summaryrefslogtreecommitdiff
path: root/Handler/User.hs
blob: e89b3659d2b12d9f57d6347c6028ce2bd1f73de5 (plain)
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
88
89
90
91
{-# 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.Auth (maybeAuth)
import Yesod.Form.Jquery (jqueryDayField, def)

getUserR :: UserId -> Handler RepHtml
getUserR cid = do
    user <- runDB $ get404 cid
    ma <- maybeAuth
    let username = userIdent user
    let isThisUser = 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'
    employments <- runDB $ selectList [EmploymentUser ==. cid] [Asc EmploymentStartDate]
    (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 isThisUser = 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'
    employments <- runDB $ selectList [EmploymentUser ==. cid] [Asc EmploymentStartDate]
    ((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
    <*> areq textField "note" 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 [(TimeCategoryId, TimeCategory, 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 (timeEntryCategory e, x, hours e, day e, timeEntryNote e)) entries
    where
	cat :: TimeCategoryId -> YesodDB App App TimeCategory
	cat y = do x <- getJust y
	           return 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)