bogocopy (empty) → 0.1.0.2
raw patch · 7 files changed
+470/−0 lines, 7 filesdep +basedep +directorydep +filemanipsetup-changed
Dependencies added: base, directory, filemanip, filepath, optparse-applicative, shelly, text, transformers, unix
Files
- LICENSE +26/−0
- README.md +39/−0
- Setup.hs +2/−0
- bogocopy.cabal +41/−0
- src/CmdArgs.hs +91/−0
- src/Main.hs +245/−0
- src/Trunc.hs +26/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright phlummox (c) 2016++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.++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+HOLDER 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.
+ README.md view
@@ -0,0 +1,39 @@+# bogocopy [](https://hackage.haskell.org/package/bogocopy) [](https://travis-ci.org/phlummox/bogocopy)++Copies a directory tree, preserving permissions and modification times, but+making zero-size sparse copies of big files.++## Installing and running++Install in the standard Haskell way: `cabal install bogocopy`, or `stack+install bogocopy` if using Stack.++Usage: ++ bogocopy [-v|--verbose] (-s|--size SIZE_MB) SRCDIR DSTDIR++> copy a directory tree, preserving permissions and modification times, but+> making zero-size sparse copies of big files+>+> `DSTDIR` will be created.++Available options:++`-h,--help` ++> Show this help text++`--v,--verbose` ++> Verbose (debugging) output++`--s,--size SIZE_MB`++> Size limit, files leq to this size (in MB) are real-copied, those above are not.++### Bugs and limitations++- Limited to unix-like systems with `rsync` and `cp` commands available.+- Won't preserve the "ctime" (inode change time) of a node+- Tested in only a desultory fashion, use at your own risk+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bogocopy.cabal view
@@ -0,0 +1,41 @@+name: bogocopy+version: 0.1.0.2+synopsis: Simple project template from stack+description: + Copies a directory tree, preserving permissions and modification times, but+ making zero-size sparse copies of big files. See the README file.++homepage: https://github.com/phlummox/bogocopy+license: BSD2+license-file: LICENSE+author: phlummox+maintainer: phlummox2@gmail.com+copyright: phlummox 2016 +category: System Tools, Tools, File Manager+build-type: Simple+tested-with: GHC == 8.0.1 +cabal-version: >=1.10+extra-source-files: README.md++executable bogocopy+ hs-source-dirs: src+ main-is: Main.hs+ other-modules: + CmdArgs+ , Paths_bogocopy+ , Trunc+ default-language: Haskell2010+ build-depends: + base >= 4.0 && < 5+ , directory >= 1.2.6.0+ , filepath+ , filemanip+ , optparse-applicative+ , shelly+ , text+ , transformers+ , unix++source-repository head+ type: git+ location: https://github.com/phlummox/bogocopy
+ src/CmdArgs.hs view
@@ -0,0 +1,91 @@+++module CmdArgs where++import Data.Version (showVersion)+import qualified Paths_bogocopy (version)+++import Data.Monoid+import Options.Applicative hiding (helper)+import System.Environment+++-- | A hidden \"helper\" option which always fails.+helper :: Parser (a -> a)+helper = abortOption ShowHelpText $ mconcat+ [ long "help"+ , short 'h'+ , help "Show this help text"+ , hidden ]++data CmdArgs = CmdArgs + {+ verbose :: Bool+ , maxSizeBytes :: Int+ , srcDir :: String+ , dstDir :: String+ }+ deriving (Eq, Show)++-- | int option reader+int :: ReadM Int+int = auto++intOption = option int+++version = showVersion $ Paths_bogocopy.version++-- | parser for command-line args.+parseCmdArgs :: Parser CmdArgs+parseCmdArgs = CmdArgs + <$> switch+ ( short 'v' + <> long "verbose"+ <> help "verbose (debugging) output" )+ <*> (mBytesToBytes <$> intOption+ ( long "size"+ <> short 's'+ <> metavar "SIZE_MB"+ <> help "size limit, files leq to this size (in MB) are real-copied, those above are not" ))+ <*> argument str (metavar "SRCDIR")+ <*> argument str (metavar "DSTDIR"+ <> help "will be created") ++ where+ mBytesToBytes x = 1024 * 1024 * x++++testMain :: IO ()+testMain =+ withArgs [+ "-v"+ , "-s" , "100"+ , "/foo/bar/baz"+ , "/thing/dest"+ ] + main++-- | test this module out+main :: IO ()+main = + withCmdArgs print ++-- | parse command-line args, and execute an action+-- which takes them as an argument.+withCmdArgs :: (CmdArgs -> IO b) -> IO b+withCmdArgs f = execParser opts >>= f+ where+ opts = info (helper <*> parseCmdArgs)+ ( fullDesc+ <> progDesc desc+ <> header h )++ desc = "copy a directory tree, preserving permissions and modification times, but making zero-size sparse copies of big files"+ h = "bogocopy v " <> version <> + " like rsync, but bogofy files over size limit" +++
+ src/Main.hs view
@@ -0,0 +1,245 @@++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+++module Main where++import Control.Monad.IO.Class (MonadIO(..))++import Data.IORef+import Data.List (sort, sortBy, isPrefixOf, stripPrefix)+import Data.Maybe (fromJust)+import Data.Monoid ( (<>) )+import Data.Ord (comparing, Down(..))+import Data.Text (Text(..))+import qualified Data.Text as T+import System.Directory (copyFileWithMetadata)+import System.FilePath (splitPath, joinPath)+import System.FilePath.Find (find, always, fileType, (==?)+ , FileType(..), FindClause(..)+ , (&&?), (<=?) )+import qualified System.FilePath.Find as Fd (fileSize)+import System.IO (hSetBuffering, stdout, BufferMode(..))+import System.Posix.Files (fileSize, modificationTime+ , getSymbolicLinkStatus+ , setFileTimesHiRes, accessTimeHiRes+ , modificationTimeHiRes, getFileStatus)+import System.Posix.Types (COff(..))+import System.IO.Unsafe++import qualified Shelly.Lifted as S+import Shelly.Lifted hiding (find, FilePath)++import Trunc (truncate)+import CmdArgs (CmdArgs(..), withCmdArgs)++default (Text)++-- | naughty. shift these into a reader monad or something.+{-# NOINLINE debugRef #-}+debugRef = unsafePerformIO $ newIORef False++{-# NOINLINE debug #-}+debug = unsafePerformIO $ readIORef debugRef++-- | number of levels in a path+depth path = length $ splitPath path+++-- | basically, makes srcFile relative to srcDir,+-- then substitutes in dstDir instead.+--+-- will throw exception on empty strings.+replaceDir :: String -> String -> String -> String+replaceDir srcDir dstDir srcFile=+ let+ srcDir' = if last srcDir /= '/' then srcDir <> "/" else srcDir+ dstDir' = if last dstDir /= '/' then dstDir <> "/" else dstDir+ in+ replaceDir_ srcDir' dstDir' srcFile+ where+ replaceDir_ srcDir dstDir srcFile =+ if srcDir `isPrefixOf` srcFile + then let fileBit = fromJust $ stripPrefix srcDir srcFile+ in joinPath [dstDir, fileBit]+ else error $ "replaceDir: srcDir '" <> srcDir <> "' is not prefix of srcFile '" <> srcFile <> "'"++ +-- | replaceDir' - version for Text+replaceDir' srcDir dstDir srcFile =+ T.pack $ replaceDir (T.unpack srcDir) (T.unpack dstDir) (T.unpack srcFile)+++-- NB:+-- "cp -a"+-- is same as System.Directory.copyFileWithMetadata++-- | eitherFiles pred f g src dst --+-- where src and dst are directory names,+-- will process all the files under src according+-- to pred. If they pass, it processes them with "f"+-- (takes the src file path and the dest file path),+-- otherwise with "g".+eitherFiles+ :: FindClause Bool+ -> (Text -> Text -> Sh a)+ -> (Text -> Text -> Sh a)+ -> Text+ -> Text+ -> Sh ([a], [a])+eitherFiles = + filtSplitFiles (fileType ==? RegularFile) +++-- | same as eitherFiles, but return Sh ().+eitherFiles_+ :: FindClause Bool+ -> (Text -> Text -> Sh ())+ -> (Text -> Text -> Sh ())+ -> Text+ -> Text+ -> Sh ()+eitherFiles_ pred f g src dst = do+ _ <- eitherFiles pred f g src dst+ return ()++-- same as eitherFiles, but for directories.+eitherDirs = + filtSplitFiles (fileType ==? Directory) ++-- | filtSplitFiles filterPred splitPred f g src dst:+--+-- iterate over the files in directory src.+-- filter for ones matching filterPred, discarding all others.+-- then split them into 2 - those matching splitPred, and those not.+-- On those that do, execute f, on the others, execute g.+-- Return the results+filtSplitFiles+ :: Control.Monad.IO.Class.MonadIO m =>+ FindClause Bool+ -> FindClause Bool+ -> (Text -> Text -> m a)+ -> (Text -> Text -> m b)+ -> Text+ -> Text+ -> m ([a], [b])+filtSplitFiles filterPred splitPred f g src dst = do+ predDirs <- liftIO $ find always (filterPred &&? splitPred) (T.unpack src)+ otherfiles <- liftIO $ find always (filterPred &&? (not <$> splitPred)) (T.unpack src) + let getNewName = replaceDir' src dst+ doF p = f p (getNewName p)+ doG p = g p (getNewName p)++ good <- mapM (doF . T.pack) predDirs+ ungood <- mapM (doG . T.pack) otherfiles+ return (good, ungood)+++-- | bogoCopy pred srcDir dstDir: make a 'clone' of srcDir at dstDir;+-- but if a file passes "pred", then make a real copy,+-- but if not, just make a zero-size sparse file with the same+-- name and attributes.+--bogoCopy+-- :: System.FilePath.Find.FindClause Bool+bogoCopy :: FindClause Bool -> Text -> Text -> Sh ()+bogoCopy pred srcDir dstDir = do+ let isDir = fileType ==? Directory+ when debug $+ echo_err "copying directory structure" + tree_cp srcDir dstDir+ when debug $+ echo_err "copying files" + eitherFiles_ pred real_cp zero_cp srcDir dstDir+ let -- return the src, and an action to clone the time+ depthAndSetTime :: Text -> Text -> Sh (String, Sh ())+ depthAndSetTime src dst =+ return (T.unpack src, time_cp src dst)+ when debug $+ echo_err "cloning dir times" + -- set the times, running actions in reverse order of depth+ -- (i.e. deepest first) + (xs, _) <- eitherDirs isDir + depthAndSetTime + (\_ _ -> return ()) + srcDir + dstDir + sequence_ $ snd $ unzip $ sortBy (comparing (Down . fst)) xs+++fromPath = T.unpack . toTextIgnore ++-- | FilePath version of fileSize+fileSize' path = + fileSize <$> (getFileStatus . fromPath) path+ ++hasSize pred path = do+ sz <- fileSize' path+ return $ pred sz+ ++real_cp :: Text -> Text -> Sh ()+real_cp src dst = do+ -- cmd "cp" "-d" "--preserve=all" src dst+ when debug $+ echo_err $ "real_cp " <> src <> " " <> dst+ liftIO $ copyFileWithMetadata (T.unpack src) (T.unpack dst)++zero_cp :: Text -> Text -> Sh ()+zero_cp src dst = do+ when debug $+ echo_err $ "zero_cp " <> src <> " " <> dst+ cmd "cp" "--attributes-only" "--preserve=all" src dst+ stat <- liftIO $ getSymbolicLinkStatus (T.unpack src)+ let aTime = accessTimeHiRes stat+ mTime = modificationTimeHiRes stat+ sz = fileSize stat + liftIO $ do+ Trunc.truncate (T.unpack dst) 0+ Trunc.truncate (T.unpack dst) (fromIntegral sz)+ setFileTimesHiRes (T.unpack dst) aTime mTime++time_cp :: Text -> Text -> Sh ()+time_cp src dst = do+ when debug $+ echo_err $ "time_cp " <> src <> " " <> dst+ -- cmd "cp" "--attributes-only" "--preserve=all" src dst+ stat <- liftIO $ getSymbolicLinkStatus (T.unpack src)+ let aTime = accessTimeHiRes stat+ mTime = modificationTimeHiRes stat+ sz = fileSize stat + liftIO $ + setFileTimesHiRes (T.unpack dst) aTime mTime+++-- | make copy of directory tree. should preserve modification times, ownership/permissions+tree_cp :: Text -> Text -> Sh ()+tree_cp src dst = do+ when debug $+ echo_err $ "tree_cp " <> src <> " " <> dst+ run_ "rsync" ["-avAt", "--include", "*/", "--exclude", "*", src, dst]++-- | src and dst are source and dest dirs.+-- maxSize is size less than which, in MB, we should make real copies+mainSh+ :: String -> String -> COff -> IO ()+mainSh src dst maxSizeBytes = do+ hSetBuffering stdout LineBuffering+ let verbosify = if debug+ then verbosely+ else silently+ shelly $ verbosify $ + bogoCopy (Fd.fileSize <=? maxSizeBytes) (T.pack (src <> "/")) (T.pack dst) +main :: IO ()+main = withCmdArgs $ + \(CmdArgs.CmdArgs verbose bytesSize srcDir dstDir) -> do+ writeIORef debugRef verbose+ mainSh srcDir dstDir (fromIntegral bytesSize)++++++
+ src/Trunc.hs view
@@ -0,0 +1,26 @@++{-# LANGUAGE CApiFFI #-}++{-| Haskell API to posix "truncate" function.+-}+++module Trunc where++import Foreign.C (CString, CInt(..)+ , withCString, throwErrnoPathIfMinus1_)+import System.Posix.Types (COff(..))++-- | returns 0 on success, -1 on failure, w/ an error code.+-- the COff is size in bytes+foreign import capi unsafe "unistd.h truncate" + c_truncate :: CString -> COff -> IO CInt++-- | "truncate filename size" will 'truncate' the file+-- to that size (in bytes), as per the posix function.+truncate :: FilePath -> Int -> IO ()+truncate filename size = + withCString filename $ \cstr -> + throwErrnoPathIfMinus1_ "truncate" filename $ + c_truncate cstr (fromIntegral size)+