feat(audit): automatic transaction log truncation

2019-08-06 14:22:16 +02:00 · 2019-08-06 14:22:16 +02:00 · 248482b1bb
commit 248482b1bb
parent f602b79e7a
10 changed files with 277 additions and 70 deletions
--- a/config/settings.yml
+++ b/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"
--- a/src/Cron.hs
+++ b/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
-              | otherwise = fromWeekDate (pred y) 53 dow
+              | w > 1     = fromWeekDate y        (pred w) 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 _ _ _ CronMatchNone = []
-genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs
-genMatch p m st (CronMatchStep step) = do
+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 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 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..]
-genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
-genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
-genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
-genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
-genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
-genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
-  = genMatch p m st . CronMatchStep $ lcm st1 st2
-genMatch p m st (CronMatchIntersect aGen bGen)
+  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 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 p m z st (CronMatchIntersect CronMatchAny other) = genMatch p m z st other
+genMatch p m z st (CronMatchIntersect other CronMatchAny) = genMatch p m z st other
+genMatch p m z st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
+  = genMatch p m z st . CronMatchStep $ lcm st1 st2
+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 st (CronMatchUnion other CronMatchNone) = genMatch p m st other
-genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
-genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m 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 CronMatchNone other) = genMatch p m z st other
+genMatch p m z st (CronMatchUnion other CronMatchNone) = genMatch p m z st other
+genMatch p m z st (CronMatchUnion CronMatchAny _) = genMatch p m z st CronMatchAny
+genMatch p m z st (CronMatchUnion _ CronMatchAny) = genMatch p m z st CronMatchAny
+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
--- a/src/Cron/Types.hs
+++ b/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
--- a/src/Handler/Utils/DateTime.hs
+++ b/src/Handler/Utils/DateTime.hs
@ -31,36 +31,9 @@ import qualified Data.Set as Set
 import Data.Time.Clock.System (systemEpochDay)


-
--------------------
-- 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
-
+-------------
+-- 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
--- a/src/Jobs.hs
+++ b/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
--- a/src/Jobs/Crontab.hs
+++ b/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
--- a/src/Jobs/Handler/TransactionLog.hs
+++ b/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|]
--- a/src/Jobs/Types.hs
+++ b/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 }
--- a/src/Settings.hs
+++ b/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"

--- a/src/Utils/DateTime.hs
+++ b/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