diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,26 @@ +Copyright (c) 2008, David Fox, Jeremy Shaw +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. The names of its contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE 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 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/System/Archive/AptMethods.hs b/System/Archive/AptMethods.hs new file mode 100644 --- /dev/null +++ b/System/Archive/AptMethods.hs @@ -0,0 +1,207 @@ +module System.Archive.AptMethods + (updateViaAptMethods + ) + where + +import Control.Monad +import Data.Function +import Data.List +import Data.Maybe +import Debian.Apt.Methods +import Debian.Apt.Index hiding (update) +import Debian.Control.ByteString +import Debian.Mirror +import System.FilePath +import System.Directory +import System.Exit +import System.Posix.Files +import System.Unix.FilePath (dirName) +import Network.URI + +test = + fetchOrLink [] (fromJust $ parseURI "http://archive.ubuntu.com/ubuntu/dists/gutsy/Release") "/tmp/curr" (Just "/tmp/prev") + + +myCallbacks :: FetchCallbacks +myCallbacks = + cliFetchCallbacks { uriDoneCB = + \uri size lastModified resumePoint filename hashes imsHit -> + putStrLn $ uriToString' uri ++ " downloaded" ++ maybe "." (" to " ++) filename + } + +uriDoneCBLink existingFP = \uri size lastModified resumePoint filename hashes imsHit -> + if imsHit + then do createLink existingFP (fromJust filename) + putStrLn $ uriToString' uri ++ " hardlinked." + else putStrLn $ uriToString' uri ++ " downloaded" ++ maybe "." (" to " ++) filename + +uriToString' uri = uriToString id uri "" +-- |if the target files already exists, we will always break any +-- hardlinks before attempting to fetch. So, even if the file is not +-- updated. +fetchOrLink :: [ConfigItem] -> URI -> FilePath -> Maybe FilePath -> IO Bool +fetchOrLink configItems remotePath localPath mExistingFP = + do flip when (breakLink localPath) =<< fileExist localPath + case mExistingFP of + Nothing -> + fetch myCallbacks configItems remotePath localPath =<< getLastModified localPath + (Just existingFP) -> + fetch (myCallbacks { uriDoneCB = uriDoneCBLink existingFP }) configItems remotePath localPath =<< getLastModified existingFP + +-- * To Be Moved + +-- break a hardlink +breakLink :: FilePath -> IO () +breakLink fp = + do status <- getSymbolicLinkStatus fp + when (linkCount status > 1) (copyFile fp fp) + +{- + +The apt methods do not break hard-links. Therefore we need to +explicitly break the hard-links for it. + +We can divide the stuff we need to download into two categories: + - files we only have a timestamp for (Release files, etc) + - stuff we have md5sums for + +If we have the md5sum some, then we can check the files on the disk +already, and link the ones we have. The ones we do not have, we can +download via the methods. + +Since we do not have a good way to automatically enumerate the dists, +the list of dists to mirror will have to be an explicit list. + +Steps: +----- + +1. Download/hardlink the Release files for each dist +2. Parse Release files and generate list of all required files +3. Attempt to hardlink to local files +4. Attempt to download remaining files +5. Rename download directory if everything successfully retrieved + +How to recover from aborted download: + +1. The bulk of the data is the debs, not the release files 2. If we +have the ability to find old copies in more than one location, then we +can just add the previous .in-progress directory to the list of places +to look for .debs. However, we also need to validate the size/md5sum +of files in the .in-progress directory, since it is likely one of them +was only download halfway. However, our hardlink algorithm will +probably already have the option to check size and md5sum. + +What should we do if a Release File is missing? How about throw an +exception? + +-} + +updateViaAptMethods :: [FilePath] -- ^ path to previous snapshot directories + -> URI -- ^ base path to remote repository + -> FilePath -- ^ base path to local directory + -> [(String, [String])] -- ^ list of (dist, arches) to download + -> IO (ExitCode) +updateViaAptMethods prevBasePaths remoteURI basePath dists = + do -- fetch the relevant files from the 'dists' directory + mapM_ fetchControlFiles dists + -- the local dists directory now contains all the control files + -- parse them and find out what pool files we need + poolFiles <- liftM concat $ mapM (createPoolFileList basePath) dists + missing <- liftM catMaybes $ mapM (fetchPoolFile prevBasePaths basePath) poolFiles + if null missing + then return (ExitSuccess) + else return (ExitFailure 1) + where + prevBasePath = listToMaybe prevBasePaths + fetchControlFiles (dist, arches) = + do let distPath = "dists" dist + releaseFP = distPath "Release" + ensureParentDirectoryExists (basePath releaseFP) + fetchOrLink [] (remoteURI { uriPath = (uriPath remoteURI) releaseFP }) (basePath releaseFP) (fmap ( releaseFP) prevBasePath) + release <- mustParseControlFromFile (basePath releaseFP) + let indexFiles = indexesInRelease (archFilter arches) release + fetch = (\fp -> ensureParentDirectoryExists (basePath distPath fp) >> + (fetchOrLink [] (remoteURI { uriPath = (uriPath remoteURI) distPath fp }) + (basePath distPath fp) + (fmap ( (distPath fp)) prevBasePath))) + -- download index files found in Release + mapM_ (\ (_,_,fp) -> fetch fp) indexFiles + -- download other files not found in Release + mapM_ fetch (["Release.gpg"] ++ map (\arch -> "Contents-" ++ arch ++ ".gz") arches) + fetchPoolFile :: [FilePath] -> FilePath -> FileTuple -> IO (Maybe FileTuple) + fetchPoolFile prevBasePaths basePath ft@(checksum, size, filename) = + do doneAlready <- fileExist (basePath filename) -- TODO: check size/md5sum + if doneAlready + then do putStrLn $ filename ++ " already exists in pool." + return Nothing + else do + ensureParentDirectoryExists (basePath filename) -- silly, but this gets us a log message, so.. + res <- fetchOrLink [] (remoteURI { uriPath = (uriPath remoteURI) filename }) (basePath filename) (fmap ( filename) prevBasePath) + if res + then return Nothing + else return (Just ft) + where + prevBasePath = listToMaybe prevBasePaths + filename (_,_,fp) = fp + ensureParentDirectoryExists filepath = + do let dir = dirName filepath + putStrLn $ "Ensuring " ++ dir ++ " exists." + createDirectoryIfMissing True dir + mustParseControlFromFile fp = + do r <- parseControlFromFile fp + case r of + (Left e) -> error (show e) + (Right c) -> return c + createPoolFileList basePath (dist, arches) = + do let distDir = (basePath "dists" dist) + release <- mustParseControlFromFile (distDir "Release") + let indexFiles = indexesInRelease (archFilter arches) release + binaryIndexes <- findIndexes distDir "Packages" indexFiles + binaryFiles <- liftM concat $ mapM (makePackageFileListIO distDir) binaryIndexes + sourceIndexes <- findIndexes distDir "Sources" indexFiles + sourceFiles <- liftM concat $ mapM (makeSourceFileListIO distDir) sourceIndexes + return (nubOn filename (binaryFiles ++ sourceFiles)) + nubOn :: (Ord b) => (a -> b) -> [a] -> [a] + nubOn selector list = map head $ groupBy ((==) `on` selector) $ sortBy (compare `on` selector) list +{- + let releaseFPs = map ((\dist -> "dists" dist "Release") . fst) dists -- hrm, we need to do this on a dist by dist basis + prevBasePath = listToMaybe prevBasePaths + in do -- create dist directories + mapM_ ((\dir -> putStrLn ("Ensuring " ++ dir ++ " exists.") >> createDirectoryIfMissing True dir) . (basePath ) . dirName) releaseFPs + -- fetch Release files + mapM_ (\fp -> fetchOrLink [] (remoteURI { uriPath = (uriPath remoteURI) fp }) (basePath fp) (fmap ( fp) prevBasePath) >>= + (flip unless) (error $ "Failed to fetch: " ++ fp)) releaseFPs + -- read the release files and get a list of the other indexes + releases <- mapM mustParseControlFromFile (map (basePath ) releaseFPs) + let indexFiles = concatMap (indexesInRelease (const True)) releases + -- add checks for size/checksums + mapM_ (\fp -> fetchOrLink [] (remoteURI { uriPath = (uriPath remoteURI) "dists" fp }) (basePath "dists" fp) (fmap ( ("dists" fp)) prevBasePath)) (map (\ (_,_,fp) -> fp) indexFiles) + -- (distFiles, _) <- liftM (\l -> (concatMap fst l, concatMap snd l)) $ mapM (\ (dist, arches) -> makeDistFileList (archFilter arches) basePath dist) dists + -- return () + -- get all the indexes + -- mapM_ ( + -- mapM_ print distFiles + -- mapM_ print (poolFiles) + -- print (length distFiles) + where + mustParseControlFromFile fp = + do r <- parseControlFromFile fp + case r of + (Left e) -> error (show e) + (Right c) -> return c + + +-} + + + +-- | apply monadic filter to list until failure is encountered +-- return True if no failures +-- return False if failed +allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool +allM f [] = return True +allM f (h:t) = + do b <- f h + case b of + False -> return False + True -> allM f t diff --git a/System/Archive/Archive.hs b/System/Archive/Archive.hs new file mode 100644 --- /dev/null +++ b/System/Archive/Archive.hs @@ -0,0 +1,350 @@ +module System.Archive.Archive + ( Option(..) + , UpdateResult(..) + , Config(..) + , archive + , configLaws + , genericConfig + ) where + +import Control.Concurrent +import Control.Monad +import Data.ByteString.Lazy.Char8 (empty) +import Data.List +import Data.Maybe +import Data.Time +import Data.Time.Clock.POSIX +import Network.URI +import System.Unix.Files +import System.Archive.AptMethods +import System.Directory +import System.FilePath +import System.IO +import System.IO.Error +import System.Locale +import System.Posix.Files +import System.Process +import System.Exit +import System.Unix.FilePath (realpath) +import System.Unix.Progress.Outputs (collectOutputUnpacked) +import System.Unix.Progress.QIO (lazyProcessV) +import Test.HUnit.Base +import Text.Regex (mkRegex, matchRegex) +import Text.Regex.Posix ((=~)) + + + +{- + +To rsync we need: + + 1. the latest 'complete' version + 2. the latest incomplete ? + +If an incomplete archive exists we can 'ignore' it. One of two things will happen: + + 1. it will be an incomplete archive from another day, and it will just sit there being ignored + 2. it will be an incomplete archive from today -- in which case we will resume the aborted transfer + +If we resume the aborted transfer, then we might also want to add +--delete to remove things that have disappeared from the original in +the meantime. + +If the incomplete is older than the most recent up to date, then it is +useless. If it is newer, then we could resume it. We can also make the +resume optional. If we make resume optional then we could end up with +several failed downloads. Also, their might be a conflict with the +date. Unless, we delete failed downloads that are not resumed. + +So the option for resume should be, if failed downloads are found, +(resume|delete). Ignore is a problem if it is the same date, unless we +move it out of the way. Perhaps the currently active one should be +.inprogress, and renamed to incomplete if failure occurs and we do not +resume. + +of course, we could then get the date.incomplete and date.inprogress, +where date is the same, and then the rename would fail, unless detects +that case. + +There are three types of directories: + +- current +- inprogress +- incomplete + +-- * Requirements + +We wish to make a bunch of snapshot directories from a +source. snapshots should be hardlinked together to save disk space. + +It should be possibly to distinguish between a directory that is +complete vs incomplete. There could also be unreleated directories. It +would be nice to be able to distinguish snapshot from non-snapshot +directories. + +The naming of the directories should be configurable. + +It should be possible to recover from an aborted download. + +A directory only has two states: + + + incomplete + + complete + +Should be possible to update the latest snapshot instead of creating a +new snapshot. + +It would be nice to avoid using the --delete flag on rsync. However, +that means we have to delete incomplete downloads some other way +anyway. So, it might be better to use the --delete flag, and instead +have the rule that there should only be one inprogress directory at a +time. If the inprogress directory is not timestamped, that makes it +easier to rename it at the end, etc. However, the timestamp will then +the completion time, not the start time of the download. Unless we +just save the time stamp in the code. + +The only useful thing you can do with an incomplete download is to +resume it. The primary advantage to not recovering it is you do not +need to use the --delete flag. However, if you do not resume it, then +you want to delete it anyway -- so it really just comes down what form +of deletion do you feel is safest. + +Storing information in the file name means parsing of filenames, which +seems error prone. But, perhaps that is unavoidable. + + +-- * How + + using rync with --link-dest to create hardlinks to previous versions. + +-} + +data Report = Found (Maybe FilePath) [FilePath] [FilePath] + deriving (Show, Read, Eq) + +newtype Date = Date String deriving (Show, Read, Ord, Eq) + +-- |These represent the command line options to this program. +data Option + = {- DryRun -- ^Print the commands to execute, done run them + | Unlink -- ^Unimplemented + | Current -- ^Unimplemented + | Prune String -- ^Unimplemented + | -} Rsync String -- ^Pass one or more additional arguments to the rsync sub-process + | NoUpdateSymlink + deriving (Eq, Show) + +-- |Did the update result in any changes +data UpdateResult + = NoChanges -- ^ rsync did not detect any changes + | Changes -- ^ rsync found some changes + deriving (Show, Read, Eq) + +-- |configuration for directory naming +-- +-- You can configure the +-- see also: 'configLaws' +data Config + = Config { mkName :: ZonedTime -> FilePath -- ^ generate a filepath for the completed snapshot directory + , date :: FilePath -> Date -- ^ return the date portion of a filepath + , isComplete :: FilePath -> Bool -- ^ predicate which tests if a filepath represents a completed snapshot + , mkInProgress :: ZonedTime -> FilePath -- ^ generate a filepath for the snapshot directory to be called while the download is in progress + , isInProgress :: FilePath -> Bool -- ^ predicate which tests if a file represents an inprogress snapshot + , linkName :: FilePath -- ^ name of symlink that points to current snapshot + } + +-- * Example Configuration + + +-- |create a config using the supplied basename and time format +-- see also: 'configLaws' +genericConfig :: FilePath -> String -> Config +genericConfig baseDirName formatString = + Config { mkName = mkName' + , date = Date . reverse . takeWhile (/= '.') . reverse + , isComplete = \fp -> not $ any (flip isPrefixOf fp) ["outofdate.", "inprogress.", "incomplete."] + , mkInProgress = \zonedtime -> "inprogress." ++ mkName' zonedtime + , isInProgress = isPrefixOf "inprogress." + , linkName = baseDirName + } + where + mkName' zonedtime = + baseDirName ++ "-" ++ formatTime defaultTimeLocale formatString zonedtime + +-- |You can (and should) test that all the laws hold for your config +-- by using the 'configLaws' function. For example, +-- +-- > Test.HUnit.Text.runTestTT (configLaws (genericConfig "snapshot" "%Y-%m-%d")) +-- +-- The user supplied configuration +-- must uphold the following laws: +-- +-- 1. completed directories should be listed chronological when sorted +-- lexigraphically +-- +-- > forall date0 date1. (date0 < date1) => (mkName date0) < (mkName date1) +-- +-- 2. the date function should return the same date if 'mkName' and +-- 'mkInProgress' are applied to the same date. +-- +-- > date . mkName == date . mkInProgress +-- +-- 3. 'mkName' should generate a filepath which tests as 'True' by 'isComplete'. +-- +-- > isComplete . mkName = const True +-- +-- 4. 'mkInProgress' should generate a filepath which tests as 'True' by 'isInProgress' +-- +-- > isInProgres . mkInProgress = const True +-- +-- 5. The filepaths generated by 'mkName' and 'mkInProgress' should +-- generate names which can be differentiated by 'isComplete' and +-- 'isInProgress'. +-- +-- > (\fp -> (isInProgress fp) == True => (isComplete fp) == False) && +-- > (\fp -> (isCompletefp fp) == True => (isInProgress fp) == False)) +-- +-- TODO: linkName must be a valid filename (ie. not null) +configLaws :: Config -> Test +configLaws config = + let zt0 = utcToZonedTime utc (posixSecondsToUTCTime (realToFrac (0 :: Integer))) + zt1 = utcToZonedTime utc (posixSecondsToUTCTime (realToFrac (100000000 :: Integer))) + zt0s = formatTime defaultTimeLocale rfc822DateFormat zt0 + zt1s = formatTime defaultTimeLocale rfc822DateFormat zt1 + in + test [ assertBool ("mkName '" ++ zt0s ++ "' < mkName '" ++ zt1s ++"'") ((mkName config zt0) < (mkName config zt1)) + -- , assertBool ("date (mkName '" ++ zt0s ++"') == date (mkInProgress '" ++ zt0s ++"')") ((date config (mkName config zt0)) == (date config (mkInProgress config zt0))) + , assertBool ("date . mkName == date . mkInProgress") ((date config (mkName config zt0)) == (date config (mkInProgress config zt0))) + , assertBool ("isComplete . mkName == const True") (isComplete config (mkName config zt0) == True) + , assertBool ("isInProgress . mkInProgress == const True") (isInProgress config (mkInProgress config zt0) == True) + , assertBool ("(isInProgress == True) => (isComplete == False) && (isComplete == True) => (isInProgress False)") + (let ip = (mkInProgress config zt0) + cp = mkName config zt0 + in + (not (isComplete config ip) && not (isInProgress config cp))) + ] + +archive :: Config -> [Option] -> FilePath -> FilePath -> [(String, [String])] -> IO (Maybe UpdateResult) +archive config options src backupdir dists = + do dirs <- getSnapshotDirectories (const True) backupdir + let report = latest config dirs + update config options src backupdir report dists + +update :: Config -> [Option] -> FilePath -> FilePath -> Report -> [(String, [String])] -> IO (Maybe UpdateResult) +update config options src snapshotDir (Found mPrev inprogress _obsolete) dists = + do ct <- getZonedTime + if mPrev == (Just (mkName config ct)) + then error "update in place" -- updateInPlace (mkName ct) + else do let inProgressFP = snapshotDir (mkInProgress config ct) + completedFP = snapshotDir (mkName config ct) + (ec, mChanges) <- doUpdate options (map (snapshotDir ) inprogress) (map (snapshotDir ) (maybeToList mPrev)) src inProgressFP dists + case ec of + (ExitFailure n) -> + do hPutStrLn stderr ("sub-process failed with exit code " ++ show n) + exitWith (ExitFailure n) + ExitSuccess -> + do renameDirectory inProgressFP completedFP `catch` + (\e -> error $ "update: failed to rename: " ++ inProgressFP ++ " to " ++ completedFP ++ "\n" ++ show e) + unless (NoUpdateSymlink `elem` options) (forceSymbolicLink completedFP (snapshotDir "current")) + let linkPath = snapshotDir (linkName config) + linkExists <- fileExist linkPath + unless linkExists $ forceSymbolicLink (snapshotDir "current") linkPath + return mChanges + where + doUpdate options partial prevBasePaths src basePath dists = + do let remoteURI = maybe (error $ "Not a valid uri: " ++ src) id (parseRsync src) + case uriScheme remoteURI of + "rsync:" -> rsync options (partial ++ prevBasePaths) src basePath + "ssh:" -> rsync options (partial ++ prevBasePaths) src basePath + _ -> do ec <- updateViaAptMethods prevBasePaths remoteURI basePath dists + return (ec, Nothing) + +-- In addition to valid URIs, rsync also accepts user@host:. +parseRsync :: FilePath -> Maybe URI +parseRsync src = + maybe parseSSH Just (parseURI src) + where + parseSSH = + case matchRegex (mkRegex "^([^@]+)@([^:]+):(.*)$") src of + Just [user, host, path] -> + case parseRelativeReference path of + Just uri -> + Just (uri { uriScheme = "ssh:" + , uriAuthority = Just (URIAuth { uriUserInfo = user ++ "@" + , uriRegName = host + , uriPort = "" })}) + _ -> Nothing + _ -> Nothing + +rsync :: [Option] -> [FilePath] -> FilePath -> FilePath -> IO (ExitCode, Maybe UpdateResult) +rsync options linkDests src dest = + do createDirectoryIfMissing True dest + absLinkDests <- mapM realpath linkDests + let cmd = "rsync" + args = + ((map ("--link-dest=" ++) absLinkDests) ++ + (mapMaybe rsyncOption (dropTwoVs options)) ++ + ["-a" -- implies: lptgoD + , "-HxS" + , "--partial" + , "--delete" -- the deletes are really only needed for update-in-place + , "--delete-excluded" + , "--stats" + , src + , dest + ] + ) + hPutStrLn stderr ("> " ++ unwords (cmd : args)) + hPutStrLn stderr (" Updating from " ++ src ++ " ...") + (out, _, ec) <- lazyProcessV cmd args Nothing Nothing empty >>= return . collectOutputUnpacked + case (out =~ "Total transferred file size: ([0-9]*) bytes") :: (String, String, String, [String]) of + (_,_,_,[s]) -> return (ec, Just (if s == "0" then NoChanges else Changes )) + _ -> return (ec, Nothing) + + where + rsyncOption (Rsync x) = Just x + rsyncOption _ = Nothing + -- The first two -v arguments cause lazyProcessV to reveal more + -- of the full output of rsync, additional -v arguments are + -- passed on to rsync. + dropTwoVs options = let (vs, others) = partition (== (Rsync "-v")) options in drop 2 vs ++ others + +-- return the latest *complete* archive, latest *inprogress* archives which are +-- newer than the latest *complete*, and a list of any other +-- *inprogress* + +latest :: Config + -> [FilePath] -- ^ archive directory contents + -> Report +latest config contents = + case categorize (isComplete config) (isInProgress config) contents of + ((complete:_), [], _) -> Found (Just complete) [] [] + ([], inprogress, _) -> Found Nothing inprogress [] + ((complete: _), inprogress, _) -> + let (newer, older) = partition (\ip -> (date config) complete <= (date config) ip) inprogress + in + Found (Just complete) newer older + +getSnapshotDirectories :: (FilePath -> Bool) -- ^ only return directories that match this predicate (. and .. are automatically removed) + -> FilePath -- ^ path to directory containing snapshots + -> IO [FilePath] +getSnapshotDirectories nameP dir = + do c <- liftM (filter (\fp -> (fp /= ".") && (fp /= "..") && nameP fp)) ((getDirectoryContents dir) + `catch` + (\e -> if isDoesNotExistError e + then return [] + else ioError e)) + filterM (liftM isRealDirectory . getFileStatus . (dir )) c + where + isRealDirectory :: FileStatus -> Bool + isRealDirectory fs = all ($ fs) [isDirectory, not . isSymbolicLink ] + +-- | file names should short lexagraphically +categorize :: (FilePath -> Bool) -> (FilePath -> Bool) -> [FilePath] -> ([FilePath], [FilePath], [FilePath]) +categorize isCompleteP isInProgressP files = foldr category ([],[],[]) files + where + category file (complete, inprogress, other) + | isCompleteP file = (insertBy newer file complete, inprogress, other) + | isInProgressP file = (complete, insertBy newer file inprogress, other) + | otherwise = (complete, inprogress, insertBy newer file other) + newer = flip compare diff --git a/System/Archive/Prune.hs b/System/Archive/Prune.hs new file mode 100644 --- /dev/null +++ b/System/Archive/Prune.hs @@ -0,0 +1,69 @@ +-- |Limit the number of incremental backups. +module System.Archive.Prune + ( prune + , nextVictim + ) where + +import Control.Monad (when) +import Data.Function (on) +import Data.List (sortBy, stripPrefix) +import Data.Maybe (mapMaybe) +import Data.Time (UTCTime, NominalDiffTime, parseTime, formatTime, diffUTCTime, zonedTimeToUTC) +import System.Directory (getDirectoryContents) +import System.Exit (ExitCode(ExitSuccess)) +import System.FilePath (()) +import System.IO (hPutStr, stderr) +import System.Locale (defaultTimeLocale) +import System.Process (readProcessWithExitCode, showCommandForUser) + +-- |Remove backups until we have a certain number left. +prune :: String -> FilePath -> String -> Int -> IO () +prune dateFormat baseDirName prefix keep = + do paths <- getDirectoryContents baseDirName + let times = sortBy (flip compare) . mapMaybe (timeFromPath dateFormat prefix) $ paths + when -- Always keep two: the oldest and the newest + (length times > max 2 keep) + (nextVictim dateFormat baseDirName prefix >>= \ victim -> + maybe (return ()) rmrf victim >> + prune dateFormat baseDirName prefix keep) + +-- |Decide which archives is the least important +nextVictim :: String -> FilePath -> String -> IO (Maybe FilePath) +nextVictim dateFormat baseDirName prefix = + do paths <- getDirectoryContents baseDirName + -- Compute the backup times and sort newest first. + let times = sortBy (flip compare) . mapMaybe (timeFromPath dateFormat prefix) $ paths + case times of + [] -> return Nothing + (newest : older) -> do + let ages = map (diffUTCTime newest) older + -- For each backup, compute the interval from the + -- backup before to the backup after. + intervals = map (uncurry diffUTCTime) (zip (newest : older) (tail older)) + -- The importance of the backup is the quotient of + -- the interval just computed and the backup's age. + importance :: [(UTCTime, NominalDiffTime)] + importance = zip older (map (uncurry (/)) (zip intervals ages)) + victim :: UTCTime + victim = fst . head $ sortBy (compare `on` snd) importance + let path :: FilePath + path = baseDirName (prefix ++ formatTime defaultTimeLocale "%F_%T" victim) + return $ Just path + +-- |Parse the date string in a backup directory name. +timeFromPath :: String -> FilePath -> FilePath -> Maybe UTCTime +timeFromPath dateFormat prefix path = + stripPrefix prefix path >>= + parseTime defaultTimeLocale dateFormat >>= + return . zonedTimeToUTC + +-- |Remove a directory and its contents. +rmrf :: FilePath -> IO () +rmrf path = do + let cmd = "rm" + args = ["-rf", path] + hPutStr stderr ("Removing backup " ++ path ++ "...") + (code, _, _) <- readProcessWithExitCode cmd args "" + case code of + ExitSuccess -> hPutStr stderr "done.\n" + code -> error $ showCommandForUser cmd args ++ " -> " ++ show code diff --git a/System/Archive/Target.hs b/System/Archive/Target.hs new file mode 100644 --- /dev/null +++ b/System/Archive/Target.hs @@ -0,0 +1,102 @@ +module System.Archive.Target where + +import System.Archive.Archive +import Control.Monad +import Data.Monoid (Monoid(..)) +import Data.List +import qualified Text.PrettyPrint.HughesPJ as D +import System.IO.Error +import System.Unix.QIO (quieter) +-- import Text.PrettyPrint.HughesPJ + +import Text.Help hiding (options) + +-- * Data Type + +data Target + = RsyncTarget { prettyName :: String -- ^ name used to refer to this target + , src :: [FilePath] -- ^ list of locations where the data to mirror can be found, order by preference + , dest :: FilePath -- ^ directory which holds all the snapshots + , config :: Config -- ^ the configuration specification used for this target + , options :: [Option] -- ^ options that should always be used with this target + } + | AptTarget { prettyName :: String -- ^ name used to refer to this target + , src :: [FilePath] -- ^ list of locations where the data to mirror can be found, order by preference + , dest :: FilePath -- ^ directory which holds all the snapshots + , config :: Config -- ^ the configuration specification used for this target + , options :: [Option] -- ^ options that should always be used with this target + , dists :: [(String, [String])] -- ^ [(dist, arches)] + } + +-- * Pretty Print + +showTargets :: [Target] -> Elements +showTargets = foldr (<>) mempty . map showTarget + +showTarget :: Target -> Elements +showTarget (RsyncTarget prettyName srcs dest _ options) = + (text (prettyName ++ ":")) <> rs Nothing (tp Nothing (text "src: ") <> mconcat (map (\src -> text src <> br) srcs) <> + tp Nothing (text "dest:") <> text dest <> br <> + tp Nothing (text "options:") <> showOptions options) + where + showOptions :: [Option] -> Elements + showOptions opts = mconcat (map showOption opts) + showOption :: Option -> Elements + showOption (Rsync str) = text "Rsync " <> cw <> (text str) <> p <> br + showOption NoUpdateSymlink = text "NoUpdateSymlink" <> br +showTarget (AptTarget prettyName srcs dest _ options dists) = + (text (prettyName ++ ":")) <> rs Nothing (tp Nothing (text "src: ") <> mconcat (map (\src -> text src <> br) srcs) <> + tp Nothing (text "dest:") <> text dest <> br <> + tp Nothing (text "options:") <> showOptions options <> + tp Nothing (text "dists:") <> showDists dists) + + where + showOptions :: [Option] -> Elements + showOptions opts = mconcat (map showOption opts) + showOption :: Option -> Elements + showOption (Rsync str) = text "Rsync " <> cw <> (text str) <> p <> br + showOption NoUpdateSymlink = text "NoUpdateSymlink" <> br + showDists :: [(String, [String])] -> Elements + showDists dists = mconcat (map showDist dists) + showDist :: (String, [String]) -> Elements + showDist (dist, arches) = text (dist ++ " ") <> showArches arches + showArches :: [String] -> Elements + showArches arches = text "[" <> mconcat (intersperse (text ", ") (map text arches)) <> text "]" + +-- * Archive Target + +archiveTargets :: [Option] -> [Target] -> IO [(Target, Either IOError (Maybe UpdateResult))] +archiveTargets options targets = + quieter (\ n -> n + 2 - length (filter (== (Rsync "-v")) options)) $ + liftM (zip targets) $ mapM (archiveTarget options) targets + +-- TODO: create repository -> current symlink +archiveTarget :: [Option] -> Target -> IO (Either IOError (Maybe UpdateResult)) +archiveTarget _ target | null (src target) = + return $ Left (userError $ "target " ++ (prettyName target) ++ " does not include any sources") +archiveTarget extraOptions (RsyncTarget _prettyName (src:_) dest config options) = + try (archive config (options ++ extraOptions) src dest []) +archiveTarget extraOptions (AptTarget _prettyName (src:_) dest config options dists) = + try (archive config (options ++ extraOptions) src dest dists) + +ppResults :: [(Target, Either IOError (Maybe UpdateResult))] -> D.Doc +ppResults = D.vcat . map ppResult + +ppResult :: (Target, Either IOError (Maybe UpdateResult)) -> D.Doc +ppResult (t, (Left e)) = D.text (prettyName t) D.<> D.colon D.<+> D.text (show e) +ppResult (t, Right Nothing) = D.text (prettyName t) D.<+> D.text "ok." +ppResult (t, Right (Just Changes)) = D.text (prettyName t) D.<+> D.text "ok. (updated)" +ppResult (t, Right (Just NoChanges)) = D.text (prettyName t) D.<+> D.text "ok. (no changes)" + + +-- * Old + +{- +showTargets :: [Target] -> Doc +showTargets targets = vcat (punctuate (text "" $+$ text "") (map showTarget targets)) + +showTarget :: Target -> Doc +showTarget (Target prettyName srcs dest _) = + (text prettyName) $$ nest 4 (text "source" $+$ (vcat (map text srcs))) + +-} diff --git a/System/Archive/UpdateMirror.hs b/System/Archive/UpdateMirror.hs new file mode 100644 --- /dev/null +++ b/System/Archive/UpdateMirror.hs @@ -0,0 +1,88 @@ +module System.Archive.UpdateMirror + ( updateMirrorMain + , Option(..) + , Target(..) + , Config(..) + , genericConfig + ) + where + +import Control.Monad +import Data.List +import Text.Help as H +import Extra.HughesPJ +import System.Environment +import System.IO + +import System.Archive.Archive +import System.Archive.Target as T + +-- * General Stuff + +manpage progName targets = + Manpage { name = progName + , sectionNum = General + , shortDesc = text "tool to keep mirrors of various repositories up to date." + , synopsis = text (progName ++ " TARGET...") + , description = text "update the mirrors named on the command line." + , H.options = Just opts + , extraSections = Just [targetSection] + , files = Nothing + , environment = Nothing + , diagnostics = Nothing + , bugs = Nothing + , authors = Just [("Jeremy Shaw", "jeremy.shaw@linspire.com")] + , seeAlso = Nothing + } + where + targetSection :: (ShowIn, Text, Elements) + targetSection = (InBoth, (text "TARGETS"), (showTargets targets)) + +opts :: [OptDescr [Option]] +opts = + [ -- Option [] ["prune"] (ReqArg (\n -> [Prune n]) "NUM") "limit the number of backup dirs to NUM." + -- , Option [] ["unlink"] (NoArg [Unlink]) "Keep only the most recent hard link. The newest backup is always complete, but the previous day will only include the files that changed or were removed." + -- , Option [] ["current"] (NoArg [Current]) "Create a link named 'current' to the new archive." + Option [] ["exclude"] (ReqArg (\x -> [Rsync "--exclude", Rsync x]) "PATTERN") (text "Passed to rsync. Implies rsync's --delete-excluded flag (so that adding this flag makes files go away in newer backups).") + -- , Option ['n'] ["dry-run"] (NoArg [DryRun, Rsync "-n"]) "Do not do any file transfers, just report what would have happened." + , Option ['v'] ["verbose"] (NoArg [Rsync "-v"]) (text "run rsync with verbose option.") + , Option ['P'] [] (NoArg [Rsync "-P"]) (text "run rsync with -P, which is the same as --partial --progress.") + , Option ['c'] ["checksum"] (NoArg [Rsync "-c"]) (text "run rsync with -c, skip based on checksum, not mod-time & size.") + , Option [] ["delete-excluded"] (NoArg [Rsync "--delete-excluded"]) (text "run rsync with --delete-excluded, also delete excluded files from dest dirs.") + , Option [] ["delete-after"] (NoArg [Rsync "--delete-after"]) (text "run rsync with --delete-after, Request that the file-deletions on the receiving side be done after the transfer has completed.") + , Option [] ["partial"] (NoArg [Rsync "--partial"]) (text "run rsync with --partial, keep partially transferred files.") + , Option [] ["force"] (NoArg [Rsync "--force"]) (text "run rsync with --force, force deletion of dirs even if not empty.") + , Option [] ["size-only"] (NoArg [Rsync "--size-only"]) (text "run rsync with --size-only, skip files that match in size.") + , Option [] ["timeout"] (ReqArg (\t -> [Rsync $ "--timeout="++ t]) "TIME") (text "set I/O timeout in seconds.") + , Option [] ["bwlimit"] (ReqArg (\kbps -> [Rsync $ "--bwlimit=" ++ kbps]) "KBPS") (text "limit I/O bandwidth; KBytes per second.") + , Option [] ["dump-man-page"] (NoArg []) (text "dump the manpage for this program on stdout and exit immediately. Use groff -mandoc to process the output.") + , Option [] ["no-update-symlink"] (NoArg [NoUpdateSymlink]) (text "do not update the symlink, current, after the update is done.") + ] + +parseOptions :: [Target] -> [String] -> Either String ([Option], [String]) +parseOptions targets args = + case getOpt Permute opts args of + (extraOptions, tgts@(_:_), []) -> + case tgts \\ (map prettyName targets) of + [] -> Right (concat extraOptions, tgts) + unknownTargets -> Left $ (if (singleton unknownTargets) + then "Unrecognized target: " + else "Unrecognized targets: ") ++ + show unknownTargets + (_, [], errors) -> Left $ concat $ "You must specify one or more TARGETs.\n" : errors + (_, _, errors) -> Left $ concat $ errors + where + singleton [_] = True + singleton _ = False + +updateMirrorMain :: [Target] -> IO () +updateMirrorMain targets = + do args <- getArgs + progName <- getProgName + when ("--dump-man-page" `elem` args) (dumpManPage (manpage progName targets)) + case parseOptions targets args of + (Left e) -> do hPutStrLn stderr e + hPutStrLn stderr =<< usage (manpage progName targets) + (Right (extraOptions, tgts)) -> + do res <- archiveTargets extraOptions (filter (\t -> (prettyName t) `elem` tgts) targets) + putStrLn =<< renderWidth (ppResults res) diff --git a/archive.cabal b/archive.cabal new file mode 100644 --- /dev/null +++ b/archive.cabal @@ -0,0 +1,22 @@ +Name: archive +Version: 1.2.12 +Cabal-Version: >= 1.2 +Category: System +Synopsis: A library and programs for creating hardlinked incremental archives or backups +Description: Uses rsync, etc to before backups similar to the old timemachine script and the newer 'Time Machine' OS X tool. +License: BSD3 +License-File: COPYRIGHT +Author: David Fox, Jeremy Shaw +Maintainer: partners@seereason.com +Stability: alpha +Build-Type: Simple + +Library + Build-Depends: base >= 3 && <5, regex-compat, regex-posix, HUnit, process, unix, old-locale, directory, Unixutils, network, time, bytestring, mtl, xhtml, pretty, debian >= 2.19, debian-mirror >= 1.1.3, help, filepath, progress >= 1.51, Extra + Exposed-Modules: System.Archive.Archive, System.Archive.Prune, System.Archive.Target, System.Archive.UpdateMirror, System.Archive.AptMethods + ghc-options: -O2 -W + +Executable archive + Main-Is: util/ArchiveMain.hs + -- Hs-Source-Dirs: util + ghc-options: -O2 -W -threaded diff --git a/util/ArchiveMain.hs b/util/ArchiveMain.hs new file mode 100644 --- /dev/null +++ b/util/ArchiveMain.hs @@ -0,0 +1,90 @@ +-- |The archive command needs to run as root so it can create any file +-- with any ownership, special files, etc. This makes it a security +-- risk. It should use a configuration file to set the destination +-- directory so a malicious user can't pass it arguments to destroy +-- other parts of the system. +-- +-- The command +-- +-- archive @: +-- +-- Creates a copy of the directory in the first argument at +-- +-- / +module Main where + +import Control.Monad +import Data.List +import System.IO +import Data.Maybe +import System.Environment +import System.Exit +import System.Archive.Archive +import Text.Help + +opts :: [OptDescr [Option]] +opts = + [ -- Option [] ["prune"] (ReqArg (\n -> [Prune n]) "NUM") "limit the number of backup dirs to NUM." + -- , Option [] ["unlink"] (NoArg [Unlink]) "Keep only the most recent hard link. The newest backup is always complete, but the previous day will only include the files that changed or were removed." + -- , Option [] ["current"] (NoArg [Current]) "Create a link named 'current' to the new archive." + Option [] ["exclude"] (ReqArg (\x -> [Rsync "--exclude", Rsync x]) "PATTERN") (text "Passed to rsync. Implies rsync's --delete-excluded flag (so that adding this flag makes files go away in newer backups).") + -- , Option ['n'] ["dry-run"] (NoArg [DryRun, Rsync "-n"]) "Do not do any file transfers, just report what would have happened." + , Option ['v'] ["verbose"] (NoArg [Rsync "-v"]) (text "run rsync with verbose option.") + , Option ['P'] [] (NoArg [Rsync "-P"]) (text "run rsync with -P, which is the same as --partial --progress.") + , Option ['c'] ["checksum"] (NoArg [Rsync "-c"]) (text "run rsync with -c, skip based on checksum, not mod-time & size.") + , Option [] ["delete-excluded"] (NoArg [Rsync "--delete-excluded"]) (text "run rsync with --delete-excluded, also delete excluded files from dest dirs.") + , Option [] ["delete-after"] (NoArg [Rsync "--delete-after"]) (text "run rsync with --delete-after, Request that the file-deletions on the receiving side be done after the transfer has completed.") + , Option [] ["partial"] (NoArg [Rsync "--partial"]) (text "run rsync with --partial, keep partially transferred files.") + , Option [] ["force"] (NoArg [Rsync "--force"]) (text "run rsync with --force, force deletion of dirs even if not empty.") + , Option [] ["size-only"] (NoArg [Rsync "--size-only"]) (text "run rsync with --size-only, skip files that match in size.") + , Option [] ["timeout"] (ReqArg (\t -> [Rsync $ "--timeout="++ t]) "TIME") (text "set I/O timeout in seconds.") + , Option [] ["bwlimit"] (ReqArg (\kbps -> [Rsync $ "--bwlimit=" ++ kbps]) "KBPS") (text "limit I/O bandwidth; KBytes per second.") + , Option [] ["no-update-symlink"] (NoArg [NoUpdateSymlink]) (text "do not automatically update the symlink named 'current' to point the latest snapshot.") + , Option [] ["dump-man-page"] (NoArg []) (text "dump the manpage for this program on stdout and exit immediately. Use groff -mandoc to process the output.") + ] + +manpage = + Manpage { name = "archive" + , sectionNum = General + , shortDesc = text "create incremental backups of directories using rsync and hardlinks." + , synopsis = text "archive [options] original backupdir" + , description = text "Create a backup of " <> i <> text "ORIGINAL" <> p <> text " in " <> i <> text "BACKUPDIR" <> p <> + text" in a directory whose name is todays date. \ + \The original may be on a remote machine. \ + \This is achieved without wasting disk space on unchanged files using \ + \a simple incremental backup technique I read about somewhere using " <> + cw <> text "cp -al" <> + p <> text" to create a hard linked copy of the previous backup and rsync \ + \to modify that copy into a copy of the current directory. It does use \ + \a lot of inodes, but I haven't run out yet on Reiser 3." + , options = Just opts + , extraSections = Nothing + , files = Nothing + , environment = Nothing + , diagnostics = Nothing + , bugs = Nothing + , authors = Just [ ("David Fox","david@seereason.org") + , ("Jeremy Shaw", "jeremy@n-heptane.com") + ] + , seeAlso = Nothing + } + +parseOptions args = + case getOpt Permute opts args of + (options, [src,dest], []) -> Right (concat options, src, dest) + (_,[],errors) -> Left $ concat $ "Missing original and backupdir arguments.\n" : errors + (_,[_],errors) -> Left $ concat $ "Missing backupdir argument\n" : errors + (_,(_:_:rest),errors) -> Left $ concat $ ("Unexpected arguments: " ++ unwords rest ++ "\n") : errors + +main :: IO () +main = + do args <- getArgs + when ("--dump-man-page" `elem` args) (dumpManPage manpage) + case parseOptions args of + (Left e) -> hPutStrLn stderr e >> + usage manpage >>= hPutStrLn stderr >> + exitFailure + (Right (options, original, backup)) -> + do archive (genericConfig "snapshot" "%Y-%m-%d") options original backup [] + return () +