yogsototh/noodle
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix hlinter warnings

Browse source
This commit is contained in:
Konrad Merz 2015-03-30 17:01:48 +02:00
parent d03db32177
commit e5f55fe670
6 changed files with 117 additions and 162 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
src/Noodle/Views/Edit.hs
View file

@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text
import Data.Monoid ((<>))
render (pollId, pollName, pollDesc) options errors = do
render (pollId, pollName, pollDesc) options errors =
H.html $ do
H.head $ do
H.title "Noodle - The doodle"
@ -22,23 +22,20 @@ render (pollId, pollName, pollDesc) options errors = do
A.name "id"
H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add"
H.form ! A.method "post" !
A.action (H.stringValue ("/options/delete")) $ do
H.table $ do
mapM_ (renderLn) options
A.action (H.stringValue "/options/delete") $ do
H.table $ mapM_ renderLn options
H.input ! A.type_ "hidden" ! A.value (H.stringValue (show pollId)) !
A.name "id"
H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Delete"
H.a ! A.class_ "btn" ! A.href (H.stringValue ("/polls/" ++ (show pollId))) $
H.a ! A.class_ "btn" ! A.href (H.stringValue ("/polls/" ++ show pollId)) $
"To poll"
where renderErrors error = do
H.p ! A.class_ "error" $ error
H.br
renderLn (id, name, desc) = do
renderLn (id, name, desc) =
H.tr $ do
H.td $ do
H.td $
H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) !
A.type_ "checkbox"
H.td $ do
H.b $ H.toHtml $ name
H.td $ do
H.toHtml desc
H.td $ H.b $ H.toHtml name
H.td $ H.toHtml desc

20
src/Noodle/Views/EditName.hs
View file

@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text
import Data.Monoid ((<>))
render (pollId, pollName, pollDesc) errors = do
render (pollId, pollName, pollDesc) errors =
H.html $ do
H.head $ do
H.title "Noodle - The doodle"
@ -16,22 +16,18 @@ render (pollId, pollName, pollDesc) errors = do
H.h2 "Edit the poll"
mapM_ renderErrors errors
H.form ! A.class_ "form" ! A.method "post" !
A.action (H.stringValue ("/polls/" ++ (show pollId) ++ "/update")) $ do
A.action (H.stringValue ("/polls/" ++ show pollId ++ "/update")) $ do
H.table $ do
H.tr $ do
H.td $ do
H.label "Name: "
H.td $ do
H.input ! A.name "name" ! A.value (H.stringValue pollName)
H.td $ H.label "Name: "
H.td $ H.input ! A.name "name" ! A.value (H.stringValue pollName)
H.tr $ do
H.td $ do
H.label "Description: "
H.td $ do
H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $
H.toHtml pollDesc
H.td $ H.label "Description: "
H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $
H.toHtml pollDesc
H.div ! A.class_ "btns" $ do
H.a ! A.class_ "btn" ! A.href (
H.stringValue ("/polls/" ++ (show pollId))) $ "To poll"
H.stringValue ("/polls/" ++ show pollId)) $ "To poll"
H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Update Poll"
where renderErrors error = do
H.p ! A.class_ "error" $ error

13
src/Noodle/Views/Index.hs
View file

@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text
import Data.Monoid ((<>))
render items = do
render items =
H.html $ do
H.head $ do
H.title "Noodle - The doodle"
@ -15,10 +15,7 @@ render items = do
H.body $ do
H.h2 "Noodle - The doodle"
H.a ! A.class_ "btn" ! A.href "/polls/new" $ "New Poll"
H.table ! A.class_ "table" $ do
mapM_ renderLn items
where renderLn i = do
H.tr $ do
H.td $ do
H.a ! A.href ("/polls/" <> (H.stringValue (show $ fst i))) $
H.toHtml (snd i)
H.table ! A.class_ "table" $ mapM_ renderLn items
where renderLn i = H.tr $ H.td $
H.a ! A.href ("/polls/" <> H.stringValue (show $ fst i)) $
H.toHtml (snd i)

14
src/Noodle/Views/New.hs
View file

