diff options
| -rw-r--r-- | Handler/Employment.hs | 42 | ||||
| -rw-r--r-- | Handler/Vacation.hs | 42 |
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) |