diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2003-2009, John Wiegley. 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 New Artisans LLC nor the names of its + 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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,977 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main where + +import Control.Concurrent.ParallelIO ( stopGlobalPool, parallel ) +import Control.DeepSeq ( NFData(..) ) +import Control.Exception ( SomeException, Exception, catch ) +import Control.Lens hiding ( value ) +import Control.Monad ( void, liftM2, (>=>) ) +import Data.Aeson ( ToJSON(..), FromJSON(..) ) +import Data.Aeson.TH ( deriveJSON ) +import qualified Data.ByteString.Char8 as BC ( writeFile, readFile ) +import Data.Char ( isDigit ) +import Data.Foldable ( for_ ) +import Data.Function ( on ) +import Data.Function.Pointless ( (.:) ) +import Data.List +import qualified Data.Map as M ( fromList, (!) ) +import Data.Maybe ( fromMaybe, isNothing, isJust, fromJust ) +import Data.Monoid ( Monoid(mconcat), (<>) ) +import Data.Stringable as S ( Stringable(fromString, toString) ) +import Data.Text.Format ( format ) +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Time.Clock ( getCurrentTime ) +import Data.Time.Format ( readTime, formatTime ) +import Data.Time.LocalTime +import Data.Yaml ( encode, decode ) +import Debug.Trace as D () +import qualified Distribution.PackageDescription.TH as Pkg +import Filesystem ( isFile, getHomeDirectory ) +import GHC.Conc ( setNumCapabilities, getNumProcessors ) +import Prelude hiding (FilePath) +import Shelly hiding (find) +import System.Console.CmdArgs +import System.Environment ( getArgs, withArgs ) +import System.IO ( stderr ) +import System.IO.Storage ( withStore, putValue, getValue ) +import System.Locale ( defaultTimeLocale ) +import System.Log.Formatter ( tfLogFormatter ) +import System.Log.Handler ( setFormatter ) +import System.Log.Handler.Simple ( streamHandler ) +import System.Log.Logger +import Text.Printf ( printf ) +import Text.Regex.Posix ( (=~) ) + +default (Integer, Text) + +instance FromJSON LocalTime where + parseJSON = + parseJSON >=> return . readTime defaultTimeLocale "%Y%m%dT%H%M%S" + +instance ToJSON LocalTime where + toJSON = toJSON . formatTime defaultTimeLocale "%Y%m%dT%H%M%S" + +instance FromJSON FilePath where + parseJSON = parseJSON >=> return . fromText + +instance ToJSON FilePath where + toJSON = toJSON . toTextIgnore + +version :: String +version = $(Pkg.packageVariable (Pkg.pkgVersion . Pkg.package)) + +copyright :: String +copyright = "2012" + +pushmeSummary :: String +pushmeSummary = "pushme v" ++ version ++ ", (C) John Wiegley " ++ copyright + +data PushmeOpts = PushmeOpts { jobs :: Int + , dryRun :: Bool + , noSync :: Bool + , loadRevs :: Bool + , stores :: Bool + , ssh :: String + , filesets :: String + , classes :: String + , verbose :: Bool + , quiet :: Bool + , debug :: Bool + , arguments :: [String] } + deriving (Data, Typeable, Show, Eq) + +pushmeOpts :: PushmeOpts +pushmeOpts = PushmeOpts + { jobs = def &= name "j" &= typ "INT" + &= help "Run INT concurrent finds at once (default: 2)" + , dryRun = def &= name "n" + &= help "Don't take any actions" + , noSync = def &= name "N" + &= help "Don't even attempt a dry-run sync" + , loadRevs = def &= name "L" + &= help "Load latest snapshot revs from disk" + , stores = def &= help "Show all the stores know to pushme" + , ssh = def &= help "Use a specific ssh command" + , filesets = def &= name "f" + &= help "Synchronize the given fileset(s) (comma-sep)" + , classes = def &= name "c" + &= help "Filesets classes to synchronize (comma-sep)" + , verbose = def &= name "v" + &= help "Report progress verbosely" + , quiet = def &= name "q" + &= help "Be a little quieter" + , debug = def &= name "D" + &= help "Report debug information" + , arguments = def &= args &= typ "ARGS..." } + + &= summary pushmeSummary + &= program "pushme" + &= help "Synchronize data from one machine to another" + +-- | A 'Fileset' is a logical grouping of files, with an assigned class and +-- priority. It may also have an associated filter. + +data Fileset = Fileset { _filesetName :: Text + , _filesetClass :: Text + , _filesetPriority :: Int + , _filesetReportMissing :: Bool } + deriving (Show, Eq) + +makeLenses ''Fileset + +$(deriveJSON (drop 8) ''Fileset) + +-- | A 'Container' is a physical grouping of files, reflecting an instance of +-- a 'Fileset' somewhere on a storage medium. For every 'Fileset', there +-- are many 'Container' instances. When a fileset is synchronized, it means +-- copying it by some means between different containers. + +data Container = Container { _containerFileset :: Text + , _containerStore :: Text + , _containerPath :: FilePath + , _containerPoolPath :: Maybe FilePath + , _containerRecurse :: Bool + , _containerLastRev :: Maybe Int + , _containerLastSync :: Maybe LocalTime } + deriving (Show, Eq) + +makeLenses ''Container + +$(deriveJSON (drop 10) ''Container) + +instance NFData Container where + rnf a = a `seq` () + +-- | A 'Store' is a repository that holds 'Container' instances in some form +-- or another. Synchronization of a remote ZFS container from a local ZFS +-- container is done by copying over incremental snapshots. Note that +-- 'storeHostName' refers to name used by SSH. + +data Store = Store { _storeName :: Text + , _storeHostRe :: Text + , _storeSelfRe :: Text + , _storeUserName :: Text + , _storeZfsPool :: Maybe Text + , _storeZfsPath :: Maybe FilePath + -- 'storeTargets' is a list of (StoreName, [FilesetName]), + -- where the containers involved are looked up from the + -- Container list by the Store/Fileset name pair for both + -- source and target. + , _storeTargets :: [(Text, [Text])] } + deriving (Show, Eq) + +makeLenses ''Store + +$(deriveJSON (drop 6) ''Store) + +instance NFData Store where + rnf a = a `seq` () + +data Info = Info { _infoHostName :: Text + , _infoStore :: Store + , _infoContainer :: Container } + deriving (Show, Eq) + +makeLenses ''Info + +data Binding = Binding { _bindingThis :: Info + , _bindingThat :: Info + , _bindingFileset :: Fileset } + deriving (Show, Eq) + +makeLenses ''Binding + +data PushmeException = PushmeException deriving (Show, Typeable) + +instance Exception PushmeException + +main :: IO () +main = do + mainArgs <- getArgs + opts <- withArgs (if null mainArgs then [] else mainArgs) + (cmdArgs pushmeOpts) + procs <- GHC.Conc.getNumProcessors + _ <- GHC.Conc.setNumCapabilities $ + case jobs opts of 0 -> min procs 1; x -> x + + runPushme opts `catch` \(_ :: PushmeException) -> return () + `catch` \(ex :: SomeException) -> error (show ex) + +testme :: IO () +testme = runPushme + PushmeOpts { jobs = 1 + , dryRun = True + , noSync = True + , loadRevs = True + , stores = False + , ssh = "" + , filesets = "" + , classes = "" + , verbose = True + , quiet = False + , debug = True + , arguments = ["@data", "data/titan"] } + +runPushme :: PushmeOpts -> IO () +runPushme opts = do + let level + | debug opts = DEBUG + | verbose opts = INFO + | otherwise = NOTICE + h <- (`setFormatter` tfLogFormatter "%H:%M:%S" "$time - [$prio] $msg") + <$> streamHandler System.IO.stderr level + + removeAllHandlers + updateGlobalLogger "pushme" (setLevel level) + updateGlobalLogger "pushme" (addHandler h) + + withStore "main" $ do + putValue "main" "opts" opts + + when (dryRun opts || noSync opts) $ + warningM "pushme" "`--dryrun' specified, no changes will be made!" + + sts <- readDataFile ".pushme/stores.yml" :: IO [Store] + fsets <- readDataFile ".pushme/filesets.yml" :: IO [Fileset] + cts <- readDataFile ".pushme/containers.yml" :: IO [Container] + + pushmeCommand opts sts fsets cts + + stopGlobalPool + +pushmeCommand :: PushmeOpts -> [Store] -> [Fileset] -> [Container] -> IO () +pushmeCommand opts sts fsets cts + | stores opts = + let fss = fromString $ filesets opts + cls = fromString $ classes opts + sorted = + sortBy (compare `on` (^._2.filesetPriority)) $ + filter + (\(_, fs) -> + (T.null fss || matchText fss (fs^.filesetName)) + && (T.null cls || matchText cls (fs^.filesetClass))) $ + map (\x -> (x, findFileset (x^.containerFileset) fsets)) $ + case arguments opts of + [] -> cts + xs -> nub $ mconcat $ map (\st -> containersForStore st cts) $ + map (\n -> findStore (fromString n) sts) xs + + in for_ sorted $ \(ct, _) -> + putStrLn $ + printf "%-12s %-38.38s %19s %5d" + (toString (ct^.containerStore)) + (toString (toTextIgnore (ct^.containerPath))) + (maybe "" (formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S") + (ct^.containerLastSync)) + (fromMaybe 0 (ct^.containerLastRev)) + + | otherwise = do + here <- shelly $ silently $ cmd "hostname" + let this = findStore here sts + + shelly $ debugL $ here <> " -> " <> fromString (show this) + + cts' <- + foldl' + (\acc host -> do + innerCts <- acc + updatedCts <- shelly $ + processHost (here,this) sts fsets innerCts (fromString host) + -- This can get expensive fast, but the number of containers + -- involved should never be large. The idea is to gather the most + -- recent data from all updated containers, until we're back to a + -- fully up-to-date master list. We can't do it "as we go" + -- because of the parallel processing. + return $ + map (\ct -> foldl' mergeContainers ct updatedCts) innerCts) + (return cts) (arguments opts) + + unless (dryRun opts || noSync opts) $ + writeDataFile ".pushme/containers.yml" cts' + +processHost :: (Text, Store) -> [Store] -> [Fileset] -> [Container] -> Text + -> Sh [Container] +processHost defaultSelf@(here, _) sts fsets conts thereRaw + | T.head thereRaw == '@' = do + let there = T.drop 1 thereRaw + that = findStore there sts + bindings <- + traverse (\x -> createBinding defaultSelf (there,that) fsets conts + (x^.containerFileset)) + (containersForStore that conts) + sorted <- filterAndSortBindings bindings + mconcat <$> + (sequence $ flip map sorted $ \bnd -> do + let info = bnd^.bindingThat + createSnapshot (storeIsLocal here (info^.infoStore)) info) + + | otherwise = do + let (self@(_, this), there) = + if "/" `T.isInfixOf` thereRaw + then let [b, e] = T.splitOn "/" thereRaw + in ((b, findStore b sts), e) + else (defaultSelf, thereRaw) + that = findStore there sts + + debugL $ (this^.storeHostRe) <> " -> " <> fromString (show this) + debugL $ there <> " -> " <> fromString (show that) + + noticeL $ format "Synchronizing {} -> {}" + [this^.storeName , that^.storeName] + + case lookup (that^.storeName) (this^.storeTargets) of + Nothing -> warningL "Nothing to do" >> return [] + + Just xs -> do + bindings <- traverse (createBinding self (there,that) fsets conts) xs + >>= filterAndSortBindings + for_ bindings $ \bnd -> + when (bnd^.bindingFileset.filesetReportMissing) $ + reportMissingFiles (bnd^.bindingFileset.filesetName) + (bnd^.bindingThis.infoContainer) + return . mconcat =<< + (liftIO . parallel . map (shelly . syncContainers) $ bindings) + + where + filterAndSortBindings bindings = do + fss <- fromString <$> getOption filesets + cls <- fromString <$> getOption classes + return + $ sortBy (compare `on` (^.bindingFileset.filesetPriority)) + $ filter + (\x -> (T.null fss || + matchText fss (x^.bindingFileset.filesetName)) + && (T.null cls || + matchText cls (x^.bindingFileset.filesetClass))) + bindings + +zfsPoolPath :: Info -> FilePath +zfsPoolPath info = + fromMaybe (error $ "storeZfsPool is Nothing: " ++ show info) + (info^.infoStore.storeZfsPool) + fromMaybe (error $ "containerPoolPath is Nothing: " ++ show info) + (info^.infoContainer.containerPoolPath) + +zfsFilePath :: Info -> IO FilePath +zfsFilePath info = do + Pathname p <- + getPathname $ + fromMaybe (error $ "storeZfsPath is Nothing: " ++ show info) + (info^.infoStore.storeZfsPath) + fromMaybe (error $ "containerPoolPath is Nothing: " ++ show info) + (info^.infoContainer.containerPoolPath) + return p + +getZfsPath :: Info -> Bool -> IO ContainerPath +getZfsPath info bothZfs + | bothZfs = return $ ZfsFilesystem $ toTextIgnore $ zfsPoolPath info + | isZfs info = Pathname <$> zfsFilePath info + | otherwise = getPathname (info^.infoContainer.containerPath) + +createSnapshot :: Bool -> Info -> Sh [Container] +createSnapshot local info + | isZfs info = do + let cont = info^.infoContainer + lastRev = cont^.containerLastRev + nextRev = case lastRev of Nothing -> 1; Just x -> succ x + poolName = zfsPoolPath info + thatSnapshot = toTextIgnore poolName <> "@" <> intToText nextRev + snapCmd = ["zfs", "snapshot"] + <> ["-r" | cont^.containerRecurse] + <> [thatSnapshot] + + noticeL $ format "Creating snapshot {}" [thatSnapshot] + + if local + then + vrun_ "sudo" snapCmd + else do + let u = info^.infoStore.storeUserName + h = info^.infoHostName + remote vrun_ (format "{}@{}" [u, h]) snapCmd + + return [containerLastRev .~ Just nextRev $ cont] + + | otherwise = return [] + +reportMissingFiles :: Text -> Container -> Sh () +reportMissingFiles label cont = do + (Pathname contPath) <- liftIO $ getPathname (cont^.containerPath) + + files <- map (T.drop (T.length (toTextIgnore contPath)) + . toTextIgnore) + <$> ls contPath + optsFile <- liftIO $ getHomePath (".pushme/filters/" + <> cont^.containerFileset) + exists <- liftIO $ isFile optsFile + + when exists $ do + optsText <- readfile optsFile + let stringify = (\x -> if T.head x == '/' then T.tail x else x) + . (\x -> if T.index x (T.length x - 1) == '/' + then T.init x else x) + . T.drop 2 + regexToGlob = T.replace "].*" "]*" + . T.replace "*" ".*" + . T.replace "?" "." + . T.replace "." "\\." + patterns = map regexToGlob + . filter (`notElem` ["*", "*/", ".*", ".*/"]) + . map stringify . T.lines $ optsText + patMatch f p = (toString f) =~ (toString p) + files' = + foldl' (\acc x -> + if any (patMatch x) patterns + then acc + else x:acc) [] + (filter (`notElem` [ ".DS_Store", ".localized" ]) files) + + for_ files' $ \f -> + warningL $ format "{}: unknown: \"{}\"" [label, f] + +createBinding :: (Text, Store) -> (Text, Store) -> [Fileset] -> [Container] + -> Text -> Sh Binding +createBinding (here,this) (there,that) fsets conts n = do + let bnd = + case find (\x -> x^.filesetName == n) fsets of + Nothing -> + error $ toString $ "Could not find fileset: " <> n + Just fs -> + Binding { + _bindingThis = + Info { _infoHostName = here + , _infoStore = this + , _infoContainer = findContainer fs this conts } + , _bindingThat = + Info { _infoHostName = there + , _infoStore = that + , _infoContainer = findContainer fs that conts } + , _bindingFileset = fs } + load <- getOption loadRevs + if load + then do + let l = infoContainer.containerLastRev -- this one is a mutator + m = infoContainer.containerLastRev -- this one is an accessor + thisContRev <- if isZfs (bnd^.bindingThis) + then containerRev (bnd^.bindingThis) + else return $ bnd^.bindingThis.m + thatContRev <- if isZfs (bnd^.bindingThat) + then containerRev (bnd^.bindingThat) + else return $ bnd^.bindingThat.m + return $ bindingThis.l .~ thisContRev + $ bindingThat.l .~ thatContRev $ bnd + else return bnd + + where + containerRev info = silently $ do + p <- liftIO $ zfsFilePath info + let p' = toTextIgnore $ p fromText ".zfs" fromText "snapshot" + u = info^.infoStore.storeUserName + h = info^.infoHostName + hn = format "{}@{}" [u, h] + listing <- sort <$> map (read . toString) <$> + filter (T.all isDigit) <$> T.lines <$> + if storeIsLocal here (info^.infoStore) + then vrun "ls" ["-1", p'] + else remote vrun hn ["ls", "-1", p'] + if length listing == 0 + then return Nothing + else return . Just . last $ listing + +containersForStore :: Store -> [Container] -> [Container] +containersForStore store conts = + filter (\x -> + let stName = x^.containerStore + names = if "," `T.isInfixOf` stName + then T.splitOn "," stName + else [stName] + in (store^.storeName) `elem` names) conts + +findContainer :: Fileset -> Store -> [Container] -> Container +findContainer fileset store conts = + fromMaybe + (error $ toString $ + format "Could not find container for Store {} + Fileset {}" + [ store^.storeName, fileset^.filesetName ]) $ + find (\x -> (x^.containerFileset) == (fileset^.filesetName)) + (containersForStore store conts) + +mergeContainers :: Container -> Container -> Container +x `mergeContainers` y + | (x^.containerFileset) == (y^.containerFileset) + && (x^.containerStore) == (y^.containerStore) + && (x^.containerPath) == (y^.containerPath) + && (x^.containerPoolPath) == (y^.containerPoolPath) = + containerLastRev .~ + (if isNothing (y^.containerLastRev) + then x^.containerLastRev + else if isNothing (x^.containerLastRev) + || fromJust (x^.containerLastRev) < + fromJust (y^.containerLastRev) + then y^.containerLastRev + else x^.containerLastRev) $ + containerLastSync .~ + (if isNothing (y^.containerLastSync) + then x^.containerLastSync + else if isNothing (x^.containerLastSync) + || fromJust (x^.containerLastSync) < + fromJust (y^.containerLastSync) + then y^.containerLastSync + else x^.containerLastSync) $ x + | otherwise = x + +updateContainers :: Maybe Int -> Binding -> Sh [Container] +updateContainers Nothing bnd = do + now <- liftIO currentLocalTime + let update = containerLastSync .~ Just now + return [ update (bnd^.bindingThis.infoContainer) + , update (bnd^.bindingThat.infoContainer) ] + +updateContainers rev bnd = do + now <- liftIO currentLocalTime + let update = containerLastSync .~ Just now + return [ update (bnd^.bindingThis.infoContainer) + , containerLastRev .~ rev $ + update (bnd^.bindingThat.infoContainer) ] + +findFileset :: Text -> [Fileset] -> Fileset +findFileset n fsets = + fromMaybe + (error $ toString $ "Could not find fileset matching name " <> n) $ + find (\x -> n == x^.filesetName) fsets + +findStore :: Text -> [Store] -> Store +findStore n sts = + fromMaybe + (error $ toString $ "Could not find store matching hostname " <> n) $ + find (\x -> matchText (x^.storeHostRe) n) sts + +storeIsLocal :: Text -> Store -> Bool +storeIsLocal host st = matchText (st^.storeSelfRe) host + +isZfs :: Info -> Bool +isZfs info = isJust (info^.infoStore.storeZfsPool) + && isJust (info^.infoContainer.containerPoolPath) + +bothSidesZfs :: Info -> Info -> Bool +bothSidesZfs = (&&) `on` isZfs + +data ContainerPath = NoPath + | Pathname FilePath + | ZfsFilesystem Text + | ZfsSnapshot Text Int + | ZfsSnapshotRange Text Int Int + deriving (Show, Eq) + +data FullPath = LocalPath ContainerPath + | RemotePath Text Text ContainerPath + deriving (Show, Eq) + +convertPath :: FilePath -> String +convertPath = toString + +getHomePath :: Text -> IO FilePath +getHomePath p = ( fromText p) <$> getHomeDirectory + +getPathname :: FilePath -> IO ContainerPath +getPathname fp = do + let text = toTextIgnore fp + p <- if T.head text == '~' + then toTextIgnore <$> getHomePath (T.drop 2 text) + else return text + return $ Pathname $ fromText $ if T.last p /= '/' + then T.append p "/" + else p + +sourcePath :: Binding -> IO FullPath +sourcePath bnd + | bothSidesZfs this that = + let poolPath = toTextIgnore $ zfsPoolPath this + in case (thisCont^.containerLastRev, thatCont^.containerLastRev) of + (Just thisRev, Just thatRev) -> + if thisRev > thatRev + then return $ LocalPath $ ZfsSnapshotRange poolPath thatRev thisRev + else return $ LocalPath NoPath + (Just thisRev, Nothing) -> + return $ LocalPath $ ZfsSnapshot poolPath thisRev + (Nothing, _) -> + return $ LocalPath $ ZfsFilesystem poolPath + + | isZfs this = + LocalPath <$> (Pathname <$> zfsFilePath this) + + | otherwise = + LocalPath <$> getPathname (bnd^.bindingThis.infoContainer.containerPath) + + where this = bnd^.bindingThis + that = bnd^.bindingThat + thisCont = this^.infoContainer + thatCont = that^.infoContainer + +destinationPath :: Binding -> IO FullPath +destinationPath bnd + | storeIsLocal (this^.infoHostName) (that^.infoStore) = + LocalPath <$> getZfsPath that (bothSidesZfs this that) + + | otherwise = do + fullpath <- getZfsPath that (bothSidesZfs this that) + return $ + RemotePath (that^.infoStore.storeUserName) + (that^.infoHostName) fullpath + + where this = bnd^.bindingThis + that = bnd^.bindingThat + +syncContainers :: Binding -> Sh [Container] +syncContainers bnd = errExit False $ do + verb <- getOption verbose + + noticeL $ format "Sending {}/{} → {}" + [ bnd^.bindingThis.infoStore.storeName + , bnd^.bindingFileset.filesetName + , bnd^.bindingThat.infoStore.storeName ] + + (sendCmd, recvCmd, updater) <- createSyncCommands bnd + + sendArgs <- sendCmd + unless (null sendArgs) $ do + noticeL $ T.intercalate " " sendArgs + recvArgs <- recvCmd + if null recvArgs + then vrun_ (fromText (head sendArgs)) (tail sendArgs) + else escaping False $ + vrun_ (fromText (head sendArgs)) $ + tail sendArgs <> ["|"] <> (if verb + then ["pv", "|"] + else []) + <> recvArgs + updater + +createSyncCommands :: Binding -> Sh (Sh [Text], Sh [Text], Sh [Container]) +createSyncCommands bnd = do + src <- liftIO $ sourcePath bnd + dst <- liftIO $ destinationPath bnd + + let thisCont = bnd^.bindingThis.infoContainer + thatCont = bnd^.bindingThat.infoContainer + recurseThis = thisCont^.containerRecurse + recurseThat = thatCont^.containerRecurse + + case (src, dst) of + (LocalPath NoPath, _) -> + return ( infoL "No sync needed" >> return [] + , return [] + , return [] ) + + (LocalPath (Pathname l), LocalPath (Pathname r)) -> + return ( systemVolCopy (bnd^.bindingFileset.filesetName) l + (toTextIgnore r) + , return [] + , updateContainers Nothing bnd ) + + (LocalPath (Pathname l), RemotePath u h (Pathname r)) -> + return ( systemVolCopy (bnd^.bindingFileset.filesetName) l $ + format "{}@{}:{}" + [u, h, escape (toTextIgnore r)] + , return [] + , updateContainers Nothing bnd ) + + (LocalPath (ZfsFilesystem l), + LocalPath (ZfsFilesystem r)) -> + return ( localSend l recurseThis + , localReceive r recurseThat + , updateContainers (thisCont^.containerLastRev) bnd ) + + (LocalPath (ZfsFilesystem l), + RemotePath u h (ZfsFilesystem r)) -> + return ( localSend l recurseThis + , remoteReceive u h r recurseThat + , updateContainers (thisCont^.containerLastRev) bnd ) + + (LocalPath (ZfsSnapshot l e), + LocalPath (ZfsFilesystem r)) -> + return ( localSendRev l recurseThis e + , localReceive r recurseThat + , updateContainers (Just e) bnd ) + + (LocalPath (ZfsSnapshot l e), + RemotePath u h (ZfsFilesystem r)) -> + return ( localSendRev l recurseThis e + , remoteReceive u h r recurseThat + , updateContainers (Just e) bnd ) + + (LocalPath (ZfsSnapshotRange l b e), + LocalPath (ZfsFilesystem r)) -> + return ( localSendTwoRevs l recurseThis b e + , localReceive r recurseThat + , updateContainers (Just e) bnd ) + + (LocalPath (ZfsSnapshotRange l b e), + RemotePath u h (ZfsFilesystem r)) -> + return ( localSendTwoRevs l recurseThis b e + , remoteReceive u h r recurseThat + , updateContainers (Just e) bnd ) + + (l, r) -> error $ toString $ + format "Unexpected paths {} and {}" + [ T.pack (show l), T.pack (show r) ] + + where + escape x = if "\"" `T.isInfixOf` x || " " `T.isInfixOf` x + then "'" <> T.replace "\"" "\\\"" x <> "'" + else x + + localSend pool recurse = + return $ ["sudo", "zfs", "send"] + <> ["-R" | recurse] + <> [pool] + + localSendRev pool recurse r1 = do + verb <- getOption verbose + return $ ["sudo", "zfs", "send"] + <> ["-R" | recurse] + <> ["-v" | verb] + <> [ pool <> "@" <> intToText r1 ] + + localSendTwoRevs pool recurse r1 r2 = do + verb <- getOption verbose + return $ ["sudo", "zfs", "send"] + <> ["-R" | recurse] + <> ["-v" | verb] + <> [ "-I" + , pool <> "@" <> intToText r1 + , pool <> "@" <> intToText r2 ] + + localReceive pool recurse = + return $ ["sudo", "zfs", "recv"] + <> ["-d" | recurse] + <> ["-F", pool] + + remoteReceive u h pool recurse = + remote (\x xs -> return (toTextIgnore x:xs)) (format "{}@{}" [u, h]) $ + ["zfs", "recv"] <> ["-d" | recurse] <> ["-F", pool ] + +systemVolCopy :: Text -> FilePath -> Text -> Sh [Text] +systemVolCopy label src dest = do + optsFile <- liftIO $ getHomePath (".pushme/filters/" <> label) + exists <- liftIO $ isFile optsFile + let rsyncOptions = ["--include-from=" <> toTextIgnore optsFile | exists] + volcopy label True rsyncOptions (toTextIgnore src) dest + +volcopy :: Text -> Bool -> [Text] -> Text -> Text -> Sh [Text] +volcopy label useSudo options src dest = do + infoL $ format "{} → {}" [src, dest] + + dry <- getOption dryRun + noSy <- getOption noSync + deb <- getOption debug + verb <- getOption verbose + + let shhh = not deb && not verb + toRemote = ":" `T.isInfixOf` dest + options' = + [ "-aHXEy" -- jww (2012-09-23): maybe -A too? + , "--fileflags" + , "--delete-after" + , "--ignore-errors" + , "--force-delete" + + , "--exclude=/.Caches/" + , "--exclude=/.Spotlight-V100/" + , "--exclude=/.TemporaryItems/" + , "--exclude=/.Trash/" + , "--exclude=/.Trashes/" + , "--exclude=/.fseventsd/" + , "--exclude=/.zfs/" + , "--exclude=/Temporary Items/" + , "--exclude=/Network Trash Folder/" + + , "--filter=-p .DS_Store" + , "--filter=-p .localized" + , "--filter=-p .AppleDouble/" + , "--filter=-p .AppleDB/" + , "--filter=-p .AppleDesktop/" + , "--filter=-p .com.apple.timemachine.supported" ] + + <> ["-n" | dry] + <> (if shhh + then ["--stats"] + else if verb + then ["-P"] + else if deb + then ["-v", "-v"] + else ["-v"]) + <> options + <> [src, dest] + + rsync <- which "rsync" + case rsync of + Nothing -> error "Could not find rsync!" + Just r -> + if shhh && not noSy + then silently $ do + output <- doCopy (drun False) r toRemote useSudo options' + let stats = M.fromList $ + map (liftM2 (,) head (head . T.words . last) + . T.splitOn ": ") + . filter (": " `T.isInfixOf`) + . T.lines $ output + files = field "Number of files" stats + sent = field "Number of files transferred" stats + total = field "Total file size" stats + xfer = field "Total transferred file size" stats + noticeL $ format "{}: Sent {} in {} files (out of {} in {})" + [ label + , fromString (humanReadable xfer), + commaSep (fromIntegral sent) + , fromString (humanReadable total), + commaSep (fromIntegral files) ] + else + doCopy (drun_ False) r toRemote useSudo options' + + return [] + + where + commaSep :: Int -> Text + commaSep = fst . T.foldr (\x (xs, num :: Int) -> + if num /= 0 && num `mod` 3 == 0 + then (x `T.cons` ',' `T.cons` xs, num + 1) + else (x `T.cons` xs, num + 1)) + ("", 0) + . intToText + field x stats = read (toString (stats M.! x)) :: Integer + + doCopy f rsync False False os = f rsync os + doCopy f rsync False True os = sudo f rsync os + doCopy f rsync True False os = f rsync (remoteRsync rsync:os) + doCopy f rsync True True os = asRoot f rsync (remoteRsync rsync:os) + + remoteRsync x = format "--rsync-path=sudo {}" [toTextIgnore x] + +readDataFile :: FromJSON a => Text -> IO [a] +readDataFile p = do + p' <- getHomePath p + d <- Data.Yaml.decode <$> BC.readFile (convertPath p') + case d of + Nothing -> error $ toString $ "Failed to read file " <> p + Just d' -> return d' + +writeDataFile :: ToJSON a => Text -> a -> IO () +writeDataFile p xs = + getHomePath p >>= flip BC.writeFile (Data.Yaml.encode xs) . convertPath + +currentLocalTime :: IO LocalTime +currentLocalTime = do + tz <- getCurrentTimeZone + tm <- getCurrentTime + return $ utcToLocalTime tz tm + +getOption' :: Data a => (a -> b) -> IO b +getOption' option = do + opts <- getValue "main" "opts" + return $ fromJust $ option <$> opts + +getOption :: Data a => (a -> b) -> Sh b +getOption = liftIO . getOption' + +matchText :: Text -> Text -> Bool +matchText = flip ((=~) `on` toString) + +intToText :: Int -> Text +intToText = fromString . show + +remote :: (FilePath -> [Text] -> Sh a) -> Text -> [Text] -> Sh a +remote f host xs = do + sshCmd <- getOption ssh + p <- if null sshCmd + then which "ssh" + else return . Just . fromText . T.pack $ sshCmd + case p of + Nothing -> error "Could not find ssh!" + Just r -> f r (host:xs) + +asRoot :: (FilePath -> [Text] -> Sh a) -> FilePath -> [Text] -> Sh a +asRoot f p xs = + f "sudo" [ "su", "-", "root", "-c" + , T.unwords (map (\x -> "\"" <> x <> "\"") xs') ] + where xs' = toTextIgnore p:xs + +sudo :: (FilePath -> [Text] -> Sh a) -> FilePath -> [Text] -> Sh a +sudo f p xs = f "sudo" (toTextIgnore p:xs) + +doRun :: (FilePath -> [Text] -> Sh a) + -> (Text -> Sh ()) + -> Sh a -> Bool -> Bool -> FilePath -> [Text] + -> Sh a +doRun f g retval doLog heedDry n xs = do + when doLog $ + g $ format "{} {}" [toTextIgnore n, T.unwords xs] + + dry <- getOption dryRun + drier <- getOption noSync + if drier || (dry && heedDry) + then retval + else f n xs + +drun :: Bool -> FilePath -> [Text] -> Sh Text +drun = doRun run debugL (return "") True + +drun_ :: Bool -> FilePath -> [Text] -> Sh () +drun_ x = void .: doRun run_ debugL (return ()) True x + +vrun :: FilePath -> [Text] -> Sh Text +vrun = doRun run infoL (return "") True True + +vrun_ :: FilePath -> [Text] -> Sh () +vrun_ = void .: doRun run_ infoL (return ()) True True + +srun :: FilePath -> [Text] -> Sh Text +srun = doRun run infoL (return "") False True + +srun_ :: FilePath -> [Text] -> Sh () +srun_ = void .: doRun run_ infoL (return ()) False True + +debugL :: Text -> Sh () +debugL = liftIO . debugM "pushme" . toString + +infoL :: Text -> Sh () +infoL = liftIO . infoM "pushme" . toString + +noticeL :: Text -> Sh () +noticeL = liftIO . noticeM "pushme" . toString + +warningL :: Text -> Sh () +warningL = liftIO . warningM "pushme" . toString + +errorL :: Text -> Sh () +errorL = liftIO . errorM "pushme" . toString + +criticalL :: Text -> Sh () +criticalL = liftIO . criticalM "pushme" . toString + +humanReadable :: Integer -> String +humanReadable x + | x < 1024 = printf "%db" x + | x < (1024^(2 :: Integer)) = + printf "%.0fK" (fromIntegral x / (1024 :: Double)) + | x < (1024^(3 :: Integer)) = + printf "%.1fM" (fromIntegral x / (1024^(2 :: Integer) :: Double)) + | x < (1024^(4 :: Integer)) = + printf "%.2fG" (fromIntegral x / (1024^(3 :: Integer) :: Double)) + | x < (1024^(5 :: Integer)) = + printf "%.3fT" (fromIntegral x / (1024^(4 :: Integer) :: Double)) + | x < (1024^(6 :: Integer)) = + printf "%.3fP" (fromIntegral x / (1024^(5 :: Integer) :: Double)) + | x < (1024^(7 :: Integer)) = + printf "%.3fX" (fromIntegral x / (1024^(6 :: Integer) :: Double)) + | otherwise = printf "%db" x + +-- Main.hs (pushme) ends here diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +This is the script I use for synchronizing data between my machines (and also +to directories on the same machine, externally connected drives, and to and +between ZFS filesystems). + +Here is an example set of files for synchronizing my home directory and +`/usr/local` via rsync between two machines: `foo` and `bar`. First, +`~/.pushme/stores.yml`: + + - 'Targets': + - - 'bar' + - - 'home' + - 'local' + 'HostRe': '[Ff]oo' + 'Name': 'Foo' + 'UserName': 'johnw' + 'SelfRe': '[Ff]oo' + 'ZfsPool': null + 'ZfsPath': null + - 'Targets': + - - 'foo' + - - 'home' + - 'local' + 'HostRe': '[Bb]ar' + 'Name': 'Bar' + 'UserName': 'johnw' + 'SelfRe': '[Bb]ar' + 'ZfsPool': null + 'ZfsPath': null + +Then, `~/.pushme/filesets.yml`: + + - 'Priority': 60 + 'Name': 'home' + 'Class': 'quick,main' + 'ReportMissing': true + - 'Priority': 80 + 'Name': 'local' + 'Class': 'system,main' + 'ReportMissing': false + +And finally, `~/.pushme/containers.yml`: + + - 'Store': 'foo,bar' + 'Recurse': false + 'Fileset': 'home' + 'PoolPath': null + 'LastRev': null + 'LastSync': null + 'Path': '~/' + - 'Store': 'foo,bar' + 'Recurse': false + 'Fileset': 'local' + 'PoolPath': null + 'LastRev': null + 'LastSync': null + 'Path': '/usr/local/' + +Now I can run the following command: + + foo $ pushme bar + 15:18:44 - [NOTICE] Synchronizing Foo -> Bar + 15:18:44 - [NOTICE] Sending Foo/home → Bar + 15:18:52 - [NOTICE] Sent 151.0M in 131 files (out of 1.37G in 12,418) + 15:20:26 - [NOTICE] Sending Foo/local → Bar + 15:21:02 - [NOTICE] Sent 0b in 0 files (out of 6.45G in 207,453) + +If you are wondering about the complexity of keeping filesets separate from +containers, it's because I use pushme for several different scenarios: +rsync'ing between machines, rsync'ing into ZFS filesystems, and sending ZFS +filesystems as snapshot stream between servers. Pushme is able to handle all +of these scenarios, but doing so required a bit more abstraction than a simple +rsync-only tool would have needed. + +Some common options include: + + $ pushme -c quick bar # only sync filesets with the "quick" class + $ pushme -f home bar # only sync the "home" fileset + $ pushme -n bar # don't do anything, just scan + $ pushme -N bar # don't even scan + $ pushme -v bar # show commands being executed + $ pushme -D bar # show more info than you want to see diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs diff --git a/pushme.cabal b/pushme.cabal new file mode 100644 --- /dev/null +++ b/pushme.cabal @@ -0,0 +1,50 @@ +Name: pushme + +Version: 0.2.0 +Synopsis: Script I use for synchronizing my data among machines + +Description: Script I use for synchronizing my data among machines. + +Homepage: https://github.com/jwiegley/pushme +License: BSD3 +License-file: LICENSE +Author: John Wiegley +Maintainer: John Wiegley +Category: Development +Build-type: Simple +Cabal-version: >= 1.8 + +Extra-Source-Files: README.md + +Executable pushme + Main-is: Main.hs + Ghc-options: -threaded + + Build-depends: base >= 4 && < 5 + , aeson >= 0.6.0 + , cabal-file-th >= 0.2.3 + , bytestring >= 0.9.2 + , cmdargs >= 0.10 + , containers >= 0.4.2 + , deepseq >= 1.3 + , hslogger >= 1.2 + , io-storage >= 0.3 + , lens >= 2.8 + , old-locale >= 1.0.0 + , parallel-io >= 0.3.2 + , pointless-fun >= 1.1 + , regex-posix >= 0.95 + , shelly >= 0.14.0.1 + , stringable >= 0.1 + , system-fileio >= 0.3.9 + , system-filepath >= 0.4.7 + , text >= 0.11.2 + , text-format >= 0.3 + , time >= 1.4 + , unix >= 2.5.1 + , unordered-containers >= 0.2.2 + , yaml >= 0.8 + +Source-repository head + type: git + location: https://github.com/jwiegley/pushme