guys, i need suggestions to add Update at my Haskell Project.
I'm using Yesod.
That's the part of my code that i List all the animals and for each one, a button to delete the animal.
How can i make a Update, like this way ?
Thanks.
getListarAnimalR :: Handler Html
getListarAnimalR = do
listaAnm <- runDB $ selectList [] [Asc AnimalsNome]
defaultLayout $ [whamlet|
<h1> Animais cadastrados:
$forall Entity pid animals <- listaAnm
<a href=#{ChecarAnimalR pid}> #{animalsNome animals}
<form method=post action=#{ChecarAnimalR pid}>
<input type="submit" value="Deletar Animal"><br>
|] >> toWidget [lucius|
form { display:inline; }
input { background-color: #ecc; border:0;}
|]
postChecarAnimalR :: AnimalsId -> Handler Html
postChecarAnimalR pid = do
runDB $ delete pid
redirect ListarAnimalR
formAnimal :: Form Animals
formAnimal = renderDivs $ Animals <$>
areq textField "Nome: " Nothing <*>
areq intField "Idade: " Nothing <*>
areq (selectField racas) "Raca" Nothing
Related
I am writing a simple website in Haskell with Yesod. I have the following hamlet
<ul id="gallery">
$forall file <- listOfFiles
<form action=#{CharacterUpdateR} method="POST">
<input type="hidden" name="Name" value=#{characterName character} />
<input type="hidden" name="Portrait" value=#{file} />
<input type="hidden" name="Description" value=#{fromMaybe "" (characterDescription character)} />
<input type="image" src=#{imageFilePath $ (++) (unpack $ characterName character) ((++) "\\" file)} name="select" alt="select" />
The following Haskell code is supposed to handle the request:
postCharacterUpdateR :: Handler Html
postCharacterUpdateR = do
((result, widget), enctype) <- runFormPost updateCharacterForm
case result of
FormSuccess (name, file, desc) -> do
_ <- runDB $ updateWhere [CharacterName ==. name] [CharacterPortrait =. file]
_ <- runDB $ updateWhere [CharacterName ==. name] [CharacterDescription =. desc]
setMessage "Character Updated"
redirect CharactersR
_ -> do
liftIO $ putStrLn $ show result
setMessage $ "Something went wrong: "
redirect CharactersR
The page renders fine and when the images in the gallery are clicked, a POST request is sent and received by the handler, but it always fails, with the following error message: FormFailure ["Value is required","Value is required"]
I have tried to send the post request via a Julius widget instead with ajax, but reached a similar problem. In the developer console, it seems like the payload for the sent POST request is fine, but nonetheless the handler never receives the POST parameters.
I fixed this issue by, rather than using Hamlet itself to create the form submission, using runFormPost to get a widget to send the request.
updateCharacterForm :: Text -> String -> Maybe Textarea -> Html -> MForm Handler (FormResult (Text, Text, Maybe Textarea), Widget)
updateCharacterForm name portrait desc = renderBootstrap $ (,,)
<$> areq hiddenField "Name" (Just name)
<*> areq hiddenField "Portrait" (Just $ pack portrait)
<*> aopt textareaField "Description" (Just desc)
In conjunction with
characterGalleryEntry :: Character -> String -> Widget
characterGalleryEntry character file = do
((_, widget), enctype) <- liftHandler $ runFormPost (updateCharacterForm (characterName character) file (characterDescription character))
[whamlet|$newline never
<form action=#{CharacterUpdateR} method=post enctype=#{enctype}>
^{widget}
<image src=#{imageFilePath $ (++) (unpack $ characterName character) ((++) "\\" file)}>
<input .btn type=submit value="Set Profile Picture and Update">
|]```
For the post itself
I am a beginner in Haskell and I am still studying and I stopped at the problem that has to do with monads.
The problem is that I want to show the comment writer in the template.
I can't do that because when I add a comment from the database it is always in the Handler monad.
Maybe my whole idea is wrong I don't know.
This is the comment entity:
ManComment
text Text sqltype=varchar(500)
created UTCTime sqltype=DateTime
writer UserId Maybe sqltype=varchar(255) default=NULL -- comment writer
manId ManifestationId sqltype=varchar(255) default=NULL
deriving Show Typeable
This is the handler function:
getManDetailsR :: ManifestationId -> Handler Html
getManDetailsR mid = do
(ui, user) <- requireAuthPair
comments <- runDB $ getComFromMan mid
defaultLayout $ do
setTitle "Manifestation details"
$(widgetFile "man-details")
Part of hamlet file (in last line trying to show writer):
$if null comments
<h4>There is not comments!
$else
$forall Entity cid com <- comments
<form method=post action=#{DeleteManCommentR mid cid}>
<li .list-group-item>
<div class="row">
<div class="col-xs-10 col-md-11">
<div>
<div .mic-info> By: <a href=#{ProfileR}>#{getCommentWriter $ com}</a>
I'm trying to get a comment writer here:
getCommentWriter :: ManComment -> Handler Text
getCommentWriter c = do
user <- runDB $ get404 $ fromJust $ manCommentWriter c --get writer from database
let username = userIdent user
return username -- but return puts in Handler monad
Eventually an error occurred:
No instance for (blaze-markup-0.8.2.7:Text.Blaze.ToMarkup
(Handler Text))
arising from a use of ‘toHtml’
you should be able to use it in the same way you use comments there: bind it to a local value and access this in your hamlet-file/code.
Of course you want to pair this up with the comment itself so I'd propose something like this:
getCommentAndWriter :: ManComment -> Handler (Entity ManComment, Text)
getCommentAndWriter c = do
user <- runDB $ get404 $ fromJust $ manCommentWriter c --get writer from database
let username = userIdent user
return (c, username)
getManDetailsR :: ManifestationId -> Handler Html
getManDetailsR mid = do
(ui, user) <- requireAuthPair
cs <- runDB $ getComFromMan mid
comments <- forM cs getCommentAndWriter
defaultLayout $ do
setTitle "Manifestation details"
$(widgetFile "man-details")
$if null comments
<h4>There is not comments!
$else
$forall (Entity cid com, writer) <- comments
<form method=post action=#{DeleteManCommentR mid cid}>
<li .list-group-item>
<div class="row">
<div class="col-xs-10 col-md-11">
<div>
<div .mic-info> By: <a href=#{ProfileR}>#{writer}</a>
Of course you should look into querying both of this together if you can but basically this should work.
PS: if you want to use more fields you probably would want to use a record - here I choose to tuple it up for simplicity.
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)
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.
I have a problem with yesod and authorization.
I get to the login page when trying to view blog posts when not logged in.
That is not what I want.
I want to be able to view blog posts even when not logged in.
I have tried to fix it but nothing has worked.
Here is the relevant sections of the code:
mkMessage "Blog" "messages" "en"
mkYesod "Blog" [parseRoutes|
/ RootR GET
/blog BlogR GET POST
/blog/#EntryId EntryR GET POST
/auth AuthR Auth getAuth
|]
instance Yesod Blog where
approot = ApprootStatic "http://localhost:3000"
defaultLayout = defLayout
authRoute _ = Just $ AuthR LoginR
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
isAdmin :: User -> Bool
isAdmin user = userEmail user == "email#something.com"
instance YesodPersist Blog where
type YesodPersistBackend Blog = SqlPersist
runDB f = do
master <- getYesod
let pool = connPool master
runSqlPool f pool
type Form x = Html -> MForm Blog Blog (FormResult x, Widget)
instance RenderMessage Blog FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodNic Blog
instance YesodAuth Blog where
type AuthId Blog = UserId
loginDest _ = RootR
logoutDest _ = RootR
authHttpManager = httpManager
authPlugins _ = [authBrowserId]
getAuthId creds = do
let email = credsIdent creds
user = User email
res <- runDB $ insertBy user
return $ Just $ either entityKey id res
getRootR :: Handler RepHtml
getRootR = defaultLayout $ do
setTitleI MsgHomepageTitle
[whamlet|
<p>_{MsgWelcomeHomepage}
<p>
<a href=#{BlogR}>_{MsgSeeArchive}
|]
entryForm :: Form Entry
entryForm = renderDivs $ Entry
<$> areq textField (fieldSettingsLabel MsgNewEntryTitle) Nothing
<*> aformM (liftIO getCurrentTime)
<*> areq nicHtmlField (fieldSettingsLabel MsgNewEntryContent)
Nothing
getBlogR :: Handler RepHtml
getBlogR = do
muser <- maybeAuth
entries <- runDB $ selectList [] [Desc EntryPosted]
(entryWidget, enctype) <- generateFormPost entryForm
defaultLayout $ do
setTitleI MsgBlogArchiveTitle
[whamlet|
$if null entries
<p>_{MsgNoEntries}
$else
<ul>
$forall Entity entryId entry <- entries
<li>
<a href=#{EntryR entryId}>#{entryTitle entry}
$maybe Entity _ user <- muser
$if isAdmin user
<form method=post enctype=#{enctype}>
^{entryWidget}
<div>
<input type=submit value=_{MsgNewEntry}>
$nothing
<p>
<a href=#{AuthR LoginR}>_{MsgLoginToPost}
|]
postBlogR :: Handler RepHtml
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}>
|]
-- comment form
commentForm :: EntryId -> Form Comment
commentForm entryId = renderDivs $ Comment
<$> pure entryId
<*> aformM (liftIO getCurrentTime)
<*> aformM requireAuthId
<*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
<*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing
getEntryR :: EntryId -> Handler RepHtml
getEntryR entryId = do
(entry, comments) <- runDB $ do
entry <- get404 entryId
comments <- selectList [] [Asc CommentPosted]
return (entry, map entityVal comments)
muser <- maybeAuth
(commentWidget, enctype) <- generateFormPost (commentForm entryId)
defaultLayout $ do
setTitleI $ MsgEntryTitle $ entryTitle entry
[whamlet|
<h1>#{entryTitle entry}
<article>#{entryContent entry}
<section .comments>
<h1>_{MsgCommentsHeading}
$if null comments
<p>_{MsgNoComments}
$else
$forall Comment _entry posted _user name text <- comments
<div .comment>
<span .by>#{name}
<span .at>#{show posted}
<div .content>#{text}
<section>
<h1>_{MsgAddCommentHeading}
$maybe Entity _ user <- muser
<form method=post enctype=#{enctype}>
^{commentWidget}
<div>
<input type=submit value=_{MsgAddCommentButton}>
$nothing
<p>
<a href=#{AuthR LoginR}>_{MsgLoginToComment}
|]
How do i fix it?
Ok, I found the problem myself.
This line gave me problems:
<*> aformM requireAuthId
I also had to remove references to the user id field where it was being used in the application.
I don't know why this problem existed in the first place because the widget should only be shown when a user is logged in.
I would however like to have the user id of the user who posted the comment is there another way to do it without reintroducing the problem I had?
Or do you think this is an error within yesod?
(This would be a comment if I was allowed to)
I'm currently learning Yesod myself so this may not be the best way to do it, but you can avoid requireAuthId in the form and still record the user id in a persist field under the comment Entity if you make your form of a different type. Instead of
commentForm :: EntryId -> Form Comment
Which is a shorthand for
commentForm :: EntryId -> Html -> MForm Blog Blog (FormResult Comment, Widget)
You could rearrange the fields and have
commentForm :: EntryId -> Html -> MForm Blog Blog (FormResult (UserId -> Comment), Widget)
and supply the user id in the POST handler.
You could even strip down the form to just
commentForm :: Html -> MForm Blog Blog (FormResult (Text, Textarea), Widget)
commentForm = renderDivs $ (,)
<$> areq textField (fieldSettingsLabel MsgCommentName) Nothing
<*> areq textareaField (fieldSettingsLabel MsgCommentText) Nothing
and supply everything else in the POST handler.
Alternatively you could probably put generateFormPost under a case branching so the form isn't generated when you aren't logged in, instead of apparently merely not being shown.