archive (empty) → 1.2.12
raw patch · 9 files changed
+956/−0 lines, 9 filesdep +Extradep +HUnitdep +Unixutilssetup-changed
Dependencies added: Extra, HUnit, Unixutils, base, bytestring, debian, debian-mirror, directory, filepath, help, mtl, network, old-locale, pretty, process, progress, regex-compat, regex-posix, time, unix, xhtml
Files
- COPYRIGHT +26/−0
- Setup.hs +2/−0
- System/Archive/AptMethods.hs +207/−0
- System/Archive/Archive.hs +350/−0
- System/Archive/Prune.hs +69/−0
- System/Archive/Target.hs +102/−0
- System/Archive/UpdateMirror.hs +88/−0
- archive.cabal +22/−0
- util/ArchiveMain.hs +90/−0
+ COPYRIGHT view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Archive/AptMethods.hs view
@@ -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
+ System/Archive/Archive.hs view
@@ -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:<path>.+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
+ System/Archive/Prune.hs view
@@ -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
+ System/Archive/Target.hs view
@@ -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)))++-}
+ System/Archive/UpdateMirror.hs view
@@ -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)
+ archive.cabal view
@@ -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
+ util/ArchiveMain.hs view
@@ -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 <user>@<host>:<path> <dest>+--+-- Creates a copy of the directory in the first argument at+--+-- <dest>/<date>+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 ()+