shelly Haskell script for automating my btrfs backups

gistfile1.hs

#!/usr/bin/env runhaskell
{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}

import Shelly
import Prelude hiding (FilePath)
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
import Control.Concurrent
import Data.List (isInfixOf, sort)
import Text.Shakespeare.Text (st)
import Filesystem.Path.CurrentOS hiding (fromText, (<.>))
import Text.ShellEscape
import System.Environment

{-

TODO

need to mount each disk at the root subvolume before doing the send otherwise will fail

-}

data MountPoint = MountPoint T.Text T.Text deriving (Show)

mountPoints = [
    MountPoint "f2e4e4d3-2d8e-4764-a818-de9176405c4b" "/mnt/ssd"
    ,MountPoint "31eee848-aad7-4d5c-bfb8-f3829cfb2209" "/mnt/internal"
    --,MountPoint "21d841c9-7c30-4d1b-b4c2-8c0e59e8959a" "/mnt/huge"
    ]


            --  subvol name, subvol location, snapshot location, backup destination, delete snapshots ?
data BackupPoint = BackupPoint T.Text T.Text T.Text T.Text Bool deriving (Show)

backupPoints = [
    (BackupPoint "@" "/mnt/ssd" "/mnt/ssd/backups" "/media/miguel/backup/backups/" True)
    ,(BackupPoint "@home" "/mnt/ssd" "/mnt/ssd/backups" "/media/miguel/backup/backups/" True )
    ,(BackupPoint "mainSubVol" "/mnt/internal/" "/mnt/internal/mainSubVol/backups" "/media/miguel/backup/backups/" False)
    --,(BackupPoint "MUSIQUEEXT" "/media/miguel" "/media/miguel/MUSIQUEEXT/backups" "/media/miguel/backup/backups/" False)
    ,(BackupPoint "main" "/media/miguel/huge" "/media/miguel/huge/main/backups" "/media/miguel/huge-backup/" False)
    ]

debug = False

sudo com args = run "sudo" (com:args)
sudo_ com args = if debug then echo $ (T.pack) $ show ("sudo":com:args) else run_ "sudo" (com:args)

-- btrfs commands
bshow subvolume = sudo "btrfs" ["filesystem", "df", subvolume]
bsnapshot old new = sudo_ "btrfs" ["subvolume", "snapshot", "-r", old, new]
bdelete subvolume = sudo_ "btrfs" ["subvolume", "delete", subvolume]
bSendReceive a b to =
    do
        --echo $ string
        run "sh" ["-c", string]
    where string = [st| sudo btrfs send -p #{a} #{b} | sudo btrfs receive #{to} |]

-- utils
date = run "date" ["+%Y-%m-%d-%H:%M"]

-- mount
domounts = do
    currentmounts <- silently $ run "sh" ["-c", "less /proc/mounts"]
    mapM_ (mountfs currentmounts) mountPoints

mountfs currentmounts (MountPoint uuid dest) =  when (not $ T.isInfixOf dest currentmounts) $
    sudo_ "mount" ["-o", "subvolid=5", "-U", uuid, dest]


-- unmount
dounmounts = mapM_ unmountfs mountPoints

unmountfs (MountPoint uuid dest) = sudo_ "umount" [dest]



subvols = fmap (\item@(BackupPoint subvol orig snapsDir dest deleteSnap)-> subvol) backupPoints

filterSnaps subvol snaps = filter (\x -> (head (T.splitOn "-" x)) == subvol) filenames
    where filenames = map (toTextIgnore.filename) snaps

getOldSnaps item@(BackupPoint subvol orig snapsDir dest deleteSnap) = (filterSnaps subvol) <$> (ls $ fromText snapsDir)


trimOldSnaps item@(BackupPoint subvol orig snapsDir dest deleteSnap) oldSnaps = if deleteSnap then
    delete else echo [st|Subvolume #{subvol} is configured for not deleting old snapshots|]
    where   delete = if (length oldSnaps > 1) && (notElem oldestSnapFullPath subvols) then delete2
                   else echo "Only one snapshot or trying to delete main subvolumes, will not delete !"
            oldestSnap = head $ sort $ oldSnaps
            oldestSnapFullPath = [st|#{snapsDir}/#{oldestSnap}|]
            delete2 = do
                echo [st|** Deleting snapshot: #{oldestSnapFullPath}|]
                bdelete oldestSnapFullPath

testTrimOldSnap :: Int -> Shelly.Sh ()
testTrimOldSnap n = do
        domounts
        x <-  getOldSnaps item
        trimOldSnaps item x
    where item = backupPoints !! n


--escapeColon = T.replace ":" "\\:"
escapesh :: T.Text -> T.Text
escapesh = T.pack.B.unpack.bytes.sh.B.pack.T.unpack

startBackups = do
    inspect $ "Starting btrfs backup"
    domounts
    d <- date
    let fixedDate = ((T.lines d) !! 0)
    echo [st|
******************************************
** Backups #{d}
******************************************
    |]
    return fixedDate

allBackups :: Shelly.Sh ()
allBackups = do
    date <- startBackups
    mapM_ (processBackupPoint date) backupPoints
    --dounmounts


processBackupPoint date item@(BackupPoint subvol orig snapsDir dest deleteSnap) = do
    echo [st|
******************************************
** Processing subvolume #{subvol}
******************************************
    |]
    snapsDirExists <- test_e $ fromText snapsDir
    unless snapsDirExists $ errorExit [st|Error: #{snapsDir} doesn't exist. exiting.|]
    oldSnaps <- getOldSnaps item
    let youngestSnap = last $ sort $ oldSnaps
    let youngestSnapFullPath = [st|#{snapsDir}/#{youngestSnap}|]
    let newSnap =  [st|#{snapsDir}/#{subvol}-#{date}|]
    let destFullPath = [st|#{dest}#{subvol}|]
    echo [st|
** Doing Snapshot for #{subvol} in #{newSnap}
    |]
-- need to check here that old snapshot exists in target directory
    destExists <- test_e $ fromText dest
    let youngestSnapAtDestFullPath = [st|#{dest}#{subvol}/#{youngestSnap}|]
    youngestSnapExists <- test_e $ fromText youngestSnapAtDestFullPath
    if destExists then
        if youngestSnapExists then
            escaping True $ bsnapshot [st|#{orig}/#{subvol}|] newSnap
            else errorExit [st|Error #{youngestSnapAtDestFullPath} does not exist !|]
        else errorExit [st|Error #{dest} does not exist !|]
    run "sync" []
    echo [st|
** Sending #{newSnap} over to backup disk
    |]
    let send = escaping True $ bSendReceive (escapesh youngestSnapFullPath) (escapesh newSnap) (escapesh destFullPath)
    catchany_sh send (\_ -> bdelete newSnap >> errorExit [st|Error: Sending failed for snapshot #{newSnap}, deleting snapshot and exiting|] )
    trimOldSnaps item oldSnaps


parse [] = shelly $ verbosely $ allBackups
parse (n:_) = shelly $ verbosely $ do
    date <- startBackups
    inspect $ backupPoints !! (read n)
    processBackupPoint date ( backupPoints !! (read n) )

-- verbosely $
-- $ silently
main = getArgs >>= parse