commit 58e44f1e772628c10b2528a110e96c44597266df
parent e6d18e706a04381a1d475385d26b73d22208ca9e
Author: mtmn <miro@haravara.org>
Date: Sat, 9 May 2026 13:48:52 +0200
backup: use turtle for scripting
Diffstat:
2 files changed, 144 insertions(+), 215 deletions(-)
diff --git a/backup/backup.cabal b/backup/backup.cabal
@@ -1,18 +1,18 @@
-cabal-version: 3.0
+cabal-version: 3.16
name: backup
version: 0.1.0
build-type: Simple
executable backup
- main-is: backup.hs
- hs-source-dirs: .
- default-language: GHC2021
- ghc-options: -Wall -O2
+ main-is: backup.hs
+ hs-source-dirs: .
+ default-language: GHC2024
+ default-extensions: OverloadedStrings
+ ghc-options: -Wall -O2
build-depends:
, base >= 4.14 && < 5
- , containers >= 0.6
- , directory >= 1.3
- , mtl >= 2.2
- , process >= 1.6
- , time >= 1.9
+ , containers >= 0.6 && < 0.8
+ , text >= 2.1
+ , time >= 1.9 && < 1.15
+ , turtle >= 1.6.2
diff --git a/backup/backup.hs b/backup/backup.hs
@@ -1,38 +1,22 @@
module Main where
-import Control.Monad (forM_, unless, when)
-import Control.Monad.Except (ExceptT, runExceptT, throwError)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad (forM_)
import Data.List (sort)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
+import Data.Text qualified as T
import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)
-import System.Directory (findExecutable)
-import System.Environment (getArgs, getEnv, getProgName)
-import System.Exit (ExitCode (..), exitFailure, exitSuccess)
-import System.IO (hPutStrLn, stderr)
-import System.Process (
- StdStream (..),
- createProcess,
- proc,
- readProcessWithExitCode,
- std_err,
- std_in,
- std_out,
- waitForProcess,
- )
-
-type BackupM = ExceptT String IO
+import Turtle hiding (sort)
data Config = Config
- { cfgHome :: FilePath
- , cfgGitDirs :: Map String FilePath
- , cfgGitAnnexDirs :: Map String FilePath
- , cfgPlakarDirs :: Map String FilePath
- , cfgMobiusDirs :: Map String FilePath
+ { cfgHome :: Text
+ , cfgGitDirs :: Map Text Text
+ , cfgGitAnnexDirs :: Map Text Text
+ , cfgPlakarDirs :: Map Text Text
+ , cfgMobiusDirs :: Map Text Text
}
-mkConfig :: FilePath -> Config
+mkConfig :: Text -> Config
mkConfig h =
Config
{ cfgHome = h
@@ -65,189 +49,161 @@ mkConfig h =
-- Logging
-ts :: IO String
-ts = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" <$> getCurrentTime
+ts :: IO Text
+ts = T.pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" <$> getCurrentTime
-logMsg :: String -> IO ()
-logMsg msg = ts >>= \t -> putStrLn $ "[" <> t <> "]: " <> msg
+logMsg :: Text -> IO ()
+logMsg msg = ts >>= \t -> echo (unsafeTextToLine $ "[" <> t <> "]: " <> msg)
-errMsg :: String -> IO ()
-errMsg msg = ts >>= \t -> hPutStrLn stderr $ "[" <> t <> "]: " <> msg
+fatal :: Text -> IO a
+fatal msg = do
+ t <- ts
+ err (unsafeTextToLine $ "[" <> t <> "]: " <> msg)
+ exit (ExitFailure 1)
-- Process helpers
-gitPrefix :: FilePath -> [String]
+gitPrefix :: Text -> [Text]
gitPrefix dir = ["--git-dir=" <> dir <> "/.git", "--work-tree=" <> dir]
--- Silent: capture and discard output, return exit code
-gitSilent :: FilePath -> [String] -> IO ExitCode
-gitSilent dir args = do
- (ec, _, _) <- readProcessWithExitCode "git" (gitPrefix dir <> args) ""
- return ec
-
--- Capture stdout only
-gitCapture :: FilePath -> [String] -> IO (ExitCode, String)
-gitCapture dir args = do
- (ec, out, _) <- readProcessWithExitCode "git" (gitPrefix dir <> args) ""
- return (ec, out)
+gitSilent :: Text -> [Text] -> IO ExitCode
+gitSilent dir args = fst <$> procStrict "git" (gitPrefix dir <> args) empty
--- Inherit all handles (shows output, allows credential prompts)
-gitLoud :: FilePath -> [String] -> IO ExitCode
-gitLoud dir args = runLoud "git" (gitPrefix dir <> args)
+gitCapture :: Text -> [Text] -> IO (ExitCode, Text)
+gitCapture dir args = procStrict "git" (gitPrefix dir <> args) empty
-runLoud :: String -> [String] -> IO ExitCode
-runLoud cmd args = do
- let p = (proc cmd args){std_in = Inherit, std_out = Inherit, std_err = Inherit}
- (_, _, _, ph) <- createProcess p
- waitForProcess ph
+gitLoud :: Text -> [Text] -> IO ExitCode
+gitLoud dir args = proc "git" (gitPrefix dir <> args) stdin
-runSilent :: String -> [String] -> IO ExitCode
-runSilent cmd args = do
- (ec, _, _) <- readProcessWithExitCode cmd args ""
- return ec
+runSilent :: Text -> [Text] -> IO ExitCode
+runSilent cmd args = fst <$> procStrict cmd args empty
-requireCmd :: String -> BackupM ()
+requireCmd :: Text -> IO ()
requireCmd cmd =
- liftIO (findExecutable cmd) >>= maybe (throwError $ cmd <> " not found") (const $ return ())
+ which (T.unpack cmd) >>= maybe (fatal $ cmd <> " not found") (const $ return ())
ok :: ExitCode -> Bool
ok = (== ExitSuccess)
-- Core logic
-syncRepos :: FilePath -> Bool -> Bool -> BackupM ()
+syncRepos :: Text -> Bool -> Bool -> IO ()
syncRepos dir push annex = do
- stageEc <-
- liftIO $
- gitSilent dir $
- if annex then ["annex", "add", "."] else ["add", "-A"]
- unless (ok stageEc) $
- throwError $
- "Failed to stage changes in " <> dir
+ stageEc <- gitSilent dir $ if annex then ["annex", "add", "."] else ["add", "-A"]
+ unless (ok stageEc) $ fatal $ "Failed to stage changes in " <> dir
- diffEc <- liftIO $ gitSilent dir ["diff", "--cached", "--quiet"]
+ diffEc <- gitSilent dir ["diff", "--cached", "--quiet"]
if ok diffEc
- then liftIO $ logMsg $ "Nothing to commit in " <> dir
+ then logMsg $ "Nothing to commit in " <> dir
else do
- (_, changed) <- liftIO $ gitCapture dir ["diff", "--cached", "--name-only"]
- let commitMsg = unwords . lines $ changed
- commitEc <- liftIO $ gitLoud dir ["commit", "-m", commitMsg]
- unless (ok commitEc) $
- throwError $
- "Failed to commit changes in " <> dir
- liftIO $ logMsg $ "Committed changes in " <> dir
+ (_, changed) <- gitCapture dir ["diff", "--cached", "--name-only"]
+ commitEc <- gitLoud dir ["commit", "-m", T.unwords . T.lines $ changed]
+ unless (ok commitEc) $ fatal $ "Failed to commit changes in " <> dir
+ logMsg $ "Committed changes in " <> dir
when push $
if annex
then do
- liftIO $ logMsg $ "Syncing annex in " <> dir
- syncEc <- liftIO $ gitLoud dir ["annex", "sync", "--content"]
- unless (ok syncEc) $ throwError $ "Failed to sync annex in " <> dir
- liftIO $ logMsg $ "Successfully synced annex in " <> dir
+ logMsg $ "Syncing annex in " <> dir
+ syncEc <- gitLoud dir ["annex", "sync", "--content"]
+ unless (ok syncEc) $ fatal $ "Failed to sync annex in " <> dir
+ logMsg $ "Successfully synced annex in " <> dir
else do
- liftIO $ logMsg $ "Pushing changes from " <> dir
- pushEc <- liftIO $ gitLoud dir ["push"]
- unless (ok pushEc) $ throwError $ "Failed to push changes from " <> dir
- liftIO $ logMsg $ "Successfully pushed changes from " <> dir
+ logMsg $ "Pushing changes from " <> dir
+ pushEc <- gitLoud dir ["push"]
+ unless (ok pushEc) $ fatal $ "Failed to push changes from " <> dir
+ logMsg $ "Successfully pushed changes from " <> dir
-plakarSync :: Config -> String -> BackupM ()
+plakarSync :: Config -> Text -> IO ()
plakarSync cfg name = case Map.lookup name (cfgPlakarDirs cfg) of
- Nothing -> throwError $ "Unknown plakar target: " <> name
+ Nothing -> fatal $ "Unknown plakar target: " <> name
Just dir -> do
- liftIO $ logMsg $ "Syncing plakar/" <> name <> " from " <> dir
+ logMsg $ "Syncing plakar/" <> name <> " from " <> dir
ec <-
- liftIO $
- runSilent
- "plakar"
- [ "at"
- , "@estri"
- , "backup"
- , "--ignore"
- , "**/.local/share/containers*"
- , "--ignore"
- , "**/Steam*"
- , "--ignore"
- , "**/mnt*"
- , "--ignore"
- , "**/.git*"
- , dir
- ]
- unless (ok ec) $ throwError $ "plakar failed for " <> name
- liftIO $ logMsg $ "Done plakar/" <> name
+ runSilent
+ "plakar"
+ [ "at"
+ , "@estri"
+ , "backup"
+ , "--ignore"
+ , "**/.local/share/containers*"
+ , "--ignore"
+ , "**/Steam*"
+ , "--ignore"
+ , "**/mnt*"
+ , "--ignore"
+ , "**/.git*"
+ , dir
+ ]
+ unless (ok ec) $ fatal $ "plakar failed for " <> name
+ logMsg $ "Done plakar/" <> name
-mobiusSync :: Config -> String -> BackupM ()
+mobiusSync :: Config -> Text -> IO ()
mobiusSync cfg name = case Map.lookup name (cfgMobiusDirs cfg) of
- Nothing -> throwError $ "Unknown mobius target: " <> name
+ Nothing -> fatal $ "Unknown mobius target: " <> name
Just dir -> do
- liftIO $ logMsg $ "Syncing mobius/" <> name <> " from " <> dir
+ logMsg $ "Syncing mobius/" <> name <> " from " <> dir
ec <-
- liftIO $
- runSilent
- "aws"
- [ "s3"
- , "sync"
- , "--exclude"
- , "*/.git/*"
- , "--no-follow-symlinks"
- , dir
- , "s3://mobius/" <> name
- ]
- unless (ok ec) $ throwError $ "aws s3 sync failed for " <> name
- liftIO $ logMsg $ "Done mobius/" <> name
+ runSilent
+ "aws"
+ [ "s3"
+ , "sync"
+ , "--exclude"
+ , "*/.git/*"
+ , "--no-follow-symlinks"
+ , dir
+ , "s3://mobius/" <> name
+ ]
+ unless (ok ec) $ fatal $ "aws s3 sync failed for " <> name
+ logMsg $ "Done mobius/" <> name
-backup :: Config -> String -> Bool -> BackupM ()
+backup :: Config -> Text -> Bool -> IO ()
backup cfg btype push = case btype of
"push" -> do
- forM_ (Map.toList (cfgGitDirs cfg)) $ \(name, dir) -> do
- liftIO $ logMsg name
- syncRepos dir True False
- forM_ (Map.toList (cfgGitAnnexDirs cfg)) $ \(name, dir) -> do
- liftIO $ logMsg $ name <> " (annex)"
- syncRepos dir True True
+ forM_ (Map.toList (cfgGitDirs cfg)) $ \(name, dir) ->
+ logMsg name >> syncRepos dir True False
+ forM_ (Map.toList (cfgGitAnnexDirs cfg)) $ \(name, dir) ->
+ logMsg (name <> " (annex)") >> syncRepos dir True True
"git" ->
- forM_ (Map.toList (cfgGitDirs cfg)) $ \(name, dir) -> do
- liftIO $ logMsg name
- syncRepos dir push False
+ forM_ (Map.toList (cfgGitDirs cfg)) $ \(name, dir) ->
+ logMsg name >> syncRepos dir push False
"annex" ->
- forM_ (Map.toList (cfgGitAnnexDirs cfg)) $ \(name, dir) -> do
- liftIO $ logMsg $ name <> " (annex)"
- syncRepos dir push True
- "ls" -> liftIO $ do
- putStrLn "git"
- mapM_ (\k -> putStrLn $ " " <> k) . sort . Map.keys $ cfgGitDirs cfg
- putStrLn "git-annex"
- mapM_ (\k -> putStrLn $ " " <> k) . sort . Map.keys $ cfgGitAnnexDirs cfg
- putStrLn "plakar"
- mapM_ (\k -> putStrLn $ " " <> k) . sort . Map.keys $ cfgPlakarDirs cfg
- putStrLn "mobius"
- mapM_ (\k -> putStrLn $ " " <> k) . sort . Map.keys $ cfgMobiusDirs cfg
+ forM_ (Map.toList (cfgGitAnnexDirs cfg)) $ \(name, dir) ->
+ logMsg (name <> " (annex)") >> syncRepos dir push True
+ "ls" -> do
+ echo "git"
+ mapM_ (echo . unsafeTextToLine . (" " <>)) . sort . Map.keys $ cfgGitDirs cfg
+ echo "git-annex"
+ mapM_ (echo . unsafeTextToLine . (" " <>)) . sort . Map.keys $ cfgGitAnnexDirs cfg
+ echo "plakar"
+ mapM_ (echo . unsafeTextToLine . (" " <>)) . sort . Map.keys $ cfgPlakarDirs cfg
+ echo "mobius"
+ mapM_ (echo . unsafeTextToLine . (" " <>)) . sort . Map.keys $ cfgMobiusDirs cfg
"local" -> do
requireCmd "plakar"
- liftIO $ logMsg "Running plakar"
+ logMsg "Running plakar"
ec <-
- liftIO $
- runSilent
- "plakar"
- [ "at"
- , "@hoo"
- , "backup"
- , "--ignore"
- , "**/.cache*"
- , "--ignore"
- , "**/Steam*"
- , "--ignore"
- , "**/mnt*"
- , "--ignore"
- , "**/.git*"
- , cfgHome cfg
- ]
- unless (ok ec) $ throwError "plakar local backup failed"
- liftIO $ logMsg "Done plakar local"
- t
- | t == "plakar" ->
- forM_ (Map.keys (cfgPlakarDirs cfg)) $ plakarSync cfg
- | t == "mobius" ->
- forM_ (Map.keys (cfgMobiusDirs cfg)) $ mobiusSync cfg
+ runSilent
+ "plakar"
+ [ "at"
+ , "@hoo"
+ , "backup"
+ , "--ignore"
+ , "**/.cache*"
+ , "--ignore"
+ , "**/Steam*"
+ , "--ignore"
+ , "**/mnt*"
+ , "--ignore"
+ , "**/.git*"
+ , cfgHome cfg
+ ]
+ unless (ok ec) $ fatal "plakar local backup failed"
+ logMsg "Done plakar local"
+ "plakar" ->
+ forM_ (Map.keys (cfgPlakarDirs cfg)) $ plakarSync cfg
+ "mobius" ->
+ forM_ (Map.keys (cfgMobiusDirs cfg)) $ mobiusSync cfg
_ -> case ( Map.lookup btype (cfgGitDirs cfg)
, Map.lookup btype (cfgGitAnnexDirs cfg)
, Map.lookup btype (cfgPlakarDirs cfg)
@@ -255,48 +211,21 @@ backup cfg btype push = case btype of
(Just dir, _, _) -> syncRepos dir push False
(_, Just dir, _) -> syncRepos dir push True
(_, _, Just _) -> plakarSync cfg btype
- _ -> throwError $ "Unknown backup type '" <> btype <> "'"
+ _ -> fatal $ "Unknown backup type '" <> btype <> "'"
-showUsage :: IO ()
-showUsage = do
- prog <- getProgName
- hPutStrLn stderr $
- unlines
- [ "Usage: " <> prog <> " <backup_type> [--push]"
- , ""
- , "Backup types:"
- , " push - Backup and push everything"
- , " ls - List available backup types"
- , " git - Sync all git repos"
- , " annex - Sync all git-annex repos"
- , " local - Sync using plakar"
- , " plakar - Sync using plakar"
- , " mobius - Sync to mobius bucket"
- , " <name> - Backup specific item"
- , ""
- , "Options:"
- , " --push - Push changes after commit (for Git items)"
- , " -h, --help - Show this help message"
- ]
+data Args = Args
+ { argBackupType :: Text
+ , argPush :: Bool
+ }
-parseArgs :: [String] -> IO (String, Bool)
-parseArgs = go "" False
- where
- go t _ ("--push" : rest) = go t True rest
- go _ _ ("-h" : _) = showUsage >> exitSuccess
- go _ _ ("--help" : _) = showUsage >> exitSuccess
- go "" p (arg : rest) = go arg p rest
- go _ _ (_ : _) = errMsg "Too many arguments" >> showUsage >> exitFailure
- go "" _ [] = errMsg "Missing backup type" >> showUsage >> exitFailure
- go t p [] = return (t, p)
+argsParser :: Parser Args
+argsParser =
+ Args
+ <$> argText "backup_type" "Type of backup (push, ls, git, annex, local, plakar, mobius, <name>)"
+ <*> switch "push" 'p' "Push changes after commit (for Git items)"
main :: IO ()
main = do
- args <- getArgs
- (btype, pushFlag) <- parseArgs args
- h <- getEnv "HOME"
- let cfg = mkConfig h
- result <- runExceptT $ backup cfg btype pushFlag
- case result of
- Left err -> errMsg ("Backup operation failed: " <> err) >> exitFailure
- Right () -> return ()
+ Args btype pushFlag <- options "Backup manager" argsParser
+ h <- need "HOME" >>= maybe (die "HOME not set") return
+ backup (mkConfig h) btype pushFlag
