Yesod: Help to add selectField and textAreaField [HASKELL] - haskell

i started program Haskell now. I need some help with my code, i want add selectField and TextAreaField in my form.
Like i said, i am new, i need some help to add this field do my form and recive them at JSON too at the same type
Here's my code:
{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, GADTs, FlexibleInstances,
MultiParamTypeClasses, DeriveDataTypeable,
GeneralizedNewtypeDeriving, ViewPatterns, EmptyDataDecls #-}
import Yesod
import Database.Persist.Postgresql
import Data.Text
import Control.Monad.Logger (runStdoutLoggingT)
data Pagina = Pagina{connPool :: ConnectionPool}
instance Yesod Pagina
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Animals json --JSON that send and create table at Database
nome Text
idade Int
deriving Show
|]
mkYesod "Pagina" [parseRoutes|
/ HomeR GET
/animal/cadastro AnimalR GET POST
/animal/checar/#AnimalsId ChecarAnimalR GET
/erro ErroR GET
|]
instance YesodPersist Pagina where
type YesodPersistBackend Pagina = SqlBackend
runDB f = do
master <- getYesod
let pool = connPool master
runSqlPool f pool
type Form a = Html -> MForm Handler (FormResult a, Widget)
instance RenderMessage Pagina FormMessage where
renderMessage _ _ = defaultFormMessage
------------------------
formAnimal :: Form Animals
formAnimal = renderDivs $ Animals <$>
areq textField "Nome: " Nothing <*>
areq intField "Idade: " Nothing
getAnimalR :: Handler Html
getAnimalR = do
(widget, enctype) <- generateFormPost formAnimal
defaultLayout $ do
toWidget [cassius|
label
color:blue;
|]
[whamlet|
<form method=post enctype=#{enctype} action=#{AnimalR}>
^{widget}
<input type="submit" value="Cadastrar Animal">
|]
postAnimalR :: Handler Html
postAnimalR = do
((result, _), _) <- runFormPost formAnimal
case result of
FormSuccess anim -> (runDB $ insert anim) >>= \piid -> redirect (ChecarAnimalR piid)
_ -> redirect ErroR
getHomeR :: Handler Html
getHomeR = defaultLayout [whamlet|Hello World!|]
getChecarAnimalR :: AnimalsId -> Handler Html
getChecarAnimalR pid = do
animal <- runDB $ get404 pid
defaultLayout [whamlet|
<font size="10">Perfil do Pet</font><br>
<p><b> Nome do Pet:</b> #{animalsNome animal}
<p><b> Idade do Pet:</b> #{show $ animalsIdade animal} Anos
|]
getErroR :: Handler Html
getErroR = defaultLayout [whamlet|
Falha no Cadastro !
|]
connStr = "dbname=... host=... user=... password=... port=5432"
main::IO()
main = runStdoutLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
runSqlPersistMPool (runMigration migrateAll) pool
warp 8080 (Pagina pool)

The Yesod book has a section on forms with many examples:
http://www.yesodweb.com/book/forms
Here is an example of a selection list:
carAForm :: Maybe Car -> AForm Handler Car
carAForm mcar = Car
<$> areq textField "Model" (carModel <$> mcar)
<*> areq carYearField "Year" (carYear <$> mcar)
<*> aopt (selectFieldList colors) "Color" (carColor <$> mcar)
where
colors :: [(Text, Color)]
colors = [("Red", Red), ("Blue", Blue), ("Gray", Gray), ("Black", Black)]
and for a TextArea just use the textareaField function, e.g.:
form :: UserId -> Form Blog
form userId = renderDivs $ Blog
<$> areq textField "Title" Nothing
<*> areq textareaField "Contents" Nothing
<*> pure userId
<*> lift (liftIO getCurrentTime)

Related

How add bootstrap to YesodForm

