Refactor ranking into a separate Mulkup.Ranking module.
Change-Id: Ieeef3f837756e6afe96f0a0c3dba591f285daae5
diff --git a/src/Mulkup/Main.hs b/src/Mulkup/Main.hs
index 3b080c4..829ef5d 100644
--- a/src/Mulkup/Main.hs
+++ b/src/Mulkup/Main.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
@@ -6,14 +5,13 @@
import Colog (Message, richMessageAction, simpleMessageAction)
import Colog.Polysemy.Effect (Log, runLogAction)
-import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
-import Data.Time
import Mulkup.Bupstash
import Mulkup.Config
import Mulkup.Flags
import Mulkup.Logging
import Mulkup.Prelude
+import Mulkup.Ranking
import Optics
import Options.Applicative
( execParser,
@@ -59,24 +57,7 @@
currentItems <- bupList (BupFilter labels Nothing)
- let tiers =
- [ (utctHour . bupItemUTCTime, #hourly),
- (utctJulianDay . bupItemUTCTime, #daily),
- (utctWeek . bupItemUTCTime, #weekly),
- (utctMonth . bupItemUTCTime, #monthly)
- ]
-
- let keepIds =
- Set.unions $
- map
- ( \(discriminator, cfgLens) ->
- let tierCfg = stash ^. #tiers ^. cfgLens
- in tierKeepIds discriminator (tierCfg ^. #keep) currentItems
- )
- tiers
-
- let currentIds = Set.fromList (map (^. #id) currentItems)
- let rmIds = Set.difference currentIds keepIds
+ let (keepIds, rmIds) = rankBupItems (stash ^. #tiers) currentItems
logInfo (show labels <> " Keeping: " <> show (Set.toList keepIds))
logInfo (show labels <> " Removing: " <> show (Set.toList rmIds))
@@ -87,32 +68,3 @@
(stash ^. #baseDir)
(stash ^. #exclusions)
labels
-
-tierKeepIds :: (BupItem -> Integer) -> Natural -> [BupItem] -> Set Text
-tierKeepIds discriminator keep items =
- fromList $
- take (fromIntegral keep) $
- map (^. #id) $
- reverse $
- sortWith bupItemUTCTime $
- map (head . NonEmpty.sortWith bupItemUTCTime) $
- elems $
- (groupBy discriminator items :: HashMap Integer (NonEmpty BupItem))
-
-utctHour :: UTCTime -> Integer
-utctHour (UTCTime (ModifiedJulianDay julianDay) tdiff) = (julianDay * 24) + (diffTimeToPicoseconds tdiff `div` (10 ^ (12 :: Integer)) `div` 3600)
-
-utctJulianDay :: UTCTime -> Integer
-utctJulianDay (UTCTime (ModifiedJulianDay julianDay) _) = julianDay
-
-utctWeek :: UTCTime -> Integer
-utctWeek (UTCTime day _) =
- julianDay + fromIntegral (dayOfWeekDiff (dayOfWeek day) Sunday)
- where
- (ModifiedJulianDay julianDay) = day
- dayOfWeekDiff a b = mod (fromEnum a - fromEnum b) 7
-
-utctMonth :: UTCTime -> Integer
-utctMonth (UTCTime day _) = fromIntegral m
- where
- (_, m, _) = toGregorian day