Polls

Application.hs

@@ -38,6 +38,7 @@ import Handler.Job
 import Handler.Team
 import Handler.Topic
 import Handler.Bling
+import Handler.Poll
 
 -- This line actually creates our YesodSite instance. It is the second half
 -- of the call to mkYesodData which occurs in Haskellers.hs. Please see

Handler/Poll.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+module Handler.Poll
+    ( getPollsR
+    , postPollsR
+    , getPollR
+    , postPollR
+    ) where
+
+import Haskellers
+import Control.Monad (unless)
+import qualified Data.Text as T
+import Data.Time (getCurrentTime)
+
+getPollsR :: Handler RepHtml
+getPollsR = do
+    polls <- runDB $ selectList [] [LimitTo 5, Desc PollCreated]
+    mu <- maybeAuth
+    let isAdmin = maybe False (userAdmin . snd) mu
+    defaultLayout $(widgetFile "polls")
+
+postPollsR :: Handler RepHtml
+postPollsR = do
+    (_, u) <- requireAuth
+    unless (userAdmin u) $ permissionDenied "Must be an admin to create a poll"
+    t <- runInputPost $ ireq textField "poll"
+    let ls = filter (not . T.null) $ T.lines t
+    unless (length ls >= 3) $ invalidArgs ["Need at least a question and two answers"]
+    let (q:as) = ls
+    now <- liftIO getCurrentTime
+    pollid <- runDB $ do
+        pollid <- insert $ Poll q now
+        mapM_ (\(a, i) -> insert $ PollOption pollid a i) $ zip as [1..]
+        return pollid
+    setMessage "Poll created"
+    redirect RedirectTemporary $ PollR pollid
+
+data OptInfo = OptInfo
+    { oiAnswer :: T.Text
+    , oiCount :: Int
+    , oiRealCount :: Int
+    }
+
+oiPercent :: Bool -> OptInfo -> [OptInfo] -> Maybe Int
+oiPercent real oi ois
+    | total == 0 = Nothing
+    | otherwise = Just $ (f oi * 100) `div` total
+  where
+    total = sum $ map f ois
+    f = if real then oiRealCount else oiCount
+
+toOI :: (PollOptionId, PollOption) -> YesodDB Haskellers Haskellers OptInfo
+toOI (poid, po) = do
+    x <- count [PollAnswerOption ==. poid]
+    y <- count [PollAnswerOption ==. poid, PollAnswerReal ==. True]
+    return $ OptInfo (pollOptionAnswer po) x y
+
+getPollR :: PollId -> Handler RepHtml
+getPollR pollid = do
+    muid <- maybeAuthId
+    (poll, ois, options, manswer) <- runDB $ do
+        poll <- get404 pollid
+        options <- selectList [PollOptionPoll ==. pollid] [Asc PollOptionPriority]
+        ois <- mapM toOI options
+        manswer <-
+            case muid of
+                Nothing -> return Nothing
+                Just uid -> do
+                    ma <- getBy $ UniquePollAnswer pollid uid
+                    case ma of
+                        Nothing -> return Nothing
+                        Just (_, pa) -> do
+                            po <- get404 $ pollAnswerOption pa
+                            return $ Just $ pollOptionAnswer po
+        return (poll, ois, options, manswer)
+    defaultLayout $(widgetFile "poll")
+
+postPollR :: PollId -> Handler RepHtml
+postPollR pollid = do
+    (uid, u) <- requireAuth
+    oidText <- runInputPost $ ireq textField "option"
+    oid <-
+        case fromSinglePiece oidText of
+            Nothing -> invalidArgs ["Invalid selection"]
+            Just x -> return x
+    o <- runDB $ get404 oid
+    unless (pollOptionPoll o == pollid) $ invalidArgs ["Poll mismatch"]
+    res <- runDB $ insertBy $ PollAnswer pollid oid uid (userReal u)
+    setMessage $ either (const "You already voted") (const "Vote cast") res
+    redirect RedirectTemporary $ PollR pollid

Haskellers.hs

@@ -12,6 +12,7 @@ module Haskellers
     , maybeAuth
     , requireAuth
     , maybeAuth'
+    , maybeAuthId
     , requireAuth'
     , module Yesod
     , module Settings
@@ -93,6 +94,9 @@ data Profile = Profile
     }
   deriving Show
 
+prettyTime :: UTCTime -> String
+prettyTime = formatTime defaultTimeLocale "%B %e, %Y %r"
+
 mkMessage "Haskellers" "messages" "en"
 
 -- This is where we define all of the routes in our application. For a full
@@ -302,6 +306,10 @@ instance YesodBreadcrumbs Haskellers where
     breadcrumb MessagesR = return ("Messages- Admin", Nothing)
     breadcrumb (AuthR LoginR) = return ("Log in to Haskellers", Just RootR)
     breadcrumb DebugR = return ("Database pool debug info", Just RootR)
+    breadcrumb PollsR = return ("Polls", Just RootR)
+    breadcrumb (PollR pollid) = do
+        poll <- runDB $ get404 pollid
+        return (pollQuestion poll, Just PollsR)
 
     breadcrumb JobsR = return ("Job Listings", Just RootR)
     breadcrumb (JobR jid) = do
@@ -476,9 +484,6 @@ getDebugR = do
                 <td>#{show (snd (snd p))}
 |]
 
-prettyTime :: UTCTime -> String
-prettyTime = formatTime defaultTimeLocale "%B %e, %Y %r"
-
 prettyDay :: Day -> String
 prettyDay = formatTime defaultTimeLocale "%B %e, %Y"
 

Model.hs

@@ -17,7 +17,7 @@ data Employment = FullTime | PartTime | FullPartTime | NotLooking
     deriving (Show, Read, Eq, Enum, Bounded)
 derivePersistField "Employment"
 
-data Service = Twitter | XMPP | AIM | Freenode
+data Service = Twitter | XMPP | AIM | Freenode | GooglePlus
     deriving (Show, Read, Eq, Enum, Bounded)
 derivePersistField "Service"
 

Settings.hs

@@ -21,6 +21,7 @@ module Settings
     ) where
 
 import qualified Text.Cassius as H
+import qualified Text.Lucius as H
 import qualified Text.Julius as H
 import Language.Haskell.TH.Syntax
 import Database.Persist.Postgresql
@@ -92,14 +93,22 @@ connectionCount = 100
 --
 -- You can see an example of how to call these functions in Handler/Root.hs
 
-toHamletFile, toCassiusFile, toJuliusFile :: String -> FilePath
+toHamletFile, toCassiusFile, toLuciusFile, toJuliusFile :: String -> FilePath
 toHamletFile x = "hamlet/" ++ x ++ ".hamlet"
 toCassiusFile x = "cassius/" ++ x ++ ".cassius"
+toLuciusFile x = "lucius/" ++ x ++ ".lucius"
 toJuliusFile x = "julius/" ++ x ++ ".julius"
 
 hamletFile :: FilePath -> Q Exp
 hamletFile = whamletFile . toHamletFile
 
+luciusFile :: FilePath -> Q Exp
+#ifdef PRODUCTION
+luciusFile = H.luciusFile . toLuciusFile
+#else
+luciusFile = H.luciusFileDebug . toLuciusFile
+#endif
+
 cassiusFile :: FilePath -> Q Exp
 #ifdef PRODUCTION
 cassiusFile = H.cassiusFile . toCassiusFile
@@ -119,7 +128,8 @@ widgetFile x = do
     let h = unlessExists toHamletFile hamletFile
     let c = unlessExists toCassiusFile cassiusFile
     let j = unlessExists toJuliusFile juliusFile
-    [|addWidget $h >> addCassius $c >> addJulius $j|]
+    let l = unlessExists toLuciusFile luciusFile
+    [|addWidget $h >> addCassius $c >> addJulius $j >> addCassius $l|]
   where
     unlessExists tofn f = do
         e <- qRunIO $ doesFileExist $ tofn x

entities

@@ -95,3 +95,16 @@ TopicMessage
     creator UserId Maybe Update Eq
     content Html
     deriving
+Poll
+    question Text
+    created UTCTime
+PollOption
+    poll PollId
+    answer Text
+    priority Int
+PollAnswer
+    poll PollId
+    option PollOptionId
+    user UserId
+    real Bool
+    UniquePollAnswer poll user

hamlet/poll.hamlet

@@ -0,0 +1,30 @@
+<h1>#{pollQuestion poll}
+$maybe _ <- muid
+    $maybe answer <- manswer
+        <p>You answered: #{answer}
+    $nothing
+        <form method=post>
+            $forall option <- options
+                $with oid <- fst option, o <- snd option
+                    <div>
+                        <input type=radio name=option id=#{toSinglePiece oid} value=#{toSinglePiece oid}>
+                        \ #
+                        <label for=#{toSinglePiece oid}>#{pollOptionAnswer o}
+            <input type=submit value=Vote>
+$nothing
+    <p>You must be logged in to submit an answer.
+<h2>Results
+<ul>
+    $forall oi <- ois
+        <li>
+            <span .answer>#{oiAnswer oi}
+            \ #
+            <span .all>
+                #{show $ oiCount oi} votes #
+                $maybe p <- oiPercent False oi ois
+                    (#{show p}%)
+            \, #
+            <span .real>
+                #{show $ oiRealCount oi} verified votes #
+                $maybe p <- oiPercent True oi ois
+                    (#{show p}%)

hamlet/polls.hamlet

@@ -0,0 +1,20 @@
+<h1>_{MsgPolls}
+$if null polls
+    <p>_{MsgNoPolls}
+<ul>
+    $forall p <- polls
+        $with pollid <- fst p, poll <- snd p
+            <li>
+                <a href=@{PollR pollid}>#{pollQuestion poll}
+                \ #
+                <span .asked>_{MsgPollAsked $ pollCreated poll}
+$if isAdmin
+    <form method=post>
+        <p>Create a new poll. Put the question on the first line, and each answer on succeeding lines.
+        <textarea name=poll>
+        <input type=submit value="Add poll">
+$else
+    <p>
+        Want to create a new poll? Just #
+        <a href="mailto:michael@snoyman.com?subject=New%20Haskellers.com%20poll">email Michael and ask
+        .

lucius/poll.lucius

@@ -0,0 +1,4 @@
+.all, .real {
+    font-size: 0.8em;
+    font-style: italic;
+}

messages/en.msg

@@ -19,3 +19,8 @@ LoginWith: Login with
 ExistingGroups: Existing Special Interest Groups
 AddGroupLong: Add new special interest group
 AddGroupShort: Add Group
+
+#polls
+Polls: Polls
+NoPolls: No polls have been created.
+PollAsked time@UTCTime: Asked on #{prettyTime time}

routes

@@ -85,3 +85,6 @@
 /bling BlingR GET
 
 /lang LangR POST
+
+/poll PollsR GET POST
+/poll/#PollId PollR GET POST