summaryrefslogtreecommitdiff
path: root/Handler
diff options
context:
space:
mode:
Diffstat (limited to 'Handler')
-rw-r--r--Handler/Employment.hs1
-rw-r--r--Handler/Vacation.hs65
2 files changed, 49 insertions, 17 deletions
diff --git a/Handler/Employment.hs b/Handler/Employment.hs
index 55057a9..a69b67a 100644
--- a/Handler/Employment.hs
+++ b/Handler/Employment.hs
@@ -37,6 +37,7 @@ employmentAForm tc = Employment
<*> areq (jqueryDayField def) "Start date" (Just (employmentStartDate tc))
<*> aopt (jqueryDayField def) "End date" (Just (employmentEndDate tc))
<*> areq doubleField "Commitment" (Just (employmentCommitment tc))
+ <*> aopt doubleField "Custom anniversary max (0 = infinite)" (Just (employmentPtoMaxRollover tc))
employmentForm :: Employment -> Html -> MForm Handler (FormResult Employment, Widget)
employmentForm tc h = renderDivs (employmentAForm tc) h
diff --git a/Handler/Vacation.hs b/Handler/Vacation.hs
index e6c95f9..233d737 100644
--- a/Handler/Vacation.hs
+++ b/Handler/Vacation.hs
@@ -2,25 +2,54 @@
module Handler.Vacation where
import Import hiding (get)
-import Control.Monad (when, guard)
-import Control.Monad.Trans.RWS.Lazy (ask, tell, get, put, execRWST)
+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.Clock (getCurrentTime, UTCTime, utctDay)
+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)
- (e':es) <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
- let twoyear = twoYearsFrom $ employmentStartDate e'
- username = userIdent user
- (currentyear, currentmonth) = monthOf today
- months = [2005 .. currentyear] >>= \ x -> [1 .. 12] >>= \ y -> guard ((x, y) < (currentyear, currentmonth)) >> return (x, y)
- (_, transacts') <- execRWST' (cid, twoyear) 0 $ mapM anotherMonth months
- let transacts = reverse $ map (fmap fromRational) transacts'
+ 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)
@@ -28,15 +57,17 @@ getVacationR cid = do
where
execRWST' = flip . flip execRWST
--- anotherMonth :: UserId -> (Integer,Int) -> WriterT [Change]
+anotherMonth :: Month -> RWST (UserId, [Employment]) [(String, Rational)] Rational Handler ()
anotherMonth (y,m) = do
- currentval <- get
- (u, twoyear) <- ask
+ (u, employments@(e:_)) <- ask
(plus, minus) <- lift . runDB $ monthlyTransactions u (y,m)
when (plus > 0) (add plus)
when (minus > 0) (subtract (toRational minus))
- when ((snd . monthOf) twoyear == m) kneecap
+ 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 " ++ show (fromRational x) ++ " hours", o + x)] >> put (o + x)
- subtract x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": subtracting " ++ show (fromRational x) ++ " hours", o - x)] >> put (o - x)
- kneecap = get >>= \o -> when (o > 160) (tell [(show y ++ "-" ++ show m ++ ": over anniversary max, subtracting " ++ show (fromRational o - 160) ++ " hours", 160)] >> put 160)
+ 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)