commit 3fbf842d50566931c2c340fc8e01d37eb7f251da
parent 7a0f8d8afde5effe7f069c18c12ad38877a08180
Author: mtmn <miro@haravara.org>
Date: Thu, 30 Apr 2026 22:01:10 +0200
feat: add `backup` tool
Diffstat:
3 files changed, 285 insertions(+), 0 deletions(-)
diff --git a/backup/.gitignore b/backup/.gitignore
@@ -0,0 +1 @@
+dist-*
diff --git a/backup/backup.cabal b/backup/backup.cabal
@@ -0,0 +1,18 @@
+cabal-version: 3.0
+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
+
+ build-depends:
+ , base >= 4.14 && < 5
+ , containers >= 0.6
+ , directory >= 1.3
+ , mtl >= 2.2
+ , process >= 1.6
+ , time >= 1.9
diff --git a/backup/backup.hs b/backup/backup.hs
@@ -0,0 +1,266 @@
+module Main where
+
+import Control.Monad (forM_, unless, when)
+import Control.Monad.Except (ExceptT, runExceptT, throwError)
+import Control.Monad.IO.Class (liftIO)
+import Data.List (sort)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+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
+
+data Config = Config
+ { cfgHome :: FilePath
+ , cfgGitDirs :: Map String FilePath
+ , cfgGitAnnexDirs :: Map String FilePath
+ , cfgS3Dirs :: Map String FilePath
+ }
+
+mkConfig :: FilePath -> Config
+mkConfig h =
+ Config
+ { cfgHome = h
+ , cfgGitDirs =
+ Map.fromList
+ [ ("mpd", h <> "/.config/mpd")
+ , ("nix", h <> "/src/sr.ht/nix")
+ , ("nota", h <> "/misc/notes/nota")
+ , ("pass", h <> "/.password-store")
+ , ("releases", h <> "/src/haravara.org/releases")
+ , ("bandcamp", h <> "/misc/music/backlog/_todo")
+ ]
+ , cfgGitAnnexDirs =
+ Map.fromList
+ [ ("notes", h <> "/misc/notes")
+ , ("books", h <> "/misc/books")
+ , ("docs", h <> "/misc/docs")
+ , ("www", h <> "/misc/www")
+ ]
+ , cfgS3Dirs =
+ Map.fromList
+ [ ("src", h <> "/src")
+ , ("misc", h <> "/misc")
+ , ("local", h <> "/.local")
+ , ("config", h <> "/.config")
+ ]
+ }
+
+-- Logging
+
+ts :: IO String
+ts = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%z" <$> getCurrentTime
+
+logMsg :: String -> IO ()
+logMsg msg = ts >>= \t -> putStrLn $ "[" <> t <> "]: " <> msg
+
+errMsg :: String -> IO ()
+errMsg msg = ts >>= \t -> hPutStrLn stderr $ "[" <> t <> "]: " <> msg
+
+-- Process helpers
+
+gitPrefix :: FilePath -> [String]
+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)
+
+-- Inherit all handles (shows output, allows credential prompts)
+gitLoud :: FilePath -> [String] -> IO ExitCode
+gitLoud dir args = runLoud "git" (gitPrefix dir <> args)
+
+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
+
+requireCmd :: String -> BackupM ()
+requireCmd cmd =
+ liftIO (findExecutable cmd) >>= maybe (throwError $ cmd <> " not found") (const $ return ())
+
+ok :: ExitCode -> Bool
+ok = (== ExitSuccess)
+
+-- Core logic
+
+syncRepos :: FilePath -> Bool -> Bool -> BackupM ()
+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
+
+ diffEc <- liftIO $ gitSilent dir ["diff", "--cached", "--quiet"]
+ if ok diffEc
+ then liftIO $ 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
+
+ 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
+ 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
+
+s3Sync :: Config -> String -> BackupM ()
+s3Sync cfg name = case Map.lookup name (cfgS3Dirs cfg) of
+ Nothing -> throwError $ "Unknown S3 target: " <> name
+ Just dir -> do
+ ec <-
+ liftIO $
+ runLoud
+ "plakar_estri"
+ [ "backup"
+ , "--ignore"
+ , "**/.local/share/containers*"
+ , "--ignore"
+ , "**/Steam*"
+ , "--ignore"
+ , "**/mnt*"
+ , dir
+ ]
+ unless (ok ec) $ throwError $ "plakar_estri failed for " <> name
+
+backup :: Config -> String -> Bool -> BackupM ()
+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
+ "git" ->
+ forM_ (Map.toList (cfgGitDirs cfg)) $ \(name, dir) -> do
+ liftIO $ 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 "estri"
+ mapM_ (\k -> putStrLn $ " " <> k) . sort . Map.keys $ cfgS3Dirs cfg
+ "histdb" -> do
+ requireCmd "histdb-sync"
+ liftIO $ logMsg "Running histdb-sync"
+ ec <- liftIO $ runLoud "histdb-sync" []
+ unless (ok ec) $ throwError "histdb-sync failed"
+ "local" -> do
+ requireCmd "plakar"
+ liftIO $ logMsg "Running plakar"
+ ec <-
+ liftIO $
+ runLoud
+ "plakar"
+ [ "at"
+ , "@hoo"
+ , "backup"
+ , "--ignore"
+ , "**/.cache*"
+ , "--ignore"
+ , "**/Steam*"
+ , "--ignore"
+ , "**/mnt*"
+ , cfgHome cfg
+ ]
+ unless (ok ec) $ throwError "plakar local backup failed"
+ t
+ | t `elem` ["estri", "s3"] ->
+ forM_ (Map.keys (cfgS3Dirs cfg)) $ s3Sync cfg
+ _ -> case ( Map.lookup btype (cfgGitDirs cfg)
+ , Map.lookup btype (cfgGitAnnexDirs cfg)
+ , Map.lookup btype (cfgS3Dirs cfg)
+ ) of
+ (Just dir, _, _) -> syncRepos dir push False
+ (_, Just dir, _) -> syncRepos dir push True
+ (_, _, Just _) -> s3Sync cfg btype
+ _ -> throwError $ "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"
+ , " histdb - Sync using histdb-sync"
+ , " git - Sync all git repos"
+ , " annex - Sync all git-annex repos"
+ , " local - Sync using plakar"
+ , " estri - Sync to S3"
+ , " <name> - Backup specific item"
+ , ""
+ , "Options:"
+ , " --push - Push changes after commit (for Git items)"
+ , " -h, --help - Show this help message"
+ ]
+
+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)
+
+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 ()