I need Help to add BootStrap to My YesodForm Project. Can you help me, guys ?
Thats my code. I just want add BootStrap styles to add to my html components
I already read aloot tutorials but are complexive, i am new at Haskell. I Need a simples thing just to that simple project. Thank.s
{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, GADTs, FlexibleInstances,
MultiParamTypeClasses, DeriveDataTypeable,
GeneralizedNewtypeDeriving, ViewPatterns, EmptyDataDecls #-}
import Yesod
import Database.Persist.Postgresql
import Data.Text
import Text.Lucius
import Control.Monad.Logger (runStdoutLoggingT)
data Pagina = Pagina{connPool :: ConnectionPool}
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Animals json
nome Text
idade Int
deriving Show
Users json
nome Text
login Text
senha Text
deriving Show
|]
mkYesod "Pagina" [parseRoutes|
/ HomeR GET
/animal/cadastro AnimalR GET POST
/animal/checar/#AnimalsId ChecarAnimalR GET
/erro ErroR GET
/login LoginR GET POST
/usuario UsuarioR GET POST
/perfil/#UsersId PerfilR GET
/admin AdminR GET
/logout LogoutR GET
|]
instance Yesod Pagina where
authRoute _ = Just LoginR
isAuthorized LoginR _ = return Authorized
isAuthorized ErroR _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized UsuarioR _ = return Authorized
isAuthorized AdminR _ = isAdmin
isAuthorized _ _ = isUser
isUser = do
mu <- lookupSession "_ID"
return $ case mu of
Nothing -> AuthenticationRequired
Just _ -> Authorized
isAdmin = do
mu <- lookupSession "_ID"
return $ case mu of
Nothing -> AuthenticationRequired
Just "admin" -> Authorized
Just _ -> Unauthorized "Acesso Restrito para Administrador"
instance YesodPersist Pagina where
type YesodPersistBackend Pagina = SqlBackend
runDB f = do
master <- getYesod
let pool = connPool master
runSqlPool f pool
type Form a = Html -> MForm Handler (FormResult a, Widget)
instance RenderMessage Pagina FormMessage where
renderMessage _ _ = defaultFormMessage
------------------------
formAnimal :: Form Animals
formAnimal = renderDivs $ Animals <$>
areq textField "Nome: " Nothing <*>
areq intField "Idade: " Nothing
formUser :: Form Users
formUser = renderDivs $ Users <$>
areq textField "Nome: " Nothing <*>
areq textField "Login: " Nothing <*>
areq passwordField "Password: " Nothing
formLogin :: Form (Text,Text)
formLogin = renderDivs $ (,) <$>
areq textField "Login: " Nothing <*>
areq passwordField "Senha: " Nothing
getAnimalR :: Handler Html
getAnimalR = do
(widget, enctype) <- generateFormPost formAnimal
defaultLayout $ do
toWidget [cassius|
label
color:blue;
|]
[whamlet|
<form .form-horizontal method=post enctype=#{enctype} action=#{AnimalR}>
^{widget}
<input type="submit" value="Cadastrar Animal">
|]
getPerfilR :: UsersId -> Handler Html
getPerfilR uid = do
user <- runDB $ get404 uid
defaultLayout $ do
toWidget $ $(luciusFile "templates/perfil.lucius")
$(whamletFile "templates/perfil.hamlet")
getUsuarioR :: Handler Html
getUsuarioR = do
(widget, enctype) <- generateFormPost formUser
defaultLayout [whamlet|
<form method=post enctype=#{enctype} action=#{UsuarioR}>
^{widget}
<input type="submit" value="Enviar">
|]
postAnimalR :: Handler Html
postAnimalR = do
((result, _), _) <- runFormPost formAnimal
case result of
FormSuccess anim -> (runDB $ insert anim) >>= \piid -> redirect (ChecarAnimalR piid)
_ -> redirect ErroR
postUsuarioR :: Handler Html
postUsuarioR = do
((result, _), _) <- runFormPost formUser
case result of
FormSuccess user -> (runDB $ insert user) >>= \piid -> redirect (PerfilR piid)
_ -> redirect ErroR
getHomeR :: Handler Html
getHomeR = defaultLayout [whamlet|Hello World!|]
addStyle :: Widget
addStyle = addStylesheetRemote "http://netdna.bootstrapcdn.com/twitter-bootstrap/2.1.0/css/bootstrap-combined.min.css"
getAdminR :: Handler Html
getAdminR = defaultLayout [whamlet|
<b><h1><font size="11"> Bem vindo ao Painel Administrativo</font></h1></b>
|]
getLoginR :: Handler Html
getLoginR = do
(widget, enctype) <- generateFormPost formLogin
defaultLayout [whamlet|
<form method=post enctype=#{enctype} action=#{LoginR}>
^{widget}
<input type="submit" value="Login">
|]
postLoginR :: Handler Html
postLoginR = do
((result, _), _) <- runFormPost formLogin
case result of
FormSuccess ("admin","eitapleuga") -> setSession "_ID" "admin" >> redirect AdminR
FormSuccess (login,senha) -> do
user <- runDB $ selectFirst [UsersLogin ==. login, UsersSenha ==. senha] []
case user of
Nothing -> redirect LoginR
Just (Entity pid u) -> setSession "_ID" (pack $ show $ fromSqlKey pid) >> redirect (PerfilR pid)
getChecarAnimalR :: AnimalsId -> Handler Html
getChecarAnimalR pid = do
animal <- runDB $ get404 pid
defaultLayout [whamlet|
<font size="10">Perfil do Pet</font><br>
<p><b> Nome do Pet:</b> #{animalsNome animal}
<p><b> Idade do Pet:</b> #{show $ animalsIdade animal} Anos
|]
getErroR :: Handler Html
getErroR = defaultLayout [whamlet|
<h1>Falha no Cadastro !</h1>
|]
getLogoutR :: Handler Html
getLogoutR = do
deleteSession "_ID"
defaultLayout [whamlet|
<h1> <b>Logout</b> efetuado com sucesso! </h1>
|]
connStr = "dbname=d4673as0stmsm7 host=ec2-54-221-225-242.compute-1.amazonaws.com user=nzjfptmglfomng password=fyYms4A9T8gkP4_Go8GswcfIiE port=5432"
main::IO()
main = runStdoutLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ do
runSqlPersistMPool (runMigration migrateAll) pool
warp 8080 (Pagina pool)
You can add it in your Handler function like this:
getUsuarioR :: Handler Html
getUsuarioR = do
(widget, enctype) <- generateFormPost formUser
defaultLayout $ do
addStylesheetRemote "http://remote-bootstrap-path.css"
[whamlet|
<form method=post enctype=#{enctype} action=#{UsuarioR}>
^{widget}
<input type="submit" value="Enviar">
|]
Also if you are new to Haskell, I would suggest you to learn some minimal Haskell before diving into Yesod.
Especially for a first project I would advise to use the scaffolded site. You can get it by following the quick start guide on the Yesod home page. Not only do you get sensible default settings, but it also has the bootstrap css already integrated.
The downside is of course that the scaffolding throws a lot of stuff and opinions at you that you might not want or not agree with. But even if you don't like the scaffolding, you can always keep one in a separate folder and just take inspiration from it and incorporate parts of it into your own site - like the integration of bootstrap or jquery.
What you need to do next is to add the appropriate classes to your html elements. There are two ways to do that, depending on the context. In your own widgets you just add them like you would any other class (with a point in front of it). If you use code that is generated, for example for forms or for yesod-table, you often have a choice between different rendering functions. For example you can render forms in two columns by using the renderTable rendering function. But there is almost always another function with a name like renderBootstrap which will render the content as plain divs with bootstrap classes.
So all in all Yesod is extremely well integrated with bootstrap. Even too much in my personal opinion. But in your case it should make your task comparatively easy after the initial setup confusion.

