This needs to be cleaned and sanitized before publication.

2 files changed, 126 insertions, 0 deletions

diff --git a/Handler/Home.hs b/Handler/Home.hs
new file mode 100644
index 0000000..3444a5b
--- /dev/null
+++ b/Handler/Home.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Home where
+
+import Import
+
+-- This is a handler function for the GET request method on the HomeR
+-- resource pattern. All of your resource patterns are defined in
+-- config/routes
+--
+-- The majority of the code you will write in Yesod lives in these handler
+-- functions. You can spread them across multiple files if you are so
+-- inclined, or create a single monolithic file.
+getHomeR :: Handler RepHtml
+getHomeR = do
+    (formWidget, formEnctype) <- generateFormPost sampleForm
+    let submission = Nothing :: Maybe (FileInfo, Text)
+        handlerName = "getHomeR" :: Text
+    defaultLayout $ do
+        aDomId <- lift newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+
+postHomeR :: Handler RepHtml
+postHomeR = do
+    ((result, formWidget), formEnctype) <- runFormPost sampleForm
+    let handlerName = "postHomeR" :: Text
+        submission = case result of
+            FormSuccess res -> Just res
+            _ -> Nothing
+
+    defaultLayout $ do
+        aDomId <- lift newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+
+sampleForm :: Form (FileInfo, Text)
+sampleForm = renderDivs $ (,)
+    <$> fileAFormReq "Choose a file"
+    <*> areq textField "What's on the file?" Nothing
diff --git a/Handler/User.hs b/Handler/User.hs
new file mode 100644
index 0000000..499ba20
--- /dev/null
+++ b/Handler/User.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.User where
+
+import Import
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Text.Read (decimal)
+import Data.Time.Clock (getCurrentTime, UTCTime, utctDay)
+import Yesod.Form.Jquery (jqueryDayField, def)
+
+getUserR :: UserId -> Handler RepHtml
+getUserR cid = do
+    user <- runDB $ get404 cid
+    ma <- maybeAuth
+    let username = userIdent user
+    let isUser = Just user == fmap entityVal ma
+    (pageNumber, pages) <- pagePosition cid
+    let doPrev = pageNumber > 1
+    let doNext = pageNumber < pages
+    let prevPageNumber = pageNumber - 1
+    let nextPageNumber = pageNumber + 1
+    let pageNavWidget = $(widgetFile "pagenav")
+    entries <- runDB $ getEntriesForPage cid pageNumber
+    cats' <- runDB $ selectList [TimeCategoryDisabled ==. False] []
+    let cats = map (\x -> ((timeCategoryName . entityVal) x, entityKey x)) cats'
+    (formWidget, formEnctype) <- generateFormPost (timeEntryForm cid cats)
+    defaultLayout $ do
+        aDomId <- lift newIdent
+        (setTitle . toHtml) ("Time entries for " `T.append` username)
+        $(widgetFile "userpage")
+
+postUserR :: UserId -> Handler RepHtml
+postUserR cid = do
+    user <- runDB $ get404 cid
+    ma <- maybeAuth
+    let username = userIdent user
+    let isUser = Just user == fmap entityVal ma
+    (pageNumber, pages) <- pagePosition cid
+    let doPrev = pageNumber > 1
+    let doNext = pageNumber < pages
+    let prevPageNumber = pageNumber - 1
+    let nextPageNumber = pageNumber + 1
+    let pageNavWidget = $(widgetFile "pagenav")
+    cats' <- runDB $ selectList [TimeCategoryDisabled ==. False] []
+    let cats = map (\x -> ((timeCategoryName . entityVal) x, entityKey x)) cats'
+    ((result, formWidget), formEnctype) <- runFormPost (timeEntryForm cid cats)
+    _ <- case result of
+            FormSuccess res -> (runDB $ insert res) >> return ()
+            _ -> return ()
+    entries <- runDB $ getEntriesForPage cid pageNumber
+
+    defaultLayout $ do
+        aDomId <- lift newIdent
+        (setTitle . toHtml) ("Entry submitted for " `T.append` username)
+        $(widgetFile "userpage")
+
+timeEntryAForm :: UTCTime -> [(Text,TimeCategoryId)] -> UserId -> AForm App App TimeEntry
+timeEntryAForm ct cats uid = TimeEntry
+    <$> pure uid
+    <*> areq (selectFieldList cats) "category" Nothing
+    <*> areq (jqueryDayField def) "day" (Just (utctDay ct))
+    <*> areq doubleField "hours" Nothing
+    <*> pure ct
+
+timeEntryForm :: UserId -> [(Text,TimeCategoryId)] -> Html -> MForm App App (FormResult TimeEntry, Widget)
+timeEntryForm u c h = do
+    ct <- liftIO getCurrentTime
+    renderDivs (timeEntryAForm ct c u) h
+
+getEntriesForPage :: UserId -> Int -> YesodDB App App [(Text, Text, Text)]
+getEntriesForPage uid pageNumber = do
+    entries <- selectList [TimeEntryUser ==. uid] [Desc TimeEntryTimestamp, LimitTo 25, OffsetBy ((pageNumber - 1) * 25)]
+    mapM (\(Entity _ e) -> cat (timeEntryCategory e) >>= \x -> return (x, hours e, day e)) entries
+    where
+	cat :: TimeCategoryId -> YesodDB App App Text
+	cat y = do x <- getJust y
+	           return $ timeCategoryName x
+	day :: TimeEntry -> Text
+	day = T.pack . show . timeEntryDay
+	hours :: TimeEntry -> Text
+	hours = T.pack . show . timeEntryHours
+
+pagePosition :: UserId -> GHandler App App (Int, Int)
+pagePosition uid = do
+    pageNumber <- fmap (either (const 1) id . fmap fst . fromMaybe (Right (1,"")) . fmap decimal) (lookupGetParam "page")
+    cnt <- runDB $ count [TimeEntryUser ==. uid]
+    return (pageNumber, ((cnt - 1) `div` 25) + 1)