diff options
Diffstat (limited to 'Handler')
| -rw-r--r-- | Handler/Employment.hs | 1 | ||||
| -rw-r--r-- | Handler/Vacation.hs | 65 |
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) |