diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Pascal Hartig (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Pascal Hartig nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/attic-schedule.cabal b/attic-schedule.cabal new file mode 100644 --- /dev/null +++ b/attic-schedule.cabal @@ -0,0 +1,41 @@ +name: attic-schedule +version: 0.2.0 +synopsis: A script I use to run "attic" for my backups. +description: Please see README.md +homepage: http://github.com/passy/attic-schedule#readme +license: BSD3 +license-file: LICENSE +author: Pascal Hartig +maintainer: phartig@rdrei.net +copyright: 2015 Pascal Hartig +category: Web +build-type: Simple +cabal-version: >=1.10 + +executable attic-schedule + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + Ghc-options: -Wall + -Wcompat + -fwarn-tabs + -fwarn-incomplete-record-updates + -fwarn-monomorphism-restriction + -fwarn-unused-do-bind + build-depends: base >= 4.7 && < 5 + , attoparsec + , control-bool + , foldl + , protolude + , system-filepath + , text + , time + , turtle + +test-suite doctests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + ghc-options: -threaded + main-is: doctests.hs + build-depends: base + , doctest >= 0.8 diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,3 @@ +import Test.DocTest + +main = doctest ["-isrc", "src/Main.hs"] diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Main where + +import qualified Control.Foldl as Fold +import qualified Data.Attoparsec.Text as PT +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import Protolude hiding ((%), FilePath, (<>), fold) +import Turtle + +import Data.String (String) +import Data.Char (isSpace) +import Data.Foldable (maximumBy) +import Data.Function (on) +import Data.Time (TimeOfDay (..), UTCTime (..), + addUTCTime, defaultTimeLocale, + diffUTCTime, getCurrentTime, + parseTimeM, timeToTimeOfDay) + +type ParsedBackups = Either String [BackupList] + +data Options = Options { dest :: FilePath + , src :: FilePath + , name :: Text + } deriving Show + +data BackupList = BackupList { backupTag :: Text + , backupTime :: UTCTime + } deriving (Show, Eq) + +backupListParser :: PT.Parser BackupList +backupListParser = do + name' <- PT.takeTill isSpace + _ <- PT.skipSpace + _weekDay <- PT.skipWhile (not . isSpace) + dateStr <- PT.takeTill PT.isEndOfLine + + -- "Oct 5 12:23:45 2015" + date' <- case parseTimeM True defaultTimeLocale "%b %e %X %Y" (T.unpack dateStr) of + Just pd -> return pd + Nothing -> error $ "Invalid date: " <> dateStr + + return BackupList { backupTag = name' + , backupTime = date' + } + +getAtticRepo :: Options -> FilePath +getAtticRepo opts = dest opts fromText (name opts <> ".attic") + +optionsParser :: Parser Options +optionsParser = Options <$> optPath "dest" 'd' "Destination (has to equal mount point in my case)" + <*> optPath "src" 's' "Source directory" + <*> optText "name" 'n' "Base identifier name" + +getYesterday :: IO UTCTime +getYesterday = do + let minimumDiff = -1 * 24 * 60 * 60 :: NominalDiffTime + addUTCTime minimumDiff <$> getCurrentTime + +-- | Based on the list of backups, decide whether or not to schedule a backup. +-- +-- Don't barf on empty results. +-- >>> shouldBackup $ Right [] +-- True +shouldBackup :: ParsedBackups -> IO Bool +shouldBackup backupList = do + yesterday <- getYesterday + let lastBackup = findLastBackup <$> backupList + return $ all (maybe True $ backupOlderThan yesterday) lastBackup + +doBackup :: FilePath -> FilePath -> Shell ExitCode +doBackup src' repo = do + now <- liftIO getCurrentTime + + let dayStr :: Text + dayStr = show . utctDay $ now + hourStr :: Text + hourStr = show . todHour . timeToTimeOfDay . utctDayTime $ now + target :: Text + target = format (fp%"::"%s%":"%s) repo dayStr hourStr + + echo $ "Creating new backup with target " <> target + proc "attic" ["create", target, format fp src', "--stats"] empty + +backupOlderThan :: UTCTime -> BackupList -> Bool +backupOlderThan time' backup = diffUTCTime time' (backupTime backup) > 0 + +mount :: FilePath -> IO ExitCode +mount path = proc "sudo" ["mount", format fp path] empty + +obtainBackupList :: FilePath -> IO (Either String [BackupList]) +obtainBackupList repo = do + output' <- fold (inproc "attic" ["list", format fp repo] empty) Fold.list + return $ sequence $ PT.parseOnly backupListParser <$> output' + +-- | O(n) finds the last backup +-- >>> findLastBackup [] +-- Nothing +findLastBackup :: [BackupList] -> Maybe BackupList +findLastBackup [] = Nothing +findLastBackup l = pure . maximumBy (compare `on` backupTime) $ l + +-- | Not really reliable way to check if something is possibly mounted. +-- If the given path is a sub-path of a mounted item, it will return a +-- false positive. +isPathMounted :: FilePath -> IO Bool +isPathMounted path = do + mounts <- TIO.readFile "/proc/mounts" + return $ format fp path `T.isInfixOf` mounts + +main :: IO () +main = do + opts <- options "Attic Schedule" optionsParser + let repo = getAtticRepo opts + + unlessM (isPathMounted $ dest opts) $ do + echo $ format ("Doesn't seem like "%s%" is mounted. Let me do that for you …") (show $ dest opts) + mount (dest opts) >>= \case + ExitSuccess -> return () + ExitFailure _ -> error $ "Failed to mount " <> show (dest opts) + + backupList <- obtainBackupList repo + shouldBackup' <- shouldBackup backupList + + if shouldBackup' then do + echo "Last backup is older than 24h, let's do it!" + view $ doBackup (src opts) repo + else + echo "Old backup isn't even a day old. I'll skip it for now."