shellmate-extras 0.3 → 0.3.1

raw patch · 2 files changed

+164/−2 lines, 2 filesdep +mime-typesdep +textdep ~shellmate

Dependencies added: mime-types, text

Dependency ranges changed: shellmate

Files

• Control/Shell/Extract.hs +157/−0
• shellmate-extras.cabal +7/−2

@@ -0,0 +1,157 @@+-- | Extract various archive files in a consistent manner.+{-# LANGUAGE OverloadedStrings #-}+module Control.Shell.Extract+  ( -- * Extracting archives+    extract, extractWith, supportedExtensions, canExtract+    -- * Extraction options+  , ExtractOptions, separateDirectory, removeArchive+  , defaultExtractOptions+  ) where+import Control.Shell+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import Network.Mime+import System.IO.Unsafe++data ExtractOptions = ExtractOptions+  { -- | Extract archive into a separate directory. The anme of the directory+    --   will be the base name of the archive.+    --   If the archive contains a single directory on the top-level, the+    --   contents of that directory will be moved into the outer directory.+    --   This ensures that tarbombs and non-tarbombs are treated consistently.+    --+    --   Default: @True@+    separateDirectory :: Bool++    -- | Remove the archive after extraction?+    --+    --   Default: @False@+  , removeArchive     :: Bool+  }++-- | Default extraction options. See 'ExtractOptions' for defaults.+defaultExtractOptions :: ExtractOptions+defaultExtractOptions = ExtractOptions+  { separateDirectory = True+  , removeArchive     = False+  }++-- | The list of supported archive format file extensions.+--   On a typical Linux/OSX/Cygwin/MinGW system, .tar, .tar.gz, .tar.bz2,+--   .tar.xz, .tbz2, .tgz, .bz2, .gz and .xz should all be supported.+--   If the appropriate programs are installed, .zip, .rar and .7z should also+--   be supported.+supportedExtensions :: [String]+supportedExtensions = unsafePerformIO $ do+  env <- shell_ $ getShellEnv+  res <- runSh (env {envStdErr = envStdOut env}) $ do+    tar <- (capture (run "tar" ["-?"]) >> pure tarExts) `orElse` pure []+    z7 <- (capture (run "7z" []) >> pure [".7z"]) `orElse` pure []+    rar <- (capture (run "unrar" []) >> pure [".rar"]) `orElse` pure []+    z <- (capture (run "unzip" []) >> pure [".zip"]) `orElse` pure []+    xz <- (capture (run "xz" ["--help"]) >> pure [".xz"]) `orElse` pure []+    bz2 <- (capture (run "bunzip2" ["--help"]) >> pure [".bz2"]) `orElse` pure []+    gz <- (capture (run "gunzip" ["--help"]) >> pure [".gz"]) `orElse` pure []+    pure $ concat [tar, z7, rar, z, xz, bz2, gz]+  case res of+    Left _   -> pure []+    Right xs -> pure xs+  where+     tarExts = [".tar.gz", ".tar.bz2", ".tar.xz", ".tbz2", ".tgz", ".tar"]++-- | Can the given file be extracted, as determined by comparing the file+--   extension to the list of supported extensions.+canExtract :: FilePath -> Bool+canExtract f =+    any (and . zipWith (==) f') (map reverse supportedExtensions)+  where+    f' = reverse f++-- | Extract an archive with the default options. See 'ExtractOptions'+--   for details.+extract :: FilePath -> Shell ()+extract = extractWith defaultExtractOptions++-- | Extract an archive with the given extraction options.+extractWith :: ExtractOptions -> FilePath -> Shell ()+extractWith opts file = do+    archivedir <- pwd+    let archive = archivedir </> file+    mkdir True outputDir+    case extractCmd archive of+      Just (cmd, args)+        | canExtract file -> inDirectory outputDir $ do+            void . capture $ run cmd (args ++ [archive])+            moveOutputToWorkDir archive+            when (separateDirectory opts) $ void $ try mergeOneLevelRoot+            when (removeArchive opts) $ rm archive+        | otherwise ->+            supportFail cmd+      Nothing ->+            mimeFail+  where+    outputDir+      | separateDirectory opts = takeBasestName file+      | otherwise              = "."+    mimeFail = fail $ concat+      [ "mime type does not seem to be an archive: "+      , BS.unpack $ defaultMimeLookup (T.pack file)+      ]+    supportFail cmd = fail $ concat+      [ "unable to unpack archive, as the program `" ++ cmd ++ "' "+      , "was not found"+      ]++-- | If the current working directory contains a single directory, move all+--   contents of that directory into the working directory, then remove the+--   directory.+mergeOneLevelRoot :: Shell ()+mergeOneLevelRoot = do+  [dir] <- ls "."+  guard $ isDirectory dir+  inCustomTempDirectory "." $ do+    mv (".." </> dir) "."+    files <- ls dir+    mapM_ (\f -> mv (dir </> f) "..") files++-- | Command + arguments to extract an archive file.+--   Arguments must be followed immediately by the archive file name.+extractCmd :: FilePath -> Maybe (FilePath, [String])+extractCmd f =+  case defaultMimeLookup (T.pack f) of+    "application/x-7z-compressed"       -> Just ("7z", ["x"])+    "application/zip"                   -> Just ("unzip", [])+    "application/x-rar-compressed"      -> Just ("unrar", ["x"])+    "application/x-tar"                 -> Just ("tar", ["-xf"])+    "application/x-tgz"                 -> Just ("tar", ["-xzf"])+    "application/x-bzip-compressed-tar" -> Just ("tar", ["-xjf"])+    "application/x-bzip"                -> Just ("bunzip2", ["-k"])+    "application/x-gzip"                -> Just ("gunzip", ["-k"])+    "application/x-xz"+      | "application/x-tar" <- defaultMimeLookup (T.pack $ dropExtension f)+                                        -> Just ("tar", ["-xJf"])+      | otherwise                       -> Just ("xz", ["-dk"])+    _                                   -> Nothing++-- | Move the extracted file of the given archive into the current working+--   directory, if the archive is .gz, .bz2 or .xz. Workaround for bunzip,+--   gunzip2 and xz insisting on unpacking files to the same directory as the+--   archive instead of to the current working directory.+moveOutputToWorkDir :: FilePath -> Shell ()+moveOutputToWorkDir f = when needsWorkaround $ mv f' (takeFileName f')+  where+    f' = dropExtension f+    needsWorkaround =+      case defaultMimeLookup (T.pack f) of+        "application/x-bzip" -> True+        "application/x-gzip" -> True+        "application/x-xz"   ->+          "application/x-tar" /= defaultMimeLookup (T.pack f')+        _                    -> False++-- | Iterate 'takeBaseName' until all extensions are gone.+takeBasestName :: FilePath -> FilePath+takeBasestName f+  | f == f'   = f+  | otherwise = takeBasestName f'+  where f' = takeBaseName f 

@@ -1,5 +1,5 @@ name:                shellmate-extras-version:             0.3+version:             0.3.1 synopsis:            Extra functionality for shellmate. description:         HTTP downloads and parsing for various file formats. homepage:            https://github.com/valderman/shellmate@@ -19,6 +19,7 @@ library   exposed-modules:     Control.Shell.Download+    Control.Shell.Extract   build-depends:     base        >=4.7    && <5,     bytestring  >=0.10   && <0.11,@@ -27,6 +28,10 @@     feed        >=0.3    && <0.4,     tagsoup     >=0.13   && <0.14,     xml         >=1.3    && <1.4,-    shellmate   >=0.3    && <0.4+    text        >=1.2    && <1.3,+    mime-types  >=0.1    && <0.2,+    shellmate   >=0.3.1  && <0.4   default-language:     Haskell2010+  ghc-options:+    -Wall