Initial checkin.
Change-Id: Ib0f503f39cedb6fcc11f80a3b309e4cbb7ed438f
diff --git a/src/Mulkup/Bupstash.hs b/src/Mulkup/Bupstash.hs
new file mode 100644
index 0000000..8804593
--- /dev/null
+++ b/src/Mulkup/Bupstash.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Mulkup.Bupstash (BupItem(..), Bupstash (..), bupPut, bupGc, bupList, bupRemove, BupFilter (..), runBupstash, bupItemUTCTime) where
+
+import Mulkup.Config (MulkupConfig (..))
+import Mulkup.Prelude hiding (put)
+import Optics
+import Polysemy
+import Polysemy.Reader (Reader, asks)
+import Turtle hiding (err, x)
+import Data.Aeson (FromJSON, eitherDecode)
+import Polysemy.Error (Error, throw)
+import Data.Text (pack, unpack)
+import Mulkup.Logging
+import Colog.Polysemy (Log)
+import Colog (Message)
+import Data.Time
+import Data.Time.Clock.POSIX
+
+-- * API
+
+data BupItem = BupItem
+ { id :: Text,
+ unix_timestamp_millis :: Integer,
+ tags :: Map String String
+ }
+ deriving stock (Generic, Show)
+ deriving anyclass (FromJSON)
+
+data BupFilter = BupFilter
+ { labels :: [(Text, Text)],
+ minimumAge :: Maybe Text
+ }
+
+makeFieldLabelsNoPrefix ''BupFilter
+
+data Bupstash m a where
+ BupGc :: Bupstash m ()
+ BupPut :: Text -> [Text] -> [(Text, Text)] -> Bupstash m ()
+ BupList :: BupFilter -> Bupstash m [BupItem]
+ BupRemove :: [Text] -> Bupstash m ()
+
+makeSem ''Bupstash
+
+-- * Smart Accessors
+
+bupItemUTCTime :: BupItem -> UTCTime
+bupItemUTCTime item =
+ posixSecondsToUTCTime $
+ secondsToNominalDiffTime $
+ fromInteger (item ^. #unix_timestamp_millis) / 1000
+
+-- * Implementation
+
+-- | Runs a 'Bupstash' using the “bupstash” CLI command.
+runBupstash :: (Member (Error Text) r, Member (Log Message) r, Member (Embed IO) r, Member (Reader MulkupConfig) r) => Sem (Bupstash ': r) a -> Sem r a
+runBupstash = interpret \case
+ BupGc ->
+ procs "bupstash" ["gc"] empty
+
+ BupPut baseDir exclusions labels -> do
+ host <- getHost
+ procs "bupstash" (["put", "--xattrs"] ++ map exclusionArg exclusions ++ map labelArg labels ++ [labelArg ("host", host)] ++ [baseDir]) empty
+
+ BupList bupFilter -> do
+ host <- getHost
+ out <- strict $ inproc "bupstash" (["list", "--format=jsonl1"] ++ filterArgs host bupFilter) empty
+ let parsedItems = map parseItem (patchLines (lines out))
+ forM parsedItems \case
+ Left err -> do
+ let errtext = pack err
+ logError errtext
+ throw errtext
+ Right x ->
+ return x
+
+ BupRemove ids -> do
+ procs "bupstash" ["rm", "--ids-from-stdin"] (select (map unsafeTextToLine ids))
+
+ where
+ getHost :: Member (Reader MulkupConfig) r => Sem r Text
+ getHost =
+ asks @MulkupConfig (^. #host)
+
+-- | Fixes up the buggy two-line output that Buptash produces in
+-- jsonl1 output mode.
+--
+-- See: https://github.com/andrewchambers/bupstash/pull/241
+patchLines :: [Text] -> [Text]
+patchLines = concatMap patchLine
+ where
+ patchLine :: Text -> [Text]
+ patchLine line
+ | line == "}" =
+ []
+ | length (filter (== '}') $ unpack line) < length (filter (== '{') $ unpack line) =
+ [line <> "}"]
+ | otherwise =
+ [line]
+
+labelArg :: (Text, Text) -> Text
+labelArg (key, value) = key <> "=" <> value
+
+exclusionArg :: Text -> Text
+exclusionArg = ("--exclude=" <>)
+
+filterArgs :: Text -> BupFilter -> [Text]
+filterArgs host (BupFilter labels minimumAge) =
+ [labelArg ("host", host)] ++
+ concatMap (\label -> ["and", labelArg label]) labels ++
+ concatMap (\x -> ["and", "older-than", x]) minimumAge
+
+parseItem :: Text -> Either String BupItem
+parseItem = eitherDecode . encodeUtf8
diff --git a/src/Mulkup/Config.hs b/src/Mulkup/Config.hs
new file mode 100644
index 0000000..f3d9fee
--- /dev/null
+++ b/src/Mulkup/Config.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Mulkup.Config (TierConfig (..), MulkupConfig (..), readConfig) where
+
+import Dhall
+import Mulkup.Prelude
+import Optics.TH
+
+--- TierConfig ---
+
+data TierConfig = TierConfig {keep :: Natural}
+ deriving stock (Generic, Show)
+ deriving anyclass (FromDhall)
+
+makeFieldLabelsNoPrefix ''TierConfig
+
+--- TierConfigs ---
+
+data TierConfigs = TierConfigs {hourly :: TierConfig, daily :: TierConfig, weekly :: TierConfig, monthly :: TierConfig}
+ deriving stock (Generic, Show)
+ deriving anyclass (FromDhall)
+
+makeFieldLabelsNoPrefix ''TierConfigs
+
+--- StashConfigs ---
+
+data StashConfig = StashConfig {name :: Text, baseDir :: Text, tiers :: TierConfigs, exclusions :: [Text]}
+ deriving stock (Generic, Show)
+ deriving anyclass (FromDhall)
+
+makeFieldLabelsNoPrefix ''StashConfig
+
+--- MulkupConfig ---
+
+data MulkupConfig = MulkupConfig {host :: Text, stashes :: [StashConfig]}
+ deriving stock (Generic, Show)
+ deriving anyclass (FromDhall)
+
+makeFieldLabelsNoPrefix ''MulkupConfig
+
+--- readConfig ---
+
+readConfig :: Text -> IO MulkupConfig
+readConfig = Dhall.input auto
diff --git a/src/Mulkup/Flags.hs b/src/Mulkup/Flags.hs
new file mode 100644
index 0000000..c5aa758
--- /dev/null
+++ b/src/Mulkup/Flags.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Mulkup.Flags (Flags (..), flagParser) where
+
+import Mulkup.Prelude
+import Optics.TH
+import Options.Applicative
+ ( Parser,
+ help,
+ long,
+ short,
+ switch,
+ )
+
+data Flags = Flags
+ {verbose :: Bool}
+
+makeFieldLabelsNoPrefix ''Flags
+
+flagParser :: Parser Flags
+flagParser =
+ Flags <$> switch (long "verbose" <> short 'v' <> help "Log verbosely.")
diff --git a/src/Mulkup/Logging.hs b/src/Mulkup/Logging.hs
new file mode 100644
index 0000000..cc6a1cc
--- /dev/null
+++ b/src/Mulkup/Logging.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Mulkup.Logging where
+
+import Colog (Message, Msg (..), Severity (..))
+import Colog.Polysemy.Effect (Log, log)
+import Data.Text (pack)
+import Mulkup.Prelude
+import Polysemy (Member, Sem)
+
+msg :: Severity -> Text -> Message
+msg msgSeverity msgText = withFrozenCallStack (Msg {msgStack = callStack, ..})
+
+debugMsg :: Text -> Message
+debugMsg = withFrozenCallStack (msg Debug)
+
+infoMsg :: Text -> Message
+infoMsg = withFrozenCallStack (msg Info)
+
+warningMsg :: Text -> Message
+warningMsg = withFrozenCallStack (msg Warning)
+
+errorMsg :: Text -> Message
+errorMsg = withFrozenCallStack (msg Error)
+
+exceptionMsg :: Exception e => e -> Message
+exceptionMsg = withFrozenCallStack (msg Error . pack . displayException)
+
+logDebug :: Member (Log Message) r => Text -> Sem r ()
+logDebug = withFrozenCallStack (log . debugMsg)
+
+logInfo :: Member (Log Message) r => Text -> Sem r ()
+logInfo = withFrozenCallStack (log . infoMsg)
+
+logWarning :: Member (Log Message) r => Text -> Sem r ()
+logWarning = withFrozenCallStack (log . warningMsg)
+
+logError :: Member (Log Message) r => Text -> Sem r ()
+logError = withFrozenCallStack (log . errorMsg)
+
+logException :: Exception e => Member (Log Message) r => e -> Sem r ()
+logException = withFrozenCallStack (log . exceptionMsg)
diff --git a/src/Mulkup/Main.hs b/src/Mulkup/Main.hs
new file mode 100644
index 0000000..3b080c4
--- /dev/null
+++ b/src/Mulkup/Main.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Mulkup.Main where
+
+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 Optics
+import Options.Applicative
+ ( execParser,
+ fullDesc,
+ helper,
+ info,
+ )
+import Polysemy (Member, Sem)
+import Polysemy.Error
+import Polysemy.Final
+import Polysemy.Reader (Reader, asks, runReader)
+
+main :: IO ()
+main = do
+ flags <- execParser $ info (flagParser <**> helper) fullDesc
+ let messageAction =
+ if verbose flags
+ then richMessageAction
+ else simpleMessageAction
+
+ config <- readConfig "./config.dhall"
+
+ result <-
+ main'
+ & runBupstash
+ & runLogAction @IO messageAction
+ & runReader (config :: MulkupConfig)
+ & errorToIOFinal @Text
+ & embedToFinal @IO
+ & runFinal @IO
+
+ case result of
+ Left err -> do
+ error err
+ Right () ->
+ return ()
+
+main' :: (Member (Log Message) r, Member (Reader MulkupConfig) r, Member Bupstash r) => Sem r ()
+main' = do
+ stashes <- asks @MulkupConfig (^. #stashes)
+ forM_ stashes $ \stash -> do
+ let labels = [("name", stash ^. #name)]
+
+ 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
+
+ logInfo (show labels <> " Keeping: " <> show (Set.toList keepIds))
+ logInfo (show labels <> " Removing: " <> show (Set.toList rmIds))
+ bupRemove (Set.toList rmIds)
+
+ logInfo (show labels <> " Creating backup.")
+ bupPut
+ (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
diff --git a/src/Mulkup/Prelude.hs b/src/Mulkup/Prelude.hs
new file mode 100644
index 0000000..632f059
--- /dev/null
+++ b/src/Mulkup/Prelude.hs
@@ -0,0 +1,10 @@
+module Mulkup.Prelude
+ ( module Relude,
+ module Relude.Extra.Group,
+ module Relude.Extra.Map,
+ )
+where
+
+import Relude hiding (Reader, ask, asks, local, runReader)
+import Relude.Extra.Group
+import Relude.Extra.Map
diff --git a/src/bin/Main.hs b/src/bin/Main.hs
new file mode 100644
index 0000000..04507b8
--- /dev/null
+++ b/src/bin/Main.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import qualified Mulkup.Main
+import Mulkup.Prelude
+
+main :: IO ()
+main = Mulkup.Main.main