attic-schedule (empty) → 0.2.0

raw patch · 5 files changed

+210/−0 lines, 5 filesdep +attoparsecdep +basedep +control-boolsetup-changed

Dependencies added: attoparsec, base, control-bool, doctest, foldl, protolude, system-filepath, text, time, turtle

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• attic-schedule.cabal +41/−0
• doctests.hs +3/−0
• src/Main.hs +134/−0

@@ -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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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

@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["-isrc", "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."