summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore7
-rw-r--r--Handler/Employment.hs1
-rw-r--r--Handler/Vacation.hs65
-rw-r--r--config/models1
-rw-r--r--sflctimekeeper.cabal1
-rw-r--r--templates/vacationpage.hamlet2
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