diff --git a/Lastik.cabal b/Lastik.cabal --- a/Lastik.cabal +++ b/Lastik.cabal @@ -1,5 +1,5 @@ Name: Lastik -Version: 0.6.1 +Version: 0.6.2 License: BSD3 License-File: LICENSE Author: Tony Morris @@ -23,6 +23,7 @@ GHC-Options: -Wall Exposed-Modules: System.Build, + System.Build.Directory, System.Build.FilePather, System.Build.Args, System.Build.Runner, diff --git a/System/Build/Directory.hs b/System/Build/Directory.hs new file mode 100644 --- /dev/null +++ b/System/Build/Directory.hs @@ -0,0 +1,130 @@ +-- | A module for performing operations on directories. +module System.Build.Directory( + -- * Directory manipulating + chdir, + mkdir, + rmdir, + -- * Directory archiving + archiveDirectories, + writeArchive, + writeHashArchive, + -- * Copying directories + copy, + copyl, + dropRoot, + dropRoot' + ) where + +import System.Directory +import System.FilePath +import System.Build.FilePather +import Codec.Archive.Zip +import qualified Data.ByteString.Lazy as B +import Control.Monad +import Control.Exception +import Data.Digest.Pure.MD5 +import Data.Digest.Pure.SHA + +-- | Change to the given directory, then execute the given action, then change back to the original directory. +chdir :: FilePath -- ^ The directory to change to. + -> IO a -- ^ The action to execute in the given directory. + -> IO a -- ^ The result of executing the given action. +chdir d a = bracket getCurrentDirectory setCurrentDirectory (\_ -> setCurrentDirectory d >> a) + +-- | Creates the given directory and its parents if it doesn't exist. +mkdir :: FilePath -- ^ The directory to create. + -> IO () +mkdir = createDirectoryIfMissing True + +-- | Removes the given directory recursively if it exists. +rmdir :: FilePath -- ^ The directory to remove. + -> IO () +rmdir d = doesDirectoryExist d >>= flip when (removeDirectoryRecursive d) + +-- | Copy the contents of a directory to another, perhaps trimming parent directories. +copy :: RecursePredicate -- ^ The recursion predicate to search for files in the source directory. + -> FilterPredicate -- ^ The filter predicate to search for files in the source directory. + -> FilePath -- ^ The source directory. + -> FilePath -- ^ The target directory. + -> IO () +copy r f from to = do isf <- doesFileExist from + if isf + then error ("Cannot copy from file " ++ from) + else do isd <- doesDirectoryExist from + if isd + then do dis <- doesFileExist to + if dis + then error ("Cannot copy to" ++ to ++ " (a file)") + else do j <- find r f from + k <- filterM doesFileExist j + mkdir to + mapM_ (\z -> let t = to dropWhile (pathSeparator ==) (drop (length from) z) + in do mkdir (dropFileName t) + copyFile z t) k + else error (from ++ " is not a directory") + +-- | Copy the contents of a directory to another, perhaps trimming parent directories. +copyl :: RecursePredicate -- ^ The recursion predicate to search for files in the source directory. + -> FilterPredicate -- ^ The filter predicate to search for files in the source directory. + -> Int -- ^ The number of parent directories to drop before copying to the target directory. + -> FilePath -- ^ The source directory. + -> FilePath -- ^ The target directory. + -> IO () +copyl rp fp levels from to = do s <- find rp fp from + forM_ s (\f -> let d = dropRoot' levels f + in do mkdir (to dropFileName d) + copyFile f (to d)) + +-- | Create a zip archive by changing into directories and archiving the contents. +archiveDirectories :: [(FilePath, FilePath)] -- ^ A list of base directories to change to and contents of that directory to archive. + -> RecursePredicate -- ^ The recursion predicate to search for files to archive. + -> FilterPredicate -- ^ The filter predicate to search for files to archive. + -> [ZipOption] -- ^ The options during the creation of the archive. + -> IO Archive -- ^ The constructed archive. +archiveDirectories dirs rp fp opts = foldM (\a (d, f) -> chdir d $ do j <- find rp fp f + addFilesToArchive opts a j) emptyArchive dirs + +-- | Writes a zip archive to a file. +writeArchive :: [(FilePath, FilePath)] -- ^ A list of base directories to change to and contents of that directory to archive. + -> RecursePredicate -- ^ The recursion predicate to search for files to archive. + -> FilterPredicate -- ^ The filter predicate to search for files to archive. + -> [ZipOption] -- ^ The options during the creation of the archive. + -> FilePath -- ^ The file to write the archive to. + -> IO () +writeArchive dirs rp fp opts f = do a <- archiveDirectories dirs rp fp opts + B.writeFile f (fromArchive a) + +-- | Writes a zip archive to a file then computes a MD5 and SHA1 hash and writes them to files with @".md5"@ and @".sha1"@ extensions. +writeHashArchive :: [(FilePath, FilePath)] -- ^ A list of base directories to change to and contents of that directory to archive. + -> RecursePredicate -- ^ The recursion predicate to search for files to archive. + -> FilterPredicate -- ^ The filter predicate to search for files to archive. + -> [ZipOption] -- ^ The options during the creation of the archive. + -> FilePath -- ^ The file to write the archive to and the prefix name of the files containing the hashes. + -> IO () +writeHashArchive dirs rp fp opts f = do a <- archiveDirectories dirs rp fp opts + let s = fromArchive a + B.writeFile f s + forM_ [(show . md5, "md5"), (show . sha1, "sha1")] (\(k, d) -> writeFile (f <.> d) (k s)) + +-- | Drops the parent directory of a given file path. +-- +-- > dropRoot "/foo/bar" == "/bar" +-- > dropRoot "foo/bar" == "bar" +-- > dropRoot "foo" == "" +-- > dropRoot "" == "" +dropRoot :: FilePath -- ^ The file path to drop the parent directory from. + -> String -- ^ The file path without a parent directory. +dropRoot [] = [] +dropRoot (x:xs) = (if x == pathSeparator then id else drop 1) (dropWhile (/= pathSeparator) xs) + +-- | Drops the parent directory ('dropRoot') of a given file path multiple times. +-- +-- > dropRoot' 0 "/foo/bar" == "/foo/bar" +-- > dropRoot' 1 "/foo/bar" == "/bar" +-- > dropRoot' 1 "foo/bar" == "bar" +-- > dropRoot' 2 "foo/bar" == "" +-- > dropRoot' 10 "foo/bar" == "" +dropRoot' :: Int -- ^ The number of times to drop the parent directory. + -> FilePath -- ^ The file path to drop parent directories from. + -> FilePath -- ^ Te file path without parent directories. +dropRoot' n k = iterate dropRoot k !! (if n < 0 then 0 else n)