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
|
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Vacation where
import Import hiding (get)
import Control.Monad (when)
import Control.Monad.Trans.RWS.Lazy (RWST, ask, tell, get, put, execRWST)
import qualified Data.Text as T
import Data.Time (UTCTime, fromGregorian, getCurrentTime, utctDay)
import Yesod.Auth (maybeAuth)
import qualified Data.Map as Map
import Text.Printf (printf)
import PTO
type Month = (Integer, Int)
fmtHours :: Rational -> String
fmtHours r = printf "%.2f" d
where d = fromRational r :: Double
getAnniversaryMax :: [Employment] -> Month -> Maybe Rational
getAnniversaryMax es (y, m) =
case capOverride of
Just 0.0 -> Nothing
Just v -> Just (toRational v)
Nothing -> Just 160.0
where
empMap = Map.fromList [(employmentStartDate e, e) | e <- es]
today = fromGregorian y m 0
todaysEmp :: Maybe Employment
todaysEmp =
Map.lookupLE today empMap >>=
\(_, emp) ->
case employmentEndDate emp of
Just end
| end < today -> Nothing
_ -> Just emp
capOverride :: Maybe Double
capOverride = todaysEmp >>= employmentPtoMaxRollover
getVacationR :: UserId -> Handler Html
getVacationR cid = do
user <- runDB $ get404 cid
ma <- maybeAuth
today <- fmap utctDay (liftIO getCurrentTime)
employments <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
let username = userIdent user
current@(currentyear, currentmonth) = monthOf today
months = takeWhile (< current) [(y, m) | y <- [2005..], m <- [1..12]]
(_, transacts') <- execRWST' (cid, employments) 0 $ mapM anotherMonth months
let transacts = reverse $ transacts' :: [(String, Rational)]
defaultLayout $ do
aDomId <- newIdent
(setTitle . toHtml) ("Vacation report for " `T.append` username)
$(widgetFile "vacationpage")
where
execRWST' = flip . flip execRWST
anotherMonth :: Month -> RWST (UserId, [Employment]) [(String, Rational)] Rational Handler ()
anotherMonth (y,m) = do
(u, employments@(e:_)) <- ask
(plus, minus) <- lift . runDB $ monthlyTransactions u (y,m)
when (plus > 0) (add plus)
when (minus > 0) (subtract (toRational minus))
let twoyear = twoYearsFrom $ employmentStartDate e
ptoMax = getAnniversaryMax employments (y,m)
when ((snd . monthOf) twoyear == m) $
maybe (return ()) kneecap ptoMax
where
add x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": adding " ++ fmtHours x ++ " hours", o + x)] >> put (o + x)
subtract x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": subtracting " ++ fmtHours x ++ " hours", o - x)] >> put (o - x)
kneecap cap = get >>= \o -> when (o > cap) (tell [(show y ++ "-" ++ show m ++ ": over anniversary max, subtracting " ++ fmtHours (o - cap) ++ " hours", cap)] >> put cap)
|
