diff options
Diffstat (limited to 'Handler/User.hs')
-rw-r--r-- | Handler/User.hs | 87 |
1 files changed, 87 insertions, 0 deletions
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) |