@ -7,7 +7,7 @@ import Text.Blaze.Html5.Attributes as A
import Text.Blaze.Html.Renderer.Text
import Data.Monoid ((<>))
render errors = do
render errors =
H.html $ do
H.head $ do
H.title "Noodle - The doodle"
@ -18,15 +18,11 @@ render errors = do
H.form ! A.class_ "form" ! A.method "post" ! A.action "/polls/" $ do
H.table $ do
H.tr $ do
H.td $ do
H.label "Name: "
H.td $ do
H.input ! A.name "name"
H.td $ H.label "Name: "
H.td $ H.input ! A.name "name"
H.tr $ do
H.td $ do
H.label "Description: "
H.td $ do
H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ ""
H.td $ H.label "Description: "
H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ ""
H.div ! A.class_ "btns" $ do
H.a ! A.class_ "btn" ! A.href "/polls" $ "Back"
H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add Poll"

56
src/Noodle/Views/Show.hs
View file

@ -8,7 +8,7 @@ import Text.Blaze.Html.Renderer.Text
import Data.List (intercalate)
import Data.Map as M hiding ((!))
render (pollId, pollName, pollDesc) options voters cants errors editVoter = do
render (pollId, pollName, pollDesc) options voters cants errors editVoter =
H.html $ do
H.head $ do
H.title "Noodle - The doodle"
@ -18,7 +18,7 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do
mapM_ (\x-> do H.toHtml x; H.br) (lines pollDesc)
H.br
H.a ! A.class_ "btn" ! A.href (
H.stringValue ("/polls/" ++ (show pollId) ++ "/edit_name")) $ "Edit"
H.stringValue ("/polls/" ++ show pollId ++ "/edit_name")) $ "Edit"
mapM_ renderErrors errors
H.table $ do
H.tr $ do
@ -27,31 +27,29 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do
mapM_ renderVoter $ M.keys voters
mapM_ renderCants cants
H.tr $ do
H.td $ ""
H.td ""
mapM_ renderVoteCount options
H.tr $ do
H.tr $
H.form ! A.method "post" !
A.action (H.stringValue ("/polls/" ++ (show pollId) ++ "/vote")) $ do
H.td $ do
A.action (H.stringValue ("/polls/" ++ show pollId ++ "/vote")) $ do
H.td $
H.input ! A.class_ "input" ! A.placeholder "Vote as" ! A.name "name"
mapM_ renderCheckbox options
H.td $ H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Vote"
H.br
H.a ! A.class_ "btn" ! A.href "/polls" $ "To overview"
H.a ! A.class_ "btn" !
A.href (H.stringValue ("/polls/" ++ (show pollId) ++ "/edit")) $
"Edit Options"
where renderOption (id, name, desc) = do
A.href (H.stringValue ("/polls/" ++ show pollId ++ "/edit")) $ "Edit Options"
where renderOption (id, name, desc) =
H.td $ do
H.b $ H.toHtml $ name
H.b $ H.toHtml name
H.br
H.toHtml desc
renderCheckbox (id, _, _) = do
H.td ! A.class_ "checker" $ do
H.input ! A.name "option_id" !
A.value (H.stringValue (show id)) !
renderCheckbox (id, _, _) =
H.td ! A.class_ "checker" $
H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) !
A.type_ "checkbox"
renderCants cant = do
renderCants cant =
if cant == editVoter
then renderEditVote cant
else
@ -61,46 +59,44 @@ render (pollId, pollName, pollDesc) options voters cants errors editVoter = do
H.td ! A.class_ "false" $ "") options
H.td $ H.a ! A.class_ "btn" !
A.href (H.stringValue (
"/polls/" ++ (show pollId) ++ "/vote/" ++ cant ++ "/edit")) $
"/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/edit")) $
"Edit"
H.td $ H.a ! A.class_ "btn" !
A.href (H.stringValue (
"/polls/" ++ (show pollId) ++ "/vote/" ++ cant ++ "/delete")) $
"/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/delete")) $
"Delete"
renderVoter voter = do
if (voter == editVoter)
then
renderEditVote voter
renderVoter voter =
if voter == editVoter then renderEditVote voter
else
H.tr $ do
H.td $ H.toHtml voter
mapM_ (\ (id, _, _) ->
case M.lookup voter voters of
Just ids -> do if (id `elem` ids)
then H.td ! A.class_ "true" $ "✓"
else H.td ! A.class_ "false" $ ""
Just ids -> if id `elem` ids
then H.td ! A.class_ "true" $ "✓"
else H.td ! A.class_ "false" $ ""
Nothing -> H.td ""
) options
H.td $ H.a ! A.class_ "btn" !
A.href (H.stringValue (
"/polls/" ++ (show pollId) ++ "/vote/" ++ voter ++ "/edit")) $
"/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/edit")) $
"Edit"
H.td $ H.a ! A.class_ "btn" !
A.href (H.stringValue (
"/polls/" ++ (show pollId) ++ "/vote/" ++ voter ++ "/delete")) $
"/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/delete")) $
"Delete"
renderVoteCount (id, _, _) = do
renderVoteCount (id, _, _) =
H.td ! A.class_ "count" $ H.toHtml (show count)
where count = M.fold(\ids acc ->
if id `elem` ids then acc + 1 else acc) 0 voters
renderErrors error = do
H.p ! A.class_ "error" $ error
H.br
renderEditVote voter = do
H.tr $ do
renderEditVote voter =
H.tr $
H.form ! A.method "post" !
A.action (H.stringValue (
"/polls/" ++ (show pollId) ++ "/vote")) $ do
"/polls/" ++ show pollId ++ "/vote")) $ do
H.td $ do
H.input ! A.class_ "input" ! A.disabled "disabled" !
A.name "name-disabled" ! A.value (H.stringValue voter)

157
src/main.hs
View file

@ -57,32 +57,26 @@ main = do
initDb
scottySite
scottySite = do
S.scotty 3000 $ do
S.get "/noodle.css" $ do
S.file "noodle.css"
scottySite = S.scotty 3000 $ do
S.get "/noodle.css" $ S.file "noodle.css"
S.get "/polls" $ do
polls <- liftIO $ allPolls
blaze $ Noodle.Views.Index.render $ pollNames $ polls
S.get "/" $ do
S.redirect "/polls"
S.get "/polls/new" $ do
blaze $ Noodle.Views.New.render []
polls <- liftIO allPolls
blaze $ Noodle.Views.Index.render $ pollNames polls
S.get "/" $ S.redirect "/polls"
S.get "/polls/new" $ blaze $ Noodle.Views.New.render []
S.post "/options/delete" $ do
id <- S.param "id" :: S.ActionM String
all_params <- S.params
let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id"
then (T.unpack value):acc
then T.unpack value:acc
else acc) [] all_params
deleteOptions choosen_opt_ids
S.redirect $ T.pack $ "/polls/" ++ id ++ "/edit"
S.post "/polls/:id/vote" $ do
id <- S.param "id" :: S.ActionM String
name <- S.param "name" :: S.ActionM String
options <- liftIO $ getOptionsByPollId id
(id, name, options) <- getPollFromParam
all_params <- S.params
let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id"
then (T.unpack value):acc
then T.unpack value:acc
else acc) [] all_params
case name of
"" -> showAction id ["Vote needs the name who votes."] ""
@ -107,9 +101,7 @@ scottySite = do
name <- S.param "name" :: S.ActionM String
showAction id [] name
S.get "/polls/:id/vote/:name/delete" $ do
id <- S.param "id" :: S.ActionM String
name <- S.param "name" :: S.ActionM String
options <- liftIO $ getOptionsByPollId id
(id, name, options) <- getPollFromParam
deleteVote id name (optionIds options)
S.redirect $ T.pack $ "/polls/" ++ id
S.post "/polls/:id/update" $ do
@ -130,7 +122,7 @@ scottySite = do
"" -> blaze $ Noodle.Views.New.render [ "A Poll needs a name" ]
otherwise -> do
newId <- liftIO $ createPoll name desc
S.redirect $ T.pack $ "/polls/" ++ (show (getNewPollId newId)) ++ "/edit"
S.redirect $ T.pack $ "/polls/" ++ show (getNewPollId newId) ++ "/edit"
S.post "/options/" $ do
name <- S.param "name" :: S.ActionM String
desc <- S.param "desc" :: S.ActionM String
@ -138,12 +130,19 @@ scottySite = do
poll <- liftIO $ getPollById pId
options <- liftIO $ getOptionsByPollId pId
case name of
"" -> do blaze $ Noodle.Views.Edit.render (pollValues $ head poll)
"" -> blaze $ Noodle.Views.Edit.render (pollValues $ head poll)
(optionsValues options) [ "Option needs a name" ]
otherwise -> do
createOption pId name desc
S.redirect $ T.pack $ "/polls/" ++ pId ++ "/edit"
getPollFromParam = do
id <- S.param "id" :: S.ActionM String
name <- S.param "name" :: S.ActionM String
options <- liftIO $ getOptionsByPollId id
return (id, name, options)
showAction id errors editVoter = do
poll <- liftIO $ getPollById id
options <- liftIO $ getOptionsByPollId id
@ -152,123 +151,97 @@ showAction id errors editVoter = do
blaze $ Noodle.Views.Show.render (pollValues $ head poll)
(optionsValues options) (getVoteNames voters) (cantNames cants) [] editVoter
initDb = do
runSqlite "noodle.db" $ do
runMigration migrateAll
initDb = runSqlite "noodle.db" $ runMigration migrateAll
createPoll name desc = do
runSqlite "noodle.db" $ do
id <- insert $ Poll name desc
return id
createPoll name desc = runSqlite "noodle.db" $ insert $ Poll name desc
createCant id name opt_ids = do
mapM_ (\i -> do
runSqlite "noodle.db" $ do
deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name]
) opt_ids
mapM_ (\i -> runSqlite "noodle.db" $
deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opt_ids
runSqlite "noodle.db" $ do
deleteWhere [CantPollId ==. pollId, CantName ==. name]
insert $ Cant pollId name
return ()
where pollId = (toSqlKey (read id))
where pollId = toSqlKey (read id)
updatePoll id name desc = do
runSqlite "noodle.db" $ do
replace pollId $ Poll name desc
where pollId = (toSqlKey (read id))
updatePoll id name desc = runSqlite "noodle.db" $ replace pollId $ Poll name desc
where pollId = toSqlKey (read id)
getNewPollId id = unSqlBackendKey $ unPollKey id
allPolls = do
runSqlite "noodle.db" $ do
polls <- selectList ([] :: [Filter Poll]) [LimitTo 30, Desc PollId]
return $ polls
allPolls = runSqlite "noodle.db" $
selectList ([] :: [Filter Poll]) [LimitTo 30, Desc PollId]
getPollById id = do
runSqlite "noodle.db" $ do
selectList [PollId ==. (toSqlKey (read id))] [LimitTo 1]
getPollById id = runSqlite "noodle.db" $
selectList [PollId ==. toSqlKey (read id)] [LimitTo 1]
pollNames = map (\i -> ((getPollId i), (pollName (entityVal i))))
pollNames = map (\i -> (getPollId i, pollName $ entityVal i))
cantNames c = map (\i -> (cantName (entityVal i))) c
cantNames = map $ cantName . entityVal
getPollId x = unSqlBackendKey $ unPollKey $ entityKey x
pollValues i = ((getPollId i), (pollName (entityVal i)), (pollDesc (entityVal i)))
pollValues i = (getPollId i, pollName $ entityVal i, pollDesc $ entityVal i)
optionsValues = map (\o -> ((getOptionId o),
(optionName (entityVal o)), (optionDesc (entityVal o))))
optionsValues = map (\o -> (getOptionId o, optionName $ entityVal o,
optionDesc $ entityVal o))
optionIds opts = map (\o -> getOptionId o) opts
optionIds = map getOptionId
getOptionId x = unSqlBackendKey $ unOptionKey $ entityKey x
getOptionsByPollId id = do
runSqlite "noodle.db" $ do
selectList [OptionPollId ==. (toSqlKey (read id))] []
getOptionsByPollId id = runSqlite "noodle.db" $
selectList [OptionPollId ==. toSqlKey (read id)] []
getCantsByPollId id = do
runSqlite "noodle.db" $ do
selectList [CantPollId ==. (toSqlKey (read id))] []
getCantsByPollId id = runSqlite "noodle.db" $
selectList [CantPollId ==. toSqlKey (read id)] []
createOption pId name desc = do
runSqlite "noodle.db" $ do
insert $ Option (toSqlKey (read pId)) name desc
createOption pId name desc = runSqlite "noodle.db" $ insert $
Option (toSqlKey (read pId)) name desc
getVotesByOptionIds ids = do
votes <- mapM (\ oId -> do
voters <- getVotersByOptionId oId
return (voters)) ids
let flat_votes = foldl (\acc x -> foldl (\a y -> y:a) acc x) [] votes
return flat_votes
votes <- mapM getVotersByOptionId ids
return $ foldl (foldl (flip (:))) [] votes
getVoteNames votes = foldl voteNameMap M.empty votes
getVoteNames = foldl voteNameMap M.empty
voteNameMap acc vote =
case M.lookup vName acc of
Just ids -> M.insert vName (vOptId:ids) acc
Nothing -> M.insert vName (vOptId:[]) acc
Nothing -> M.insert vName [vOptId] acc
where vName = voterName vote
vOptId = unSqlBackendKey $ unOptionKey $ voterOptId vote
voterValues = map (\(oId, voters) -> (oId, (map voterName voters)))
voterValues = map (\(oId, voters) -> (oId, map voterName voters))
voterName vote = (voteVoter (entityVal vote))
voterOptId vote = (voteOptionId (entityVal vote))
voterName vote = voteVoter (entityVal vote)
voterOptId vote = voteOptionId (entityVal vote)
getVotersByOptionId oId =
runSqlite "noodle.db" $ do
selectList [VoteOptionId ==. (toSqlKey oId)] [Asc VoteId]
getVotersByOptionId oId = runSqlite "noodle.db" $
selectList [VoteOptionId ==. toSqlKey oId] [Asc VoteId]
deleteOptions ids = do
runSqlite "noodle.db" $ do
deleteOptions ids = runSqlite "noodle.db" $
mapM_ (\id -> runSqlite "noodle.db" $ do
deleteWhere [VoteOptionId ==. id]
deleteWhere [OptionId ==. id]
) choosen_ids
where choosen_ids = map (\x -> (toSqlKey (read x))) ids
where choosen_ids = map (toSqlKey . read ) ids
voteForOptions name opts c_opt_ids id = do
mapM_ (\i -> runSqlite "noodle.db" $ do
deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name]
) opts
runSqlite "noodle.db" $ do
deleteWhere [CantPollId ==. pollId, CantName ==. name]
mapM_ (\i -> runSqlite "noodle.db" $ do
insert $ Vote i name
) choosen_ids
where choosen_ids = map (\x -> (toSqlKey (read x))) c_opt_ids
pollId = (toSqlKey (read id))
mapM_ (\i -> runSqlite "noodle.db" $
deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts
runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name]
mapM_ (\i -> runSqlite "noodle.db" $ insert $ Vote i name) choosen_ids
where choosen_ids = map (toSqlKey . read) c_opt_ids
pollId = toSqlKey (read id)
doVoting name opt_ids choosen_opt_ids id = do
case (length choosen_opt_ids) of
doVoting name opt_ids choosen_opt_ids id =
case length choosen_opt_ids of
0 -> createCant id name opt_ids
otherwise -> voteForOptions name opt_ids choosen_opt_ids id
deleteVote id name opts = do
mapM_ (\i -> runSqlite "noodle.db" $ do
deleteWhere [VoteOptionId ==. (toSqlKey i), VoteVoter ==. name]
) opts
runSqlite "noodle.db" $ do
deleteWhere [CantPollId ==. pollId, CantName ==. name]
where pollId = (toSqlKey (read id))
mapM_ (\i -> runSqlite "noodle.db" $
deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts
runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name]
where pollId = toSqlKey (read id)