PTO: rounding, anniversary max overridesHEADmaster

- Allow changing/disabling anniversary PTO rollover caps per-employment.
  (We want to let mishi accumulated unlimited vacation time.)

- Round all amounts to two decimal places. (Requested by tanisha.)

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