Persisting an uploaded file in the database (Couldn't match type ‘ConduitM () ByteString (ResourceT IO) ()’ with ‘HandlerT App IO ByteString’)

Using yesod I am trying to persist an uploaded file in the database.
To do this, I want to extract the bytestring and persist it, but I still need the code to typecheck.
The actual problem is
Couldn't match type ‘ConduitM () ByteString (ResourceT IO) ()’
with ‘HandlerT App IO ByteString’
Expected type: HandlerT App IO ByteString
Actual type: Source (ResourceT IO) ByteString
In a stmt of a 'do' block: file <- (fileSourceRaw fileinfo)
In the expression:
do { setMessageI $ MsgUploadedImg;
uuidWrapped <- liftIO (U4.nextRandom);
let uuid = fromString $ U.toString $ uuidWrapped;
transactionId <- runDB $ insert $ Transaction userId;
.... }
The relevant part is this function (see: file <- (fileSourceRaw fileinfo)).
getImgR :: Handler Html
getImgR = do
oldImages <- runDB $ selectList [] []
mauthId <- maybeAuthId
((res, widget), enctype) <- runFormPost $ form Nothing Nothing ""
case (mauthId,res) of
(Just userId, FormSuccess (title,fileinfo)) -> do
transactionId <- runDB $ insert $ Transaction userId
file <- (fileSourceRaw fileinfo)
let newImg = Img {imgFile = Just file, imgTitle = title , imgDesc = Nothing, imgFiletype = Nothing, imgTransactionId = Just transactionId, imgUserId = Just userId}
_ <- runDB $ insert newImg
redirect $ ImgR
_ -> defaultLayout
[whamlet|
$if null oldImages
<p>There are no images
$else
<ul>
$forall Entity imgId img <- oldImages
<li>
<p>#{imgTitle img}
$if mauthId == Nothing
<form method=post action=#{ImgR} enctype=#{enctype}>
<input type=submit value=_{MsgPleaseLogin}>
$else
<form method=post action=#{ImgR} enctype=#{enctype}>
^{widget}
<input type=submit>
|]
Helper code:
type MyForm = Html -> MForm Handler (FormResult (Text, FileInfo), Widget)
form :: Maybe UserId -> Maybe TransactionId -> Text -> MyForm
form userId transactionId uuid = renderBootstrap $ (,)
<$> areq textField "Title" Nothing
<*> fileAFormReq "Image file"
Img
title Text
filetype Text Maybe
desc Textarea Maybe
file ByteString Maybe
transactionId TransactionId Maybe
userId UserId Maybe
deriving Show
Still going over the documentation, but I thought the use case was common enough to ask a question. The datatype of FileInfo is:
data FileInfo = FileInfo
{ fileName :: !Text
, fileContentType :: !Text
, fileSourceRaw :: !(Source (ResourceT IO) ByteString)
, fileMove :: !(FilePath -> IO ())
}
Thank you for your attention.
Edit: I assume the solution is contained in the documentation here
http://www.yesodweb.com/blog/2013/03/simpler-streaming-responses?
Update:
It looks like one of those links
How can I post FileInfo to a web service using Yesod and Http-Conduit?
https://www.schoolofhaskell.com/school/to-infinity-and-beyond/competition-winners/part-5
Yesod handlers, content of POSTed files
contain the solution.
Update2:
Using (Data.Conduit.Binary is DCB)
file <- runResourceT $ fileSource fileinfo $$ DCB.sinkLbs
leaves me with
Handler/Img.hs:62:42:
Couldn't match expected type ‘ByteString’
with actual type ‘Data.ByteString.Lazy.Internal.ByteString’
NB: ‘ByteString’ is defined in ‘Data.ByteString.Internal’
‘Data.ByteString.Lazy.Internal.ByteString’
is defined in ‘Data.ByteString.Lazy.Internal’
In the first argument of ‘Just’, namely ‘file’
In the ‘imgFile’ field of a record
Looks like the missing function is here:
Many types of String (ByteString)
The final code is
module Handler.Img where
import Import
import LambdaCms.Core -- for UserId
import Database.Persist.Sql (toSqlKey)
-- for uuids
import qualified Data.UUID as U
import qualified Data.UUID.V4 as U4
import Yesod.Core.Types
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Binary as DCB
import Data.ByteString as BS
import Data.ByteString.Lazy as LBS
type MyForm = Html -> MForm Handler (FormResult (Text, FileInfo), Widget)
form :: Maybe UserId -> Maybe TransactionId -> Text -> MyForm
form userId transactionId uuid = renderBootstrap $ (,)
<$> areq textField "Title" Nothing
<*> fileAFormReq "Image file"
lazyToStrictBS :: LBS.ByteString -> BS.ByteString
lazyToStrictBS x = BS.concat $ LBS.toChunks x
getImgR :: Handler Html
getImgR = do
oldImages <- runDB $ selectList [] []
mauthId <- maybeAuthId
((res, widget), enctype) <- runFormPost $ form Nothing Nothing ""
case (mauthId,res) of
(Just userId, FormSuccess (title,fileinfo)) -> do
setMessageI $ MsgUploadedImg
transactionId <- runDB $ insert $ Transaction userId
file <- runResourceT $ fileSource fileinfo $$ DCB.sinkLbs
let newImg = Img {imgFile = Just (lazyToStrictBS file), imgTitle = title , imgDesc = Nothing, imgFiletype = Nothing, imgTransactionId = Just transactionId, imgUserId = Just userId}
_ <- runDB $ insert newImg
redirect $ ImgR
_ -> defaultLayout
[whamlet|
$if Import.null oldImages
<p>There are no images
$else
<ul>
$forall Entity imgId img <- oldImages
<li>
<p>#{imgTitle img}
$if mauthId == Nothing
<form method=post action=#{ImgR} enctype=#{enctype}>
<input type=submit value=_{MsgPleaseLogin}>
$else
<form method=post action=#{ImgR} enctype=#{enctype}>
^{widget}
<input type=submit>
|]
postImgR :: Handler Html
postImgR = getImgR

How to write Yesod form that checks if two fileds are the same?

Let's say we have something like this:
myForm :: Form (Text, Text)
myForm = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq passwordField (bfs ("Password" :: Text)) Nothing
<*> areq passwordField (bfs ("Repeat password" :: Text)) Nothing
Is it possible to check whether the both field are the same? Validation is
described here,
check
seems to be not powerful enough to perform this sort of check. Maybe
checkM
may be of some use?
If it's not possible to do with built-in Yesod facilities, what would be the
best work-around? I can think of:
postSomethingR :: Handler Html
postSomethingR = do
((result, form), enctype) <- runFormPost myForm
case result of
FormSuccess (password0, password1) -> do
if password0 == password1
then
-- do your thing
else
-- serve the form again and perhaps set message telling that
-- passwords don't match?
This is a working example of a custom password field that checks if the input from both boxes were the same. This comparison is created in the record fieldParse.
To run this example from cmd: stack runghc <filename.hs>
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
import Control.Applicative
import Data.Text (Text)
import Yesod
data App = App
mkYesod "App" [parseRoutes|
/ HomeR GET
|]
instance Yesod App
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
passwordConfirmField :: Field Handler Text
passwordConfirmField = Field
{ fieldParse = \rawVals _fileVals ->
case rawVals of
[a, b]
| a == b -> return $ Right $ Just a
| otherwise -> return $ Left "Passwords don't match"
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs eResult isReq ->
[whamlet|
<input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
<div>Confirm:
<input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
|]
, fieldEnctype = UrlEncoded
}
getHomeR :: Handler Html
getHomeR = do
((res, widget), enctype) <- runFormGet $ renderDivs $
areq passwordConfirmField "Password" Nothing
defaultLayout
[whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
^{widget}
<input type=submit value="Change password">
|]
main :: IO ()
main = warp 3000 App

Why is my Yesod app throwing a TlsNotSupported exception when I try to log in?

I'm trying to follow along with Yesod's cookbook for a blog. I've changed a few things such as switching to a PostgreSQL database, adding a link for GoogleEmail authentication, and moving some of the Shakespearean templates to separate files.
My problem is that when I run the app and try to authenticate, I get returned a TlsNotSupported exception and I have no idea what's causing it or how to find out. I've used both forms of authentication in a separate app and both have worked fine.
My code is below. Any help would be greatly appreciated.
{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, GADTs, FlexibleContexts,
MultiParamTypeClasses, DeriveDataTypeable #-}
import Yesod
import Yesod.Auth
import Yesod.Form.Nic (YesodNic, nicHtmlField)
import Yesod.Auth.BrowserId (authBrowserId, def)
import Yesod.Auth.GoogleEmail (authGoogleEmail)
import Data.Text (Text)
import Network.HTTP.Client (defaultManagerSettings)
import Network.HTTP.Conduit (Manager, newManager)
import Database.Persist.Postgresql
( ConnectionString, ConnectionPool, SqlPersistT, runSqlPool, runMigration
, withPostgresqlPool, runSqlPersistMPool
)
import Data.Time (UTCTime, getCurrentTime)
import Control.Applicative ((<$>), (<*>), pure)
import Data.Typeable (Typeable)
import Text.Hamlet (hamletFile)
import Text.Lucius (luciusFile)
share [mkPersist sqlOnlySettings, mkMigrate "migrateAll"]
[persistLowerCase|
User
email Text
UniqueUser email
deriving Typeable
Entry
title Text
posted UTCTime
content Html
Comment
entry EntryId
posted UTCTime
user UserId
name Text
text Textarea
|]
data Blog = Blog
{ connPool :: ConnectionPool
, httpManager :: Manager
}
mkMessage "Blog" "blog-messages" "en"
mkYesod "Blog" [parseRoutes|
/ HomeR GET
/blog BlogR GET POST
/blog/#EntryId EntryR GET POST
/auth AuthR Auth getAuth
|]
instance Yesod Blog where
approot = ApprootStatic "http://localhost:3000"
isAuthorized BlogR True = do
mauth <- maybeAuth
case mauth of
Nothing -> return AuthenticationRequired
Just (Entity _ user)
| isAdmin user -> return Authorized
| otherwise -> unauthorizedI MsgNotAnAdmin
isAuthorized (EntryR _) True = do
mauth <- maybeAuth
case mauth of
Nothing -> return AuthenticationRequired
Just _ -> return Authorized
isAuthorized _ _ = return Authorized
authRoute _ = Just (AuthR LoginR)
defaultLayout inside = do
mmsg <- getMessage
pc <- widgetToPageContent $ do
toWidget $(luciusFile "template.lucius")
inside
giveUrlRenderer $(hamletFile "template.hamlet")
isAdmin :: User -> Bool
isAdmin user = userEmail user == "xxxxx#gmail.com"
instance YesodPersist Blog where
type YesodPersistBackend Blog = SqlPersistT
runDB f = do
master <- getYesod
let pool = connPool master
runSqlPool f pool
type Form x = Html -> MForm Handler (FormResult x, Widget)
instance RenderMessage Blog FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodNic Blog
instance YesodAuth Blog where
type AuthId Blog = UserId
loginDest _ = HomeR
logoutDest _ = HomeR
authHttpManager = httpManager
authPlugins _ = [ authBrowserId def
, authGoogleEmail
]
getAuthId creds = do
let email = credsIdent creds
user = User email
res <- runDB $ insertBy user
return $ Just $ either entityKey id res
getHomeR :: Handler Html
getHomeR = defaultLayout $ do
setTitleI MsgHomepageTitle
[whamlet|
<p>_{MsgWelcomeHomepage}
<p>
<a href=#{BlogR}>_{MsgSeeArchive}
|]
entryForm :: Form Entry
entryForm = renderDivs $ Entry
<$> areq textField (fieldSettingsLabel MsgNewEntryTitle) Nothing
<*> lift (liftIO getCurrentTime)
<*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent) Nothing
getBlogR :: Handler Html
getBlogR = do
muser <- maybeAuth
entries <- runDB $ selectList [] [Desc EntryPosted]
(entryWidget, enctype) <- generateFormPost entryForm
defaultLayout $ do
setTitleI MsgBlogArchiveTitle
$(whamletFile "blog.hamlet")
postBlogR :: Handler Html
postBlogR = do
((res, entryWidget), enctype) <- runFormPost entryForm
case res of
FormSuccess entry -> do
entryId <- runDB $ insert entry
setMessageI $ MsgEntryCreated $ entryTitle entry
redirect $ EntryR entryId
_ -> defaultLayout $ do
setTitleI MsgPleaseCorrectEntry
[whamlet|
<form method=post enctype=#{enctype}>
^{entryWidget}
<div>
<input type=submit value=_{MsgNewEntry}>
|]
commentForm :: EntryId -> Form Comment
commentForm entryId = renderDivs $ Comment
<$> pure entryId
<*> lift (liftIO getCurrentTime)
<*> lift requireAuthId
<*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
<*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing
getEntryR :: EntryId -> Handler Html
getEntryR entryId = do
(entry, comments) <- runDB $ do
entry <- get404 entryId
comments <- selectList [CommentEntry ==. entryId] [Asc CommentPosted]
return (entry, map entityVal comments)
muser <- maybeAuth
(commentWidget, enctype) <- generateFormPost (commentForm entryId)
defaultLayout $ do
setTitleI $ MsgEntryTitle $ entryTitle entry
$(whamletFile "entry.hamlet")
postEntryR :: EntryId -> Handler Html
postEntryR entryId = do
((res, commentWidget), enctype) <- runFormPost (commentForm entryId)
case res of
FormSuccess comment -> do
_ <- runDB $ insert comment
setMessageI MsgCommentAdded
redirect $ EntryR entryId
_ -> defaultLayout $ do
setTitleI MsgPleaseCorrectComment
[whamlet|
<form method=post enctype=#{enctype}>
^{commentWidget}
<div>
<input type=submit value=_{MsgAddCommentButton}>
|]
openConnectionCount :: Int
openConnectionCount = 10
connStr :: ConnectionString
connStr = "host=localhost dbname=postgres user=postgres password=postgres port=5432"
main :: IO ()
main = withPostgresqlPool connStr openConnectionCount $ \pool -> do
runSqlPersistMPool (runMigration migrateAll) pool
manager <- newManager defaultManagerSettings
warp 3000 $ Blog pool manager
edit: My platform is Arch Linux.
import Network.HTTP.Client (defaultManagerSettings)
You need to use tlsManagerSettings from Network.HTTP.Client.TLS instead.

Does my compiler error really have to do with the quasiquote, or is it something more subtle?

I'm following the yesod book example about how to use monadic forms. My getRootR action was taken almost verbatim from the book. I got a compiler error, stripped the quasiquote but still got the error. Below is my error message, the code as it is, followed by what I would like getRootR to look like. Any input as to what the problem might be would be much appreciated.
ghci Rocko.hs
... several "package loading"
messages pass until ...
Rocko.hs:67:5:
Couldn't match type `handler'
with `GGHandler
Scheduler
Scheduler
(Data.Enumerator.Iteratee Data.ByteString.Internal.ByteString IO)'
`handler' is a rigid type variable bound by
the type signature for getRootR :: handler RepHtml at Rocko.hs:65:1
Expected type: handler RepHtml
Actual type: GGHandler
Scheduler
Scheduler
(Data.Enumerator.Iteratee Data.ByteString.Internal.ByteString IO)
RepHtml
Expected type: handler RepHtml
Actual type: GHandler Scheduler Scheduler RepHtml
In the return type of a call of `defaultLayout'
In the expression:
defaultLayout
(addHtml
((Text.Blaze.Internal.preEscapedText . Data.Text.pack)
"<p>Result: </p>"))
Failed, modules loaded: JsonParser.
>{-# LANGUAGE OverloadedStrings, TypeFamilies, QuasiQuotes,
TemplateHaskell, MultiParamTypeClasses #-}
>import Yesod
import Control.Applicative
import Control.Monad
import Data.Text (Text)
import Data.Time
import Yesod.Form.Jquery
import JsonParser
data Scheduler = Scheduler
mkYesod "Scheduler" [parseRoutes|
/ RootR GET
|]
instance Yesod Scheduler where
approot _ = ""
instance RenderMessage Scheduler FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodJquery Scheduler
data SelectedProduct = MKsp { product :: Text
, version :: Text
, requestedDate :: Day
} deriving Show
productForm :: Html
-> Form Scheduler Scheduler (FormResult SelectedProduct, Widget)
productForm extra = do
pInfo <- liftIO getUIdata
let products = Prelude.map productACC $ fst pInfo
versions = Prelude.map versionsACC $ snd pInfo
version' = head versions
(productRes, productView) <- mreq (radioField products) "Placeholder" Nothing
(versionRes, versionView) <- mreq (selectField version') "Placeholder" Nothing
(dateRes, dateView) <- mreq (jqueryDayField def
{ jdsChangeYear = True
, jdsYearRange = "2011:2012"
}) "Schedule" Nothing
let selectedRes = MKsp <$> productRes <*> versionRes <*> dateRes
widget = do
toWidget [whamlet|
#{extra}
<p>
^{fvInput productView}
^{fvInput versionView}
^{fvInput dateView}
<input type=submit value="aint that some &^*^">
|]
return (selectedRes, widget)
productACC :: ProductNames -> (Text,Text)
productACC (MKpn pNames) = (pNames,pNames)
versionsACC :: [ProductVersions] -> [(Text,Text)]
versionsACC pVersions = Prelude.map vACC' pVersions
where vACC' (MKpv pversions') = (pversions', pversions')
getRootR :: handler RepHtml
getRootR = do
((res, widget), enctype) <- runFormGet productForm
defaultLayout [whamlet|
<p>Result:
|]
main = return ()
-- main :: IO ()
--main = warpDebug 3000 Scheduler `
Here's what I would like getRootR to look like for now
>getRootR :: Handler RepHtml
getRootR = do
((res, widget), enctype) <- runFormGet productForm
defaultLayout [whamlet|
<p>Result: #{show res}
<form enctype=#{enctype}>
^{widget}
|]
I guess it is because you have
getRootR :: handler RepHtml
Handler should be with uppercase h.

Resources