feat(audit): automatic transaction log truncation

config/settings.yml

@@ -47,6 +47,8 @@ log-settings:
   minimum-level: "_env:LOGLEVEL:warn"
   destination:   "_env:LOGDEST:stderr"
 
+ip-retention-time: 1209600
+
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"

src/Cron.hs

@@ -23,7 +23,7 @@ import Utils.Lens hiding (from, to)
 
   
 data CronDate = CronDate
-  { cdYear, cdWeekOfYear, cdDayOfYear
+  { cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear
   , cdMonth, cdWeekOfMonth, cdDayOfMonth
   , cdDayOfWeek
   , cdHour, cdMinute, cdSecond :: Natural
@@ -48,7 +48,7 @@ toCronDate LocalTime{..} = CronDate{..}
       = toGregorian localDay
     (_, fromIntegral -> cdDayOfYear)
       = toOrdinalDate localDay
-    (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
+    (fromInteger -> cdWeekYear, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
       = toWeekDate localDay
     cdWeekOfMonth = go 1 localDay
       where
@@ -60,8 +60,8 @@ toCronDate LocalTime{..} = CronDate{..}
           where
             (y, w, dow) = toWeekDate day
             day'
-              | w /= 0 = fromWeekDate y (pred w) dow
+              | w > 1     = fromWeekDate y        (pred w) dow
-              | otherwise = fromWeekDate (pred y) 53 dow
+              | otherwise = fromWeekDate (pred y) 53       dow
             (_, m, _) = toGregorian day
             (_, m', _) = toGregorian day'
     TimeOfDay
@@ -73,7 +73,7 @@ toCronDate LocalTime{..} = CronDate{..}
 consistentCronDate :: CronDate -> Bool
 consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
   gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
-  wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
+  wDay <- fromWeekDateValid (fromIntegral cdWeekYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
   guard $ gDay == wDay
   oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
   guard $ wDay == oDay
@@ -107,39 +107,40 @@ listToMatch (t:_) = MatchAt t
 
 genMatch :: Int -- ^ Period
          -> Bool -- ^ Modular
+         -> Bool -- ^ Zero based
          -> Natural -- ^ Start value
          -> CronMatch
          -> [Natural]
-genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
+genMatch p m z st CronMatchAny = take p $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [st..]
-genMatch _ _ _ CronMatchNone = []
+genMatch _ _ _ _ CronMatchNone = []
-genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs
+genMatch p m z _ (CronMatchSome xs) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) . Set.toAscList $ toNullable xs
-genMatch p m st (CronMatchStep step) = do
+genMatch p m z st (CronMatchStep step) = do
   start <- [st..st + step]
   guard $ (start `mod` step) == 0
-  take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
+  take (ceiling $ fromIntegral p % step) $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [start,start + step..]
-genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
+genMatch p m z st (CronMatchContiguous from to) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) $ [max st from..to]
-genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
+genMatch _ _ _ _ (CronMatchIntersect CronMatchNone _) = []
-genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
+genMatch _ _ _ _ (CronMatchIntersect _ CronMatchNone) = []
-genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
+genMatch p m z st (CronMatchIntersect CronMatchAny other) = genMatch p m z st other
-genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
+genMatch p m z st (CronMatchIntersect other CronMatchAny) = genMatch p m z st other
-genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
+genMatch p m z st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
-  = genMatch p m st . CronMatchStep $ lcm st1 st2
+  = genMatch p m z st . CronMatchStep $ lcm st1 st2
-genMatch p m st (CronMatchIntersect aGen bGen)
+genMatch p m z st (CronMatchIntersect aGen bGen)
   | [] <- as' = []
-  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
+  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m z a bGen)
   where
-    as' = genMatch p m st aGen
+    as' = genMatch p m z st aGen
     mergeAnd [] _ = []
     mergeAnd _ [] = []
     mergeAnd (a:as) (b:bs)
       | a <  b    = mergeAnd as (b:bs)
       | a == b    = a : mergeAnd as bs
       | otherwise = mergeAnd (a:as) bs
-genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
+genMatch p m z st (CronMatchUnion CronMatchNone other) = genMatch p m z st other
-genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
+genMatch p m z st (CronMatchUnion other CronMatchNone) = genMatch p m z st other
-genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
+genMatch p m z st (CronMatchUnion CronMatchAny _) = genMatch p m z st CronMatchAny
-genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
+genMatch p m z st (CronMatchUnion _ CronMatchAny) = genMatch p m z st CronMatchAny
-genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
+genMatch p m z st (CronMatchUnion aGen bGen) = merge (genMatch p m z st aGen) (genMatch p m z st bGen)
   where
     merge [] bs = bs
     merge as [] = as
@@ -215,28 +216,134 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
         | ref <= ts || not wasExecd -> MatchAt ts
         | otherwise -> MatchNone
       CronCalendar{..} -> listToMatch $ do
-        let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
+        let
+          localRef = utcToLocalTimeTZ tz ref
+          CronDate{..} = toCronDate localRef
+
+        mCronWeekDate <- if
+          | cronWeekYear == CronMatchAny
+          , cronWeekOfYear == CronMatchAny
+          , cronDayOfWeek == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> genMatch 53 True False cdWeekOfYear cronWeekOfYear
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+
+        mCronGregorianDate <- if
+          | cronYear == CronMatchAny
+          , cronMonth == CronMatchAny
+          , cronDayOfMonth == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 400 False True cdYear cronYear
+               <*> genMatch 12 True False cdMonth cronMonth
+               <*> genMatch 31 True False cdDayOfMonth cronDayOfMonth
+
+        mCronWeekOfMonthDate <- if
+          | cronWeekOfMonth == CronMatchAny
+            -> return Nothing
+          | Just (wY, _, wd) <- mCronWeekDate
+            -> fmap Just $ (,,,)
+                 <$> pure wY
+                 <*> maybe (genMatch 12 True False cdMonth cronMonth) (pure . view _2) mCronGregorianDate
+                 <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+                 <*> pure wd
+          | Just (_, m, _) <- mCronGregorianDate
+            -> fmap Just $ (,,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> pure m
+               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+          | otherwise
+            -> fmap Just $ (,,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> genMatch 12 True False cdMonth cronMonth
+               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+
+        mCronOrdinalDate <- if
+          | cronYear == CronMatchAny
+          , cronDayOfYear == CronMatchAny
+            -> return Nothing
+          | Just (y, _, _) <- mCronGregorianDate
+            -> Just . (y,) <$> genMatch 366 True False cdDayOfYear cronDayOfYear
+          | otherwise
+            -> fmap Just $ (,)
+               <$> genMatch 400 False True cdYear cronYear
+               <*> genMatch 366 True False cdDayOfYear cronDayOfYear
+
+        mCronTime <- if
+          | cronHour == CronMatchAny
+          , cronMinute == CronMatchAny
+          , cronSecond == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 24 True True cdHour cronHour
+               <*> genMatch 60 True True cdMinute cronMinute
+               <*> genMatch 60 True True cdSecond cronSecond
+
+        let toGregorian' = over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral . toGregorian
+        (mCronYear, mCronMonth, mCronDayOfMonth) <- if
+            | Just (year, month, dayOfMonth) <- mCronGregorianDate
+              -> return (year, month, dayOfMonth)
+            | Just (weekYear, week, dayOfWeek) <- mCronWeekDate
+              -> return . toGregorian' $ fromWeekDate (fromIntegral weekYear) (fromIntegral week) (fromIntegral dayOfWeek)
+            | Just (year, dayOfYear) <- mCronOrdinalDate
+              -> maybeToList . fmap toGregorian' $ fromOrdinalDateValid (fromIntegral year) (fromIntegral dayOfYear)
+            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
+              -> do
+                   year <- genMatch 400 False True cdYear cronYear
+                   day <- genMatch 31 True False cdDayOfMonth cronDayOfMonth
+                   jDay <- maybeToList $ fromGregorianValid (fromIntegral year) (fromIntegral month) (fromIntegral day)
+                   guard $ consistentCronDate (toCronDate localRef{ localDay = jDay }) { cdWeekYear = weekYear, cdMonth = month, cdWeekOfMonth = weekOfMonth, cdDayOfWeek = dayOfWeek }
+                   return (year, month, day)
+            | otherwise
+              -> fmap toGregorian' [localDay localRef, succ $ localDay localRef]
+
+        julDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
+
+        mCronDayOfYear <- if
+            | Just (year, dayOfYear) <- mCronOrdinalDate
+              -> dayOfYear <$ guard (year == mCronYear)
+            | otherwise
+              -> return . fromIntegral . snd $ toOrdinalDate julDay
+
+        (mCronWeekYear, mCronWeekOfYear, mCronDayOfWeek) <- if
+            | Just weekDate <- mCronWeekDate
+              -> return weekDate
+            | otherwise
+              -> return . over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral $ toWeekDate julDay
+
+        mCronWeekOfMonth <- if
+            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
+              -> weekOfMonth <$ guard (weekYear == mCronWeekYear && month == mCronMonth && dayOfWeek == mCronDayOfWeek)
+            | otherwise
+              -> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+
+        (mCronHour, mCronMinute, mCronSecond) <- if
+            | Just (h, m, s) <- mCronTime
+              -> return (h, m, s)
+            | otherwise
+              -> [(0, 0, 0), (cdHour, cdMinute, cdSecond)]
 
-        mCronYear <- genMatch 400 False cdYear cronYear
-        mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
-        mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
-        mCronMonth <- genMatch 12 True cdMonth cronMonth
-        mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
-        mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
-        mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
-        mCronHour <- genMatch 24 True cdHour cronHour
-        mCronMinute <- genMatch 60 True cdMinute cronMinute
-        mCronSecond <- genMatch 60 True cdSecond cronSecond
         guard $ consistentCronDate CronDate
           { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
           , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
-          , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
+          , cdWeekYear = mCronWeekYear, cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
           , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
           }
 
         localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
         let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
-        return $ localTimeToUTCTZ tz LocalTime{..}
+            res = localTimeToUTCTZ tz LocalTime{..}
+
+        guard $ res >= ref
+
+        return res
       CronNotScheduled -> MatchNone
 
 matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry

src/Cron/Types.hs

@@ -1,7 +1,9 @@
 module Cron.Types
   ( Cron(..), Crontab
   , CronMatch(..)
+  , cronMatchOne
   , CronAbsolute(..)
+  , cronCalendarAny
   , CronRepeat(..)
   ) where
 
@@ -14,6 +16,7 @@ import Data.Time
 import Numeric.Natural
 
 import Data.HashMap.Strict (HashMap)
+import qualified Data.Set as Set
   
 
 data CronMatch
@@ -26,13 +29,16 @@ data CronMatch
   | CronMatchUnion CronMatch CronMatch
   deriving (Eq, Show, Read)
 
+cronMatchOne :: Natural -> CronMatch
+cronMatchOne = CronMatchSome . impureNonNull . Set.singleton
+
 data CronAbsolute
   = CronAsap
   | CronTimestamp
     { cronTimestamp :: LocalTime
     }
   | CronCalendar
-    { cronYear, cronWeekOfYear, cronDayOfYear
+    { cronYear, cronWeekYear, cronWeekOfYear, cronDayOfYear
     , cronMonth, cronWeekOfMonth, cronDayOfMonth
     , cronDayOfWeek
     , cronHour, cronMinute, cronSecond :: CronMatch
@@ -42,6 +48,21 @@ data CronAbsolute
 
 makeLenses_ ''CronAbsolute
 
+cronCalendarAny :: CronAbsolute
+cronCalendarAny = CronCalendar
+  { cronYear        = CronMatchAny
+  , cronWeekYear    = CronMatchAny
+  , cronWeekOfYear  = CronMatchAny
+  , cronDayOfYear   = CronMatchAny
+  , cronMonth       = CronMatchAny
+  , cronWeekOfMonth = CronMatchAny
+  , cronDayOfMonth  = CronMatchAny
+  , cronDayOfWeek   = CronMatchAny
+  , cronHour        = CronMatchAny
+  , cronMinute      = CronMatchAny
+  , cronSecond      = CronMatchAny
+  }
+
 data CronRepeat
   = CronRepeatOnChange
   | CronRepeatScheduled CronAbsolute

src/Handler/Utils/DateTime.hs

@@ -31,36 +31,9 @@ import qualified Data.Set as Set
 import Data.Time.Clock.System (systemEpochDay)
 
 
-
+-------------
---------------------
+-- UTCTime --
--- NominalDiffTime
+-------------
-
--- | One hour in 'NominalDiffTime'.
-nominalHour :: NominalDiffTime
-nominalHour = 3600
-
--- | One minute in 'NominalDiffTime'.
-nominalMinute :: NominalDiffTime
-nominalMinute= 60
-
-formatDiffDays :: NominalDiffTime -> Text
-formatDiffDays t
-  | t > nominalDay    = inDays    <> "d"
-  | t > nominalHour   = inHours   <> "h"
-  | t > nominalMinute = inMinutes <> "m"
-  | otherwise         = tshow $ roundToDigits 0 t
-  where
-    convertBy :: NominalDiffTime -> Double
-    convertBy len = realToFrac $ roundToDigits 1 $ t / len
-    inDays    = tshow $ convertBy nominalDay
-    inHours   = tshow $ convertBy nominalHour
-    inMinutes = tshow $ convertBy nominalMinute
-
-
-
-------------
--- UTCTime
-
 
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@@ -198,6 +171,20 @@ dateTimeFormatOptions sel = do
   optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
 
 
+formatDiffDays :: NominalDiffTime -> Text
+formatDiffDays t
+  | t > nominalDay    = inDays    <> "d"
+  | t > nominalHour   = inHours   <> "h"
+  | t > nominalMinute = inMinutes <> "m"
+  | otherwise         = tshow $ roundToDigits 0 t
+  where
+    convertBy :: NominalDiffTime -> Double
+    convertBy len = realToFrac $ roundToDigits 1 $ t / len
+    inDays    = tshow $ convertBy nominalDay
+    inHours   = tshow $ convertBy nominalHour
+    inMinutes = tshow $ convertBy nominalMinute
+
+
 setYear :: Integer -> Day -> Day
 setYear year date = fromGregorian year month day
   where

src/Jobs.hs

@@ -67,6 +67,7 @@ import Jobs.Handler.DistributeCorrections
 import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.Invitation
 import Jobs.Handler.SendPasswordReset
+import Jobs.Handler.TransactionLog
 
 import Jobs.HealthReport
 
@@ -239,6 +240,11 @@ execCrontab = do
       Just (_, MatchNone) -> liftBase retry
       Just x -> return (crontab, x)
 
+  -- do
+  --   lastTimes <- State.get
+  --   now <- liftIO getCurrentTime
+  --   $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
+
   let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do
           newCrontab <- lift . hoist lift $ determineCrontab'
           if

src/Jobs/Crontab.hs

@@ -59,6 +59,33 @@ determineCrontab = execWriterT $ do
           }
       Nothing  -> mempty
 
+  let newyear = cronCalendarAny
+        { cronDayOfYear  = cronMatchOne 1
+        }
+   in tell $ HashMap.singleton
+        (JobCtlQueue JobTruncateTransactionLog)
+        Cron
+          { cronInitial = newyear
+          , cronRepeat = CronRepeatScheduled newyear
+          , cronRateLimit = minNominalYear
+          , cronNotAfter = Right CronNotScheduled
+          }
+
+  oldestLogEntry <- fmap listToMaybe . lift . E.select . E.from $ \transactionLog -> do
+    E.where_ . E.not_ . E.isNothing $ transactionLog E.^. TransactionLogRemote
+    E.orderBy [E.asc $ transactionLog E.^. TransactionLogTime]
+    E.limit 1
+    return $ transactionLog E.^. TransactionLogTime
+  for_ oldestLogEntry $ \(E.Value oldestEntry) ->
+    tell $ HashMap.singleton
+      (JobCtlQueue JobDeleteTransactionLogIPs)
+      Cron
+        { cronInitial   = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appTransactionLogIPRetentionTime oldestEntry
+        , cronRepeat    = CronRepeatOnChange
+        , cronRateLimit = nominalDay
+        , cronNotAfter  = Right CronNotScheduled
+        }
+
   let
     sheetJobs (Entity nSheet Sheet{..}) = do
       tell $ HashMap.singleton

src/Jobs/Handler/TransactionLog.hs

@@ -0,0 +1,32 @@
+module Jobs.Handler.TransactionLog
+  ( dispatchJobTruncateTransactionLog
+  , dispatchJobDeleteTransactionLogIPs
+  ) where
+
+import Import hiding (currentYear)
+import Utils.Lens hiding ((<.))
+import Handler.Utils.DateTime
+
+import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
+
+dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: Handler ()
+dispatchJobTruncateTransactionLog = do
+  now <- liftIO getCurrentTime
+  let localNow = utcToLocalTime now
+      (localCurrentYear, _, _) = toGregorian $ localDay localNow
+      localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight
+      (currentYear, _, _) = toGregorian $ utctDay now
+      startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0
+      startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of
+        LTUUnique utc' _ -> utc'
+        _other           -> startOfPreviousYear
+
+  n <- runDB $ deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ]
+  $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|]
+dispatchJobDeleteTransactionLogIPs = do
+  now <- liftIO getCurrentTime
+  retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime
+  let cutoff = addUTCTime (- retentionTime) now
+
+  n <- runDB $ updateWhereCount [ TransactionLogTime <. cutoff ] [ TransactionLogRemote =. Nothing ]
+  $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|]

src/Jobs/Types.hs

@@ -48,6 +48,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                          }
          | JobSendPasswordReset { jRecipient :: UserId
                                 }
+         | JobTruncateTransactionLog
+         | JobDeleteTransactionLogIPs
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }

src/Settings.hs

@@ -122,6 +122,8 @@ data AppSettings = AppSettings
 
     , appInitialLogSettings     :: LogSettings
 
+    , appTransactionLogIPRetentionTime :: NominalDiffTime
+
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
     , appMutableStatic          :: Bool
@@ -405,6 +407,8 @@ instance FromJSON AppSettings where
 
         appInitialLogSettings     <- o .:  "log-settings"
 
+        appTransactionLogIPRetentionTime <- o .:  "ip-retention-time"
+
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 

src/Utils/DateTime.hs

@@ -6,6 +6,8 @@ module Utils.DateTime
   , currentYear
   , DateTimeFormat(..)
   , SelDateTimeFormat(..)
+  , nominalHour, nominalMinute
+  , minNominalYear, avgNominalYear
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -13,7 +15,7 @@ module Utils.DateTime
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (TimeLocale(..))
+import Data.Time (TimeLocale(..), NominalDiffTime, nominalDay)
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
 
@@ -117,3 +119,20 @@ instance BoundedMeetSemiLattice SelDateTimeFormat where
   top = SelFormatDateTime
 
 instance BoundedLattice SelDateTimeFormat
+
+
+---------------------
+-- NominalDiffTime --
+---------------------
+
+-- | One hour in `NominalDiffTime`.
+nominalHour :: NominalDiffTime
+nominalHour = 3600
+
+-- | One minute in `NominalDiffTime`.
+nominalMinute :: NominalDiffTime
+nominalMinute = 60
+
+minNominalYear, avgNominalYear :: NominalDiffTime
+minNominalYear = 365 * nominalDay
+avgNominalYear = fromRational $ 365.2425 * toRational nominalDay