diff options
| -rw-r--r-- | .gitignore | 7 | ||||
| -rw-r--r-- | Handler/Employment.hs | 1 | ||||
| -rw-r--r-- | Handler/Vacation.hs | 65 | ||||
| -rw-r--r-- | config/models | 1 | ||||
| -rw-r--r-- | sflctimekeeper.cabal | 1 | ||||
| -rw-r--r-- | templates/vacationpage.hamlet | 2 |
6 files changed, 59 insertions, 18 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e385d7e --- /dev/null +++ b/.gitignore @@ -0,0 +1,7 @@ +/apache-test-proxy.log +/apache-test-proxy.pid +/config/client_session_key.aes +/dist +/*.sqlite3 +/static/combined +/static/tmp 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) diff --git a/config/models b/config/models index 54723f0..478f3a8 100644 --- a/config/models +++ b/config/models @@ -8,6 +8,7 @@ Employment startDate Day endDate Day Maybe commitment Double + ptoMaxRollover Double Maybe TimeEntry user UserId category TimeCategoryId diff --git a/sflctimekeeper.cabal b/sflctimekeeper.cabal index 0e9b0e0..d583a1d 100644 --- a/sflctimekeeper.cabal +++ b/sflctimekeeper.cabal @@ -95,6 +95,7 @@ library , time , transformers , unix + , containers executable sflctimekeeper if flag(library-only) diff --git a/templates/vacationpage.hamlet b/templates/vacationpage.hamlet index 1bdfeee..a0121bb 100644 --- a/templates/vacationpage.hamlet +++ b/templates/vacationpage.hamlet @@ -7,7 +7,7 @@ $forall (s,rt) <- transacts <tr .vacentry> <td .activity>#{s} - <td .balance>#{show rt} + <td .balance>#{fmtHours rt} <p> <a href=@{UserR cid}>Time entry page |