summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Handler/Employment.hs42
-rw-r--r--Handler/Vacation.hs42
2 files changed, 84 insertions, 0 deletions
diff --git a/Handler/Employment.hs b/Handler/Employment.hs
new file mode 100644
index 0000000..ce31dd1
--- /dev/null
+++ b/Handler/Employment.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+module Handler.Employment where
+
+import Import
+import qualified Data.Text as T
+import Yesod.Form.Jquery (jqueryDayField, def)
+
+getEmploymentR :: EmploymentId -> Handler RepHtml
+getEmploymentR eid = do
+ emp <- runDB $ get404 eid
+ user <- runDB $ get404 (employmentUser emp)
+ let username = userIdent user
+ (formWidget, formEnctype) <- generateFormPost (employmentForm emp)
+ defaultLayout $ do
+ aDomId <- newIdent
+ (setTitle . toHtml) ("Employment span for " `T.append` username)
+ $(widgetFile "employmentpage")
+
+postEmploymentR :: EmploymentId -> Handler RepHtml
+postEmploymentR eid = do
+ emp <- runDB $ get404 eid
+ user <- runDB $ get404 (employmentUser emp)
+ let username = userIdent user
+ ((result, formWidget), formEnctype) <- runFormPost (employmentForm emp)
+ _ <- case result of
+ FormSuccess res -> (runDB $ replace eid res) >> return ()
+ _ -> return ()
+
+ defaultLayout $ do
+ aDomId <- newIdent
+ (setTitle . toHtml) ("Employment span for " `T.append` username)
+ $(widgetFile "employmentpage")
+
+employmentAForm :: Employment -> AForm Handler Employment
+employmentAForm tc = Employment
+ <$> pure (employmentUser tc)
+ <*> areq (jqueryDayField def) "Start date" (Just (employmentStartDate tc))
+ <*> aopt (jqueryDayField def) "End date" (Just (employmentEndDate tc))
+ <*> areq doubleField "Commitment" (Just (employmentCommitment 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
new file mode 100644
index 0000000..b9e1217
--- /dev/null
+++ b/Handler/Vacation.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TupleSections, OverloadedStrings #-}
+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 qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime, UTCTime, utctDay)
+import Yesod.Auth (maybeAuth)
+import PTO
+
+getVacationR :: UserId -> Handler RepHtml
+getVacationR cid = do
+ user <- runDB $ get404 cid
+ ma <- maybeAuth
+ today <- fmap utctDay (liftIO getCurrentTime)
+ [e'] <- 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'
+ defaultLayout $ do
+ aDomId <- newIdent
+ (setTitle . toHtml) ("Vacation report for " `T.append` username)
+ $(widgetFile "vacationpage")
+ where
+ execRWST' = flip . flip execRWST
+
+-- anotherMonth :: UserId -> (Integer,Int) -> WriterT [Change]
+anotherMonth (y,m) = do
+ currentval <- get
+ (u, twoyear) <- 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
+ 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)