From b7bdac567ffe809b36e16fe29a663c1f437b38ae Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Thu, 5 Feb 2015 18:56:02 -0500 Subject: Handle multiple stints of employment --- Handler/Vacation.hs | 2 +- PTO.hs | 61 ++++++++++++++++++++++++++++++----------------------- config/settings.yml | 3 +-- 3 files changed, 37 insertions(+), 29 deletions(-) diff --git a/Handler/Vacation.hs b/Handler/Vacation.hs index 18a96cb..e6c95f9 100644 --- a/Handler/Vacation.hs +++ b/Handler/Vacation.hs @@ -14,7 +14,7 @@ getVacationR cid = do user <- runDB $ get404 cid ma <- maybeAuth today <- fmap utctDay (liftIO getCurrentTime) - [e'] <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] []) + (e':es) <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] []) let twoyear = twoYearsFrom $ employmentStartDate e' username = userIdent user (currentyear, currentmonth) = monthOf today diff --git a/PTO.hs b/PTO.hs index 01ffda8..19dd13f 100644 --- a/PTO.hs +++ b/PTO.hs @@ -5,32 +5,36 @@ module PTO where import Import -import Data.Maybe (fromJust) -import Data.Time.Calendar (Day, fromGregorian, toGregorian, gregorianMonthLength, diffDays) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, fromGregorian, toGregorian, gregorianMonthLength, diffDays, addDays) import Database.Persist.Sql (SqlBackend) -- this can't be good accrual :: (Functor m, PersistQuery m, PersistMonadBackend m ~ SqlBackend) => UserId -> (Integer, Int) -> m Rational accrual u' (y',m') = do - [e'] <- fmap (map entityVal) (selectList [EmploymentUser ==. u'] []) - return $ accrual' e' (y',m') + (e':es') <- fmap (map entityVal) (selectList [EmploymentUser ==. u'] []) + return $ accrualThisMonth (e':es') (y',m') + +accrualThisMonth :: [Employment] -> (Integer, Int) -> Rational +accrualThisMonth es@(e1:es') (y,m) = baseRateAccrual + twoYearRateAccrual where - accrual' e@Employment{..} (y,m) - | employmentStartDate > endOfMonth (y,m) = 0 - | fmap (\x -> x < startOfMonth (y,m)) employmentEndDate == Just True = 0 - | monthOf employmentStartDate == (y,m) = percent employmentStartDate (endOfMonth (y,m)) * baseLevel * toRational employmentCommitment - | Just (y,m) == endMonth e && ((y,m) > monthOf (twoYearsFrom employmentStartDate)) = (percent (startOfMonth (y,m)) (fromJust employmentEndDate)) * afterTwo * toRational employmentCommitment -- FIXME or leave bug-compatible? - | Just (y,m) == endMonth e = (percent (startOfMonth (y,m)) (fromJust employmentEndDate)) * baseLevel * toRational employmentCommitment -- FIXME or leave bug-compatible? - | monthOf (twoYearsFrom employmentStartDate) < (y,m) = afterTwo * toRational employmentCommitment - | (y,m) == monthOf (twoYearsFrom employmentStartDate) = toRational employmentCommitment * (((percent (twoYearsFrom employmentStartDate) (endOfMonth (y,m))) * (afterTwo - baseLevel)) + baseLevel) - | otherwise = baseLevel * toRational employmentCommitment - baseLevel = 104/12 - afterTwo = 12 - percent s e - | monthOf s == monthOf e = toRational (daysInPeriod s e) / toRational (daysInMonth s) - | otherwise = error "this should never happen" - daysInPeriod s e = diffDays e s + 1 -- is this right or off-by-one? - daysInMonth = uncurry gregorianMonthLength . monthOf + baseRateAccrual = baseLevel * sum (map (proportionOf tmBRRange) es) + twoYearRateAccrual = afterTwo * sum (map (proportionOf tmTYRRange) es) + proportionOf r emp = toRational (employmentCommitment emp) * + proportion (fromMaybe (Nothing,Nothing) + (r >>= rangeIntersection (employmentRange emp))) + thisMonthRange + employmentRange emp = (Just (employmentStartDate emp), employmentEndDate emp) + proportion (Just a,Just b) (Just a', Just b') = toRational (diffDays b a + 1) / toRational (diffDays b' a' + 1) + proportion _ _ = 0 + tmBRRange = rangeIntersection brRange thisMonthRange + tmTYRRange = rangeIntersection tyRange thisMonthRange + startDate = employmentStartDate e1 + brRange = (Just startDate, Just (addDays (-1) (twoYearsFrom startDate))) + tyRange = (Just (twoYearsFrom startDate), Nothing) + thisMonthRange = (Just (startOfMonth (y,m)), Just (endOfMonth (y,m))) + baseLevel = 104/12 + afterTwo = 12 -- deductions :: PersistQuery backend m => (Integer, Int) -> Key backend (UserGeneric backend) -> backend m [Entity (TimeEntryGeneric backend)] deductions (year,month) user = do @@ -48,6 +52,7 @@ deductibles = do ||. [TimeCategoryName ==. "/admin/vacation"]) [] return $ map entityKey ds +yearlySacrifice :: Num a => a -> a yearlySacrifice hs = 160 - hs -- monthlyTransactions :: UserId -> (Integer, Int) -> m (Rational, Double) @@ -62,14 +67,18 @@ startOfMonth (year,month) = fromGregorian year month 1 endOfMonth :: (Integer, Int) -> Day endOfMonth (year,month) = fromGregorian year month 32 -startMonth :: Employment -> (Integer, Int) -startMonth = monthOf . employmentStartDate - -endMonth :: Employment -> Maybe (Integer, Int) -endMonth = fmap monthOf . employmentEndDate - twoYearsFrom :: Day -> Day twoYearsFrom = (\(y,m,d) -> fromGregorian (y+2) m d) . toGregorian monthOf :: Day -> (Integer, Int) monthOf = (\(x,y,_) -> (x,y)) . toGregorian + +rangeIntersection :: (Maybe Day, Maybe Day) -> (Maybe Day, Maybe Day) -> Maybe (Maybe Day, Maybe Day) +rangeIntersection (a,b) (a',b') = let (c,d) = (newest a a', oldest b b') in if (c > d) then Nothing else Just (c,d) + where + newest Nothing x = x + newest x Nothing = x + newest (Just x) (Just y) = Just (max x y) + oldest Nothing x = x + oldest x Nothing = x + oldest (Just x) (Just y) = Just (min x y) diff --git a/config/settings.yml b/config/settings.yml index 686c9fc..f51e2c2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,7 +1,6 @@ Default: &defaults host: "*4" # any IPv4 host port: 3000 - approot: "http://burrell.hq.sflc.info:80" copyright: sflctimekeeper pre-release #Copyright (C) 2012-2013 Clint Adams #analytics: UA-YOURCODE @@ -16,5 +15,5 @@ Staging: <<: *defaults Production: - #approot: "http://www.example.com" + approot: "http://burrell.hq.sflc.info:80" <<: *defaults -- cgit v1.2.1