├── .gitignore ├── Setup.hs ├── noodle.png ├── .noodle.db.txt ├── README.md ├── src ├── Noodle │ └── Views │ │ ├── Index.hs │ │ ├── New.hs │ │ ├── EditName.hs │ │ ├── Edit.hs │ │ └── Show.hs └── main.hs ├── noodle.cabal ├── LICENSE └── noodle.css /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .*.swp 3 | noodle.db 4 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /noodle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kmerz/noodle/HEAD/noodle.png -------------------------------------------------------------------------------- /.noodle.db.txt: -------------------------------------------------------------------------------- 1 | fromList [(2,Poll {name = "Was wollen wir trinken?", opts = fromList [(1,Opt {desc = "Bier", up = [], down = []}),(2,Opt {desc = "Wein", up = [], down = []}),(3,Opt {desc = "Wasser", up = [], down = []}),(4,Opt {desc = "Kaffee", up = [], down = []}),(5,Opt {desc = "Saft", up = [], down = []})]})] 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Noodle - The doodle 2 | 3 | ![Screenshot](https://raw.github.com/kmerz/noodle/master/noodle.png) 4 | 5 | Noodle is a doodle clone written in haskell with: 6 | * [scotty](https://github.com/scotty-web/scotty) 7 | * [persistent](https://github.com/yesodweb/persistent) 8 | * [sqlite3](https://www.sqlite.org/) 9 | 10 | Even though it is a project to explore the possibilties of haskell in web 11 | development, it is designed as a inhouse doodle solution to fit the needs of 12 | privacy. 13 | 14 | To build the project you need a updated version of cabal and following 15 | commands: 16 | 17 | ``` 18 | cabal configure 19 | cabal install 20 | cabal build 21 | ``` 22 | 23 | After that place `./dist/build/noodle/noodle` and `noodle.css` beside each other 24 | into the desired directory and start it with: `./noodle` or a shell script 25 | or something. 26 | 27 | If you liked this project please have a look at my paste bin clone in rails: 28 | [graveio](https://github.com/kmerz/graveio) 29 | -------------------------------------------------------------------------------- /src/Noodle/Views/Index.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Noodle.Views.Index where 4 | 5 | import Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5.Attributes as A 7 | import Text.Blaze.Html.Renderer.Text 8 | import Data.Monoid ((<>)) 9 | 10 | render items = 11 | H.html $ do 12 | H.head $ do 13 | H.title "Noodle - The doodle" 14 | H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/noodle.css" 15 | H.body $ do 16 | H.h2 ! A.class_ "header" $ "Noodle - The doodle" 17 | H.h3 ! A.class_ "title" $ "All polls" 18 | H.div ! A.class_ "container" $ do 19 | H.a ! A.class_ "btn" ! A.href "/polls/new" $ "New Poll" 20 | H.table ! A.class_ "table" $ mapM_ renderLn items 21 | where renderLn i = H.tr $ do 22 | H.td $ H.a ! A.href ("/polls/" <> H.stringValue (show $ fst i)) $ 23 | H.toHtml (snd i) 24 | H.td $ H.a ! A.class_ "btn" ! 25 | A.href (H.stringValue ("/polls/" ++ (show $ fst i) ++ "/delete")) $ 26 | "delete" 27 | -------------------------------------------------------------------------------- /noodle.cabal: -------------------------------------------------------------------------------- 1 | -- Initial noodle.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: noodle 5 | version: 0.1.0.0 6 | synopsis: Noodle - The real doole 7 | -- description: 8 | homepage: https://github.com/kmerz/noodle 9 | license: BSD2 10 | license-file: LICENSE 11 | author: Konrad Merz 12 | maintainer: kmerz@hulud.net 13 | -- copyright: 14 | category: Web 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | executable noodle 20 | main-is: main.hs 21 | other-modules: Noodle.Views.Index, Noodle.Views.Show, Noodle.Views.New 22 | Noodle.Views.Edit, Noodle.Views.EditName 23 | -- other-extensions: 24 | build-depends: base >=4.7 && <4.8, scotty, blaze-html, monads-tf, 25 | persistent, persistent-sqlite, time, transformers, 26 | persistent-template, resourcet, text, containers 27 | hs-source-dirs: src 28 | default-language: Haskell2010 29 | -------------------------------------------------------------------------------- /src/Noodle/Views/New.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Noodle.Views.New where 4 | 5 | import Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5.Attributes as A 7 | import Text.Blaze.Html.Renderer.Text 8 | import Data.Monoid ((<>)) 9 | 10 | render errors = 11 | H.html $ do 12 | H.head $ do 13 | H.title "Noodle - The doodle" 14 | H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/noodle.css" 15 | H.body $ do 16 | H.h2 ! A.class_ "header" $ "Noodle - The doodle" 17 | H.h3 ! A.class_ "title" $ "Create a poll" 18 | H.div ! A.class_ "container" $ do 19 | mapM_ renderErrors errors 20 | H.form ! A.class_ "form" ! A.method "post" ! A.action "/polls/" $ do 21 | H.table $ do 22 | H.tr $ do 23 | H.td $ H.label "Name: " 24 | H.td $ H.input ! A.name "name" 25 | H.tr $ do 26 | H.td $ H.label "Description: " 27 | H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ "" 28 | H.div ! A.class_ "btns" $ do 29 | H.a ! A.class_ "btn" ! A.href "/polls" $ "Back" 30 | H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add Poll" 31 | where renderErrors error = do 32 | H.p ! A.class_ "error" $ error 33 | H.br 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Konrad Merz 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the 14 | distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 22 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 23 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 24 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 26 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /src/Noodle/Views/EditName.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Noodle.Views.EditName where 4 | 5 | import Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5.Attributes as A 7 | import Text.Blaze.Html.Renderer.Text 8 | import Data.Monoid ((<>)) 9 | 10 | render (pollId, pollName, pollDesc) errors = 11 | H.html $ do 12 | H.head $ do 13 | H.title "Noodle - The doodle" 14 | H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/noodle.css" 15 | H.body $ do 16 | H.h2 ! A.class_ "header" $ "Noodle - The doodle" 17 | H.h3 ! A.class_ "title" $ "Edit the poll" 18 | H.div ! A.class_ "container" $ do 19 | mapM_ renderErrors errors 20 | H.form ! A.class_ "form" ! A.method "post" ! 21 | A.action (H.stringValue ("/polls/" ++ show pollId ++ "/update")) $ do 22 | H.table $ do 23 | H.tr $ do 24 | H.td $ H.label "Name: " 25 | H.td $ H.input ! A.name "name" ! A.value (H.stringValue pollName) 26 | H.tr $ do 27 | H.td $ H.label "Description: " 28 | H.td $ H.textarea ! A.name "desc" ! A.cols "50" ! A.rows "10" $ 29 | H.toHtml pollDesc 30 | H.div ! A.class_ "btns" $ do 31 | H.a ! A.class_ "btn" ! A.href ( 32 | H.stringValue ("/polls/" ++ show pollId)) $ "To poll" 33 | H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Update Poll" 34 | where renderErrors error = do 35 | H.p ! A.class_ "error" $ error 36 | H.br 37 | -------------------------------------------------------------------------------- /src/Noodle/Views/Edit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Noodle.Views.Edit where 4 | 5 | import Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5.Attributes as A 7 | import Text.Blaze.Html.Renderer.Text 8 | 9 | render (pollId, pollName, pollDesc) options errors = 10 | H.html $ do 11 | H.head $ do 12 | H.title "Noodle - The doodle" 13 | H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/noodle.css" 14 | H.body $ do 15 | H.h2 ! A.class_ "header" $ "Noodle - The doodle" 16 | H.h3 ! A.class_ "title" $ toHtml $ "Edit options of " ++ pollName 17 | H.div ! A.class_ "container" $ do 18 | mapM_ renderErrors errors 19 | H.form ! A.method "post" ! A.action "/options/" $ do 20 | H.input ! A.class_ "input" ! A.placeholder "add a option" ! 21 | A.name "name" 22 | H.input ! A.class_ "input" ! A.placeholder "with description" ! 23 | A.name "desc" 24 | H.input ! A.type_ "hidden" ! A.value (H.stringValue (show pollId)) ! 25 | A.name "id" 26 | H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Add" 27 | H.form ! A.method "post" ! 28 | A.action (H.stringValue "/options/delete") $ do 29 | H.table $ mapM_ renderLn options 30 | H.input ! A.type_ "hidden" ! A.value (H.stringValue (show pollId)) ! 31 | A.name "id" 32 | H.input ! A.class_ "btn" ! A.type_ "submit" ! A.value "Delete" 33 | H.a ! A.class_ "btn" ! 34 | A.href (H.stringValue ("/polls/" ++ show pollId)) $ "To poll" 35 | where renderErrors error = do 36 | H.p ! A.class_ "error" $ error 37 | H.br 38 | renderLn (id, name, desc) = 39 | H.tr $ do 40 | H.td $ 41 | H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) ! 42 | A.type_ "checkbox" 43 | H.td $ H.b $ H.toHtml name 44 | H.td $ H.toHtml desc 45 | -------------------------------------------------------------------------------- /noodle.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: Sans; 3 | } 4 | 5 | h2.header { 6 | font-weight: lighter; 7 | width: 100%; 8 | border-bottom: 1px solid #ddd; 9 | } 10 | 11 | h3.title { 12 | font-weight: lighter; 13 | } 14 | 15 | .container { 16 | margin: 30px 20px; 17 | } 18 | 19 | .poll-name { 20 | font-weight: normal; 21 | border-bottom: 1px solid #ddd; 22 | margin-bottom: 10px; 23 | } 24 | 25 | .poll-desc { 26 | font-family: monospace; 27 | margin-bottom: 20px; 28 | padding: 5px 5px 30px 5px; 29 | background-color: #ddd; 30 | } 31 | 32 | .opt-edit.btn { 33 | float: right; 34 | border: 1px solid #bbb; 35 | } 36 | 37 | .table { 38 | border-collapse: collapse; 39 | margin-top: 25px; 40 | width: 100%; 41 | } 42 | 43 | .table td { 44 | padding-bottom: 5px; 45 | padding-top: 5px; 46 | border-bottom: 1px solid #ddd; 47 | border-top: 1px solid #ddd; 48 | } 49 | 50 | .table .btn { 51 | float: right; 52 | } 53 | 54 | .table a { 55 | text-decoration: none; 56 | } 57 | 58 | .table a, .table a:visited, .table a:active, .table a:link { 59 | color: #819FF7; 60 | } 61 | 62 | .table a:hover { 63 | color: #045FB4; 64 | } 65 | 66 | .btns { 67 | margin-top: 10px; 68 | } 69 | 70 | .btn { 71 | text-decoration: none; 72 | background-color: #eee; 73 | color: #111; 74 | padding: 3px 6px 3px 6px; 75 | border: none; 76 | font-size: 16px; 77 | margin-right: 8px; 78 | } 79 | 80 | a.btn.td-edit { 81 | color: #819FF7; 82 | } 83 | a.btn.td-delete { 84 | color: #819FF7; 85 | } 86 | 87 | .input { 88 | font-size: 14px; 89 | margin-right: 5px; 90 | padding-left: 5px; 91 | } 92 | 93 | .error { 94 | background-color: #F78181; 95 | padding: 5px; 96 | } 97 | 98 | .voters { 99 | padding-left: 20px; 100 | } 101 | 102 | .true { 103 | background-color: #BCF5A9; 104 | color: #fff; 105 | text-align: center; 106 | } 107 | 108 | .false { 109 | background-color: #F5BCA9; 110 | } 111 | 112 | .checker { 113 | text-align: center; 114 | } 115 | 116 | .count { 117 | text-align: center; 118 | background-color: #819FF7; 119 | color: #fff; 120 | } 121 | -------------------------------------------------------------------------------- /src/Noodle/Views/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Noodle.Views.Show where 4 | 5 | import Text.Blaze.Html5 as H 6 | import Text.Blaze.Html5.Attributes as A 7 | import Text.Blaze.Html.Renderer.Text 8 | import Data.List (intercalate) 9 | import Data.Map as M hiding ((!)) 10 | 11 | render (pollId, pollName, pollDesc) options voters cants errors editVoter = 12 | H.html $ do 13 | H.head $ do 14 | H.title "Noodle - The doodle" 15 | H.link ! A.rel "stylesheet" ! A.type_ "text/css" ! A.href "/noodle.css" 16 | H.body $ do 17 | H.h2 ! A.class_ "header" $ "Noodle - The doodle" 18 | H.h3 ! A.class_ "title" $ "Show poll" 19 | H.div ! A.class_ "container" $ do 20 | H.div ! A.class_ "poll" $ do 21 | H.h4 ! A.class_ "poll-name" ! A.class_ "title" $ toHtml pollName 22 | H.div ! A.class_ "poll-desc" $ do 23 | mapM_ (\x-> do H.toHtml x; H.br) (lines pollDesc) 24 | H.a ! A.class_ "opt-edit btn" ! A.href ( 25 | H.stringValue ("/polls/" ++ show pollId ++ "/edit_name")) $ "Edit" 26 | mapM_ renderErrors errors 27 | H.table $ do 28 | H.tr $ do 29 | H.td "" 30 | mapM_ renderOption options 31 | H.tr $ do 32 | H.td "" 33 | mapM_ renderVoteCount options 34 | mapM_ renderVoter $ M.keys voters 35 | mapM_ renderCants cants 36 | H.tr $ 37 | H.form ! A.method "post" ! A.action 38 | (H.stringValue ("/polls/" ++ show pollId ++ "/vote")) $ do 39 | H.td $ 40 | H.input ! A.class_ "input" ! A.placeholder "Vote as" ! 41 | A.name "name" 42 | mapM_ renderCheckbox options 43 | H.td $ H.input ! A.class_ "btn" ! A.type_ "submit" ! 44 | A.value "Vote" 45 | H.br 46 | H.a ! A.class_ "btn" ! A.href "/polls" $ "To overview" 47 | H.a ! A.class_ "btn" ! 48 | A.href (H.stringValue ("/polls/" ++ show pollId ++ "/edit")) $ 49 | "Edit Options" 50 | where renderOption (id, name, desc) = 51 | H.td $ do 52 | H.b $ H.toHtml name 53 | H.br 54 | H.toHtml desc 55 | renderCheckbox (id, _, _) = 56 | H.td ! A.class_ "checker" $ 57 | H.input ! A.name "option_id" ! A.value (H.stringValue (show id)) ! 58 | A.type_ "checkbox" 59 | renderCants cant = 60 | if cant == editVoter 61 | then renderEditVote cant 62 | else 63 | H.tr $ do 64 | H.td $ H.toHtml cant 65 | mapM_ (\ (_, _, _) -> 66 | H.td ! A.class_ "false" $ "") options 67 | H.td $ H.a ! A.class_ "btn td-edit" ! 68 | A.href (H.stringValue ( 69 | "/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/edit")) $ 70 | "edit" 71 | H.td $ H.a ! A.class_ "btn td-delete" ! 72 | A.href (H.stringValue ( 73 | "/polls/" ++ show pollId ++ "/vote/" ++ cant ++ "/delete")) $ 74 | "delete" 75 | renderVoter voter = 76 | if voter == editVoter then renderEditVote voter 77 | else 78 | H.tr $ do 79 | H.td $ H.toHtml voter 80 | mapM_ (\ (id, _, _) -> 81 | case M.lookup voter voters of 82 | Just ids -> if id `elem` ids 83 | then H.td ! A.class_ "true" $ "✓" 84 | else H.td ! A.class_ "false" $ "" 85 | Nothing -> H.td "" 86 | ) options 87 | H.td $ H.a ! A.class_ "btn td-edit" ! 88 | A.href (H.stringValue ( 89 | "/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/edit")) $ 90 | "edit" 91 | H.td $ H.a ! A.class_ "btn td-delete" ! 92 | A.href (H.stringValue ( 93 | "/polls/" ++ show pollId ++ "/vote/" ++ voter ++ "/delete")) $ 94 | "delete" 95 | renderVoteCount (id, _, _) = 96 | H.td ! A.class_ "count" $ H.toHtml (show count) 97 | where count = M.fold(\ids acc -> 98 | if id `elem` ids then acc + 1 else acc) 0 voters 99 | renderErrors error = do 100 | H.p ! A.class_ "error" $ error 101 | H.br 102 | renderEditVote voter = 103 | H.tr $ 104 | H.form ! A.method "post" ! 105 | A.action (H.stringValue ( 106 | "/polls/" ++ show pollId ++ "/vote")) $ do 107 | H.td $ do 108 | H.input ! A.class_ "input" ! A.disabled "disabled" ! 109 | A.name "name-disabled" ! A.value (H.stringValue voter) 110 | H.input ! A.class_ "input" ! A.type_ "hidden" ! 111 | A.name "name" ! A.value (H.stringValue voter) 112 | mapM_ renderCheckbox options 113 | H.td $ H.input ! A.class_ "btn" ! A.type_ "submit" ! 114 | A.value "Update" 115 | -------------------------------------------------------------------------------- /src/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE QuasiQuotes #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | import Control.Monad.Trans (liftIO) 12 | import Control.Monad (filterM) 13 | import qualified Web.Scotty as S 14 | import qualified Text.Blaze.Html5 as H 15 | import qualified Text.Blaze.Html5.Attributes as A 16 | import Text.Blaze.Html.Renderer.Text 17 | import Database.Persist 18 | import Database.Persist.Sqlite 19 | import Database.Persist.TH 20 | import Control.Monad.IO.Class (liftIO) 21 | import Data.Time (UTCTime, getCurrentTime) 22 | import qualified Data.Map as M 23 | import Data.Text.Lazy as T (unpack, pack) 24 | import Data.Monoid (mconcat) 25 | import System.Environment (getArgs) 26 | 27 | import qualified Noodle.Views.Index 28 | import qualified Noodle.Views.Show 29 | import qualified Noodle.Views.New 30 | import qualified Noodle.Views.Edit 31 | import qualified Noodle.Views.EditName 32 | 33 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 34 | Poll 35 | name String 36 | desc String 37 | createdAt UTCTime 38 | deriving Show 39 | Cant 40 | pollId PollId 41 | name String 42 | createdAt UTCTime 43 | UniqueCant pollId name 44 | deriving Show 45 | Option 46 | pollId PollId 47 | name String 48 | desc String 49 | createdAt UTCTime 50 | deriving Show 51 | Vote 52 | optionId OptionId 53 | voter String 54 | createdAt UTCTime 55 | UniqueVote optionId voter 56 | deriving Show 57 | |] 58 | 59 | blaze = S.html . renderHtml 60 | main :: IO () 61 | main = do 62 | args <- getArgs 63 | initDb 64 | scottySite $ getPort args 65 | 66 | getPort :: [String] -> Int 67 | getPort [] = 80 68 | getPort args = head $ map (\ p -> (read p :: Int)) args 69 | 70 | scottySite port = S.scotty port $ do 71 | S.get "/noodle.css" $ S.file "noodle.css" 72 | S.get "/polls" $ do 73 | polls <- liftIO getPolls 74 | blaze $ Noodle.Views.Index.render $ pollNames polls 75 | S.get "/" $ S.redirect "/polls" 76 | S.get "/polls/new" $ blaze $ Noodle.Views.New.render [] 77 | S.post "/options/delete" $ do 78 | id <- S.param "id" :: S.ActionM String 79 | all_params <- S.params 80 | let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id" 81 | then T.unpack value:acc 82 | else acc) [] all_params 83 | deleteOptions choosen_opt_ids 84 | S.redirect $ T.pack $ "/polls/" ++ id ++ "/edit" 85 | S.get "/polls/:id/delete" $ do 86 | id <- S.param "id" 87 | options <- liftIO $ getOptionsByPollId id 88 | mapM_ (\oid -> runSqlite "noodle.db" $ do 89 | deleteWhere [VoteOptionId ==. oid] 90 | deleteWhere [OptionId ==. oid] 91 | ) (map toSqlKey (optionIds options)) 92 | deletePoll id 93 | S.redirect "/polls" 94 | S.post "/polls/:id/vote" $ do 95 | (id, name, options) <- getPollFromParam 96 | all_params <- S.params 97 | let choosen_opt_ids = foldl (\ acc (key, value) -> if key == "option_id" 98 | then T.unpack value:acc 99 | else acc) [] all_params 100 | case (validVote name) of 101 | False -> (showAction id 102 | ["Vote needs the name who votes and must not contain '?'."] "") 103 | otherwise -> do 104 | doVoting name (optionIds options) choosen_opt_ids id 105 | S.redirect $ T.pack $ "/polls/" ++ id 106 | S.get "/polls/:id/edit" $ do 107 | id <- S.param "id" 108 | poll <- liftIO $ getPollById id 109 | options <- liftIO $ getOptionsByPollId id 110 | blaze $ Noodle.Views.Edit.render 111 | (pollValues $ head poll) (optionsValues options) [] 112 | S.get "/polls/:id/edit_name" $ do 113 | id <- S.param "id" 114 | poll <- liftIO $ getPollById id 115 | blaze $ Noodle.Views.EditName.render (pollValues $ head poll) [] 116 | S.get "/polls/:id" $ do 117 | id <- S.param "id" 118 | showAction id [] "" 119 | S.get "/polls/:id/vote/:name/edit" $ do 120 | id <- S.param "id" :: S.ActionM String 121 | name <- S.param "name" :: S.ActionM String 122 | showAction id [] name 123 | S.get "/polls/:id/vote/:name/delete" $ do 124 | (id, name, options) <- getPollFromParam 125 | deleteVote id name (optionIds options) 126 | S.redirect $ T.pack $ "/polls/" ++ id 127 | S.post "/polls/:id/update" $ do 128 | id <- S.param "id" 129 | name <- S.param "name" 130 | desc <- S.param "desc" 131 | poll <- liftIO $ getPollById id 132 | case name of 133 | "" -> blaze $ Noodle.Views.EditName.render (pollValues $ head poll) 134 | [ "Poll needs a name" ] 135 | otherwise -> do 136 | updatePoll id name desc 137 | S.redirect $ T.pack $ "/polls/" ++ id 138 | S.post "/polls/" $ do 139 | name <- S.param "name" 140 | desc <- S.param "desc" 141 | case name of 142 | "" -> blaze $ Noodle.Views.New.render [ "A Poll needs a name" ] 143 | otherwise -> do 144 | newId <- liftIO $ createPoll name desc 145 | S.redirect $ T.pack $ "/polls/" ++ show (getNewPollId newId) ++ "/edit" 146 | S.post "/options/" $ do 147 | name <- S.param "name" :: S.ActionM String 148 | desc <- S.param "desc" :: S.ActionM String 149 | pId <- S.param "id":: S.ActionM String 150 | poll <- liftIO $ getPollById pId 151 | options <- liftIO $ getOptionsByPollId pId 152 | case name of 153 | "" -> blaze $ Noodle.Views.Edit.render (pollValues $ head poll) 154 | (optionsValues options) [ "Option needs a name" ] 155 | otherwise -> do 156 | createOption pId name desc 157 | S.redirect $ T.pack $ "/polls/" ++ pId ++ "/edit" 158 | 159 | getPollFromParam = do 160 | id <- S.param "id" :: S.ActionM String 161 | name <- S.param "name" :: S.ActionM String 162 | options <- liftIO $ getOptionsByPollId id 163 | return (id, name, options) 164 | 165 | 166 | showAction id errors editVoter = do 167 | poll <- liftIO $ getPollById id 168 | options <- liftIO $ getOptionsByPollId id 169 | voters <- liftIO $ getVotesByOptionIds (optionIds options) 170 | cants <- liftIO $ getCantsByPollId id 171 | blaze $ (Noodle.Views.Show.render (pollValues $ head poll) 172 | (optionsValues options) (getVoteNames voters) (cantNames cants) errors 173 | editVoter) 174 | 175 | initDb = runSqlite "noodle.db" $ runMigration migrateAll 176 | 177 | createPoll name desc = do 178 | now <- liftIO $ getCurrentTime 179 | runSqlite "noodle.db" $ insert $ Poll name desc now 180 | 181 | createCant id name opt_ids = do 182 | now <- liftIO $ getCurrentTime 183 | mapM_ (\i -> runSqlite "noodle.db" $ 184 | deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opt_ids 185 | runSqlite "noodle.db" $ do 186 | deleteWhere [CantPollId ==. pollId, CantName ==. name] 187 | insert $ Cant pollId name now 188 | return () 189 | where pollId = toSqlKey (read id) 190 | 191 | deletePoll id = runSqlite "noodle.db" $ do 192 | deleteWhere [CantPollId ==. pollId] 193 | deleteWhere [PollId ==. pollId] 194 | where pollId = toSqlKey (read id) 195 | 196 | updatePoll id name desc = do 197 | now <- liftIO $ getCurrentTime 198 | runSqlite "noodle.db" $ replace pollId $ Poll name desc now 199 | where pollId = toSqlKey (read id) 200 | 201 | getNewPollId id = unSqlBackendKey $ unPollKey id 202 | 203 | getPolls = runSqlite "noodle.db" $ 204 | selectList ([] :: [Filter Poll]) [LimitTo 30, Desc PollId] 205 | 206 | getPollById id = runSqlite "noodle.db" $ 207 | selectList [PollId ==. toSqlKey (read id)] [LimitTo 1] 208 | 209 | pollNames = map (\i -> (getPollId i, pollName $ entityVal i)) 210 | 211 | cantNames = map $ cantName . entityVal 212 | 213 | getPollId x = unSqlBackendKey $ unPollKey $ entityKey x 214 | 215 | pollValues i = (getPollId i, pollName $ entityVal i, pollDesc $ entityVal i) 216 | 217 | optionsValues = map (\o -> (getOptionId o, optionName $ entityVal o, 218 | optionDesc $ entityVal o)) 219 | 220 | optionIds = map getOptionId 221 | 222 | getOptionId x = unSqlBackendKey $ unOptionKey $ entityKey x 223 | 224 | getOptionsByPollId id = runSqlite "noodle.db" $ 225 | selectList [OptionPollId ==. toSqlKey (read id)] [] 226 | 227 | getCantsByPollId id = runSqlite "noodle.db" $ 228 | selectList [CantPollId ==. toSqlKey (read id)] [] 229 | 230 | createOption pId name desc = do 231 | now <- liftIO $ getCurrentTime 232 | runSqlite "noodle.db" $ insert $ 233 | Option (toSqlKey (read pId)) name desc now 234 | 235 | getVotesByOptionIds ids = do 236 | votes <- mapM getVotersByOptionId ids 237 | return $ foldl (foldl (flip (:))) [] votes 238 | 239 | getVoteNames = foldl voteNameMap M.empty 240 | 241 | voteNameMap acc vote = 242 | case M.lookup vName acc of 243 | Just ids -> M.insert vName (vOptId:ids) acc 244 | Nothing -> M.insert vName [vOptId] acc 245 | where vName = voterName vote 246 | vOptId = unSqlBackendKey $ unOptionKey $ voterOptId vote 247 | 248 | voterValues = map (\(oId, voters) -> (oId, map voterName voters)) 249 | 250 | voterName vote = voteVoter (entityVal vote) 251 | voterOptId vote = voteOptionId (entityVal vote) 252 | 253 | getVotersByOptionId oId = runSqlite "noodle.db" $ 254 | selectList [VoteOptionId ==. toSqlKey oId] [Asc VoteCreatedAt] 255 | 256 | deleteOptions ids = runSqlite "noodle.db" $ 257 | mapM_ (\id -> runSqlite "noodle.db" $ do 258 | deleteWhere [VoteOptionId ==. id] 259 | deleteWhere [OptionId ==. id] 260 | ) choosen_ids 261 | where choosen_ids = map (toSqlKey . read ) ids 262 | 263 | voteForOptions name opts c_opt_ids id = do 264 | now <- liftIO $ getCurrentTime 265 | mapM_ (\i -> runSqlite "noodle.db" $ 266 | deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts 267 | runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name] 268 | mapM_ (\i -> runSqlite "noodle.db" $ insert $ Vote i name now) choosen_ids 269 | where choosen_ids = map (toSqlKey . read) c_opt_ids 270 | pollId = toSqlKey (read id) 271 | 272 | doVoting name opt_ids choosen_opt_ids id = 273 | case length choosen_opt_ids of 274 | 0 -> createCant id name opt_ids 275 | otherwise -> voteForOptions name opt_ids choosen_opt_ids id 276 | 277 | deleteVote id name opts = do 278 | mapM_ (\i -> runSqlite "noodle.db" $ 279 | deleteWhere [VoteOptionId ==. toSqlKey i, VoteVoter ==. name]) opts 280 | runSqlite "noodle.db" $ deleteWhere [CantPollId ==. pollId, CantName ==. name] 281 | where pollId = toSqlKey (read id) 282 | 283 | validVote name = validLength && validChars 284 | where validLength = (length name) > 0 285 | validChars = foldl (\ acc c -> c /= '?' && acc) True name 286 | --------------------------------------------------------------------------------