diff options
Diffstat (limited to 'Handler')
| -rw-r--r-- | Handler/Home.hs | 39 | ||||
| -rw-r--r-- | Handler/User.hs | 87 |
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) |