1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
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)
|
