summaryrefslogtreecommitdiff
path: root/Handler/User.hs
blob: 8032da914ecb7c9c94b6c3f817c52ae14a04e149 (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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.User where

import Import
import Data.Maybe (fromMaybe, isJust)
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)
import Control.Error.Util (hoistMaybe)
import Control.Monad (join)
import Control.Monad.Trans.Maybe (runMaybeT)

getUserR :: UserId -> Handler Html
getUserR cid = do
    user <- runDB $ get404 cid
    zzzma <- runMaybeT $ do
        a <- hoistMaybe =<< lift maybeAuth
        masst <- lift . runDB $ selectFirst [AssistantAssistant ==. entityKey a, AssistantAssisted ==. cid] []
	return (entityKey a, isJust masst)
    let username = userIdent user
    let isThisUser = Just cid == fmap fst zzzma
    let isAssistant = Just True == fmap snd zzzma
    (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 <- newIdent
        (setTitle . toHtml) ("Time entries for " `T.append` username)
        $(widgetFile "userpage")

postUserR :: UserId -> Handler Html
postUserR cid = do
    user <- runDB $ get404 cid
    zzzma <- runMaybeT $ do
        a <- hoistMaybe =<< lift maybeAuth
        masst <- lift . runDB $ selectFirst [AssistantAssistant ==. entityKey a, AssistantAssisted ==. cid] []
	return (entityKey a, isJust masst)
    let username = userIdent user
    let isThisUser = Just cid == fmap fst zzzma
    let isAssistant = Just True == fmap snd zzzma
    (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 <- newIdent
        (setTitle . toHtml) ("Entry submitted for " `T.append` username)
        $(widgetFile "userpage")

timeEntryAForm :: UTCTime -> [(Text,TimeCategoryId)] -> UserId -> AForm Handler 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 Handler (FormResult TimeEntry, Widget)
timeEntryForm u c h = do
    ct <- liftIO getCurrentTime
    renderDivs (timeEntryAForm ct c u) h

-- getEntriesForPage :: UserId -> Int -> YesodDB m [(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 Handler 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 -> Handler (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)

parttime :: Employment -> Bool
parttime e = employmentCommitment e /= 1.0