Rename security checks

Author: Bodigrim

Codec/Archive/Tar.hs

@@ -108,7 +108,7 @@ module Codec.Archive.Tar (
   pack,
   packAndCheck,
   unpack,
-  unpackWith,
+  unpackAndCheck,
 
   -- * Types
   -- ** Tar entry type

Codec/Archive/Tar/Check.hs

@@ -15,14 +15,17 @@ module Codec.Archive.Tar.Check (
 
   -- * Security
   checkSecurity,
+  checkEntrySecurity,
   FileNameError(..),
 
   -- * Tarbombs
   checkTarbomb,
+  checkEntryTarbomb,
   TarBombError(..),
 
   -- * Portability
   checkPortability,
+  checkEntryPortability,
   PortabilityError(..),
   PortabilityPlatform,
   ) where

Codec/Archive/Tar/Check/Internal.hs

@@ -22,18 +22,22 @@ module Codec.Archive.Tar.Check.Internal (
 
   -- * Security
   checkSecurity,
+  checkEntrySecurity,
   FileNameError(..),
 
   -- * Tarbombs
   checkTarbomb,
+  checkEntryTarbomb,
   TarBombError(..),
 
   -- * Portability
   checkPortability,
+  checkEntryPortability,
   PortabilityError(..),
   PortabilityPlatform,
   ) where
 
+import Codec.Archive.Tar.LongNames
 import Codec.Archive.Tar.Types
 import Control.Applicative ((<|>))
 import Control.Monad.Catch (MonadThrow(throwM))
@@ -67,35 +71,42 @@ import qualified System.FilePath.Posix   as FilePath.Posix
 -- link target. A failure in any entry terminates the sequence of entries with
 -- an error.
 --
-checkSecurity :: CheckSecurityCallback
-checkSecurity e = do
-  check (entryTarPath e)
+checkSecurity
+  :: Entries e
+  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError)
+checkSecurity = checkEntries checkEntrySecurity . decodeLongNames
+
+-- |
+-- @since 0.6.0.0
+checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError
+checkEntrySecurity e =
+  check (entryTarPath e) <|>
   case entryContent e of
     HardLink     link ->
       check link
     SymbolicLink link ->
       check (FilePath.Posix.takeDirectory (entryTarPath e) FilePath.Posix.</> link)
-    _ -> pure ()
+    _ -> Nothing
   where
     checkPosix name
       | FilePath.Posix.isAbsolute name
-      = throwM $ AbsoluteFileName name
+      = Just $ AbsoluteFileName name
       | not (FilePath.Posix.isValid name)
-      = throwM $ InvalidFileName name
+      = Just $ InvalidFileName name
       | not (isInsideBaseDir (FilePath.Posix.splitDirectories name))
-      = throwM $ UnsafeLinkTarget name
-      | otherwise = pure ()
+      = Just $ UnsafeLinkTarget name
+      | otherwise = Nothing
 
     checkNative (fromFilePathToNative -> name)
       | FilePath.Native.isAbsolute name || FilePath.Native.hasDrive name
-      = throwM $ AbsoluteFileName name
+      = Just $ AbsoluteFileName name
       | not (FilePath.Native.isValid name)
-      = throwM $ InvalidFileName name
+      = Just $ InvalidFileName name
       | not (isInsideBaseDir (FilePath.Native.splitDirectories name))
-      = throwM $ UnsafeLinkTarget name
-      | otherwise = pure ()
+      = Just $ UnsafeLinkTarget name
+      | otherwise = Nothing
 
-    check name = checkPosix name >>= \_ -> checkNative (fromFilePathToNative name)
+    check name = checkPosix name <|> checkNative (fromFilePathToNative name)
 
 isInsideBaseDir :: [FilePath] -> Bool
 isInsideBaseDir = go 0
@@ -143,18 +154,28 @@ showFileNameError mb_plat err = case err of
 -- Note: This check must be used in conjunction with 'checkSecurity'
 -- (or 'checkPortability').
 --
-checkTarbomb :: FilePath -> CheckSecurityCallback
-checkTarbomb expectedTopDir entry = do
+checkTarbomb
+  :: FilePath
+  -> Entries e
+  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError)
+checkTarbomb expectedTopDir
+  = checkEntries (checkEntryTarbomb expectedTopDir)
+  . decodeLongNames
+
+-- |
+-- @since 0.6.0.0
+checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError
+checkEntryTarbomb expectedTopDir entry = do
   case entryContent entry of
     -- Global extended header aka XGLTYPE aka pax_global_header
     -- https://pubs.opengroup.org/onlinepubs/9699919799/utilities/pax.html#tag_20_92_13_02
-    OtherEntryType 'g' _ _ -> pure ()
+    OtherEntryType 'g' _ _ -> Nothing
     -- Extended header referring to the next file in the archive aka XHDTYPE
-    OtherEntryType 'x' _ _ -> pure ()
+    OtherEntryType 'x' _ _ -> Nothing
     _                      ->
       case FilePath.Posix.splitDirectories (entryTarPath entry) of
-        (topDir:_) | topDir == expectedTopDir -> pure ()
-        _ -> throwM $ TarBombError expectedTopDir (entryTarPath entry)
+        (topDir:_) | topDir == expectedTopDir -> Nothing
+        _ -> Just $ TarBombError expectedTopDir (entryTarPath entry)
 
 -- | An error that occurs if a tar file is a \"tar bomb\" that would extract
 -- files outside of the intended directory.
@@ -195,33 +216,40 @@ instance Show TarBombError where
 --   includes characters that are valid in both systems and the \'/\' vs \'\\\'
 --   directory separator conventions.
 --
-checkPortability :: CheckSecurityCallback
-checkPortability entry
+checkPortability
+  :: Entries e
+  -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError)
+checkPortability = checkEntries checkEntryPortability . decodeLongNames
+
+-- |
+-- @since 0.6.0.0
+checkEntryPortability :: GenEntry FilePath linkTarget -> Maybe PortabilityError
+checkEntryPortability entry
   | entryFormat entry `elem` [V7Format, GnuFormat]
-  = throwM $ NonPortableFormat (entryFormat entry)
+  = Just $ NonPortableFormat (entryFormat entry)
 
   | not (portableFileType (entryContent entry))
-  = throwM NonPortableFileType
+  = Just NonPortableFileType
 
   | not (all portableChar posixPath)
-  = throwM $ NonPortableEntryNameChar posixPath
+  = Just $ NonPortableEntryNameChar posixPath
 
   | not (FilePath.Posix.isValid posixPath)
-  = throwM $ NonPortableFileName "unix"    (InvalidFileName posixPath)
+  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)
   | not (FilePath.Windows.isValid windowsPath)
-  = throwM $ NonPortableFileName "windows" (InvalidFileName windowsPath)
+  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)
 
   | FilePath.Posix.isAbsolute posixPath
-  = throwM $ NonPortableFileName "unix"    (AbsoluteFileName posixPath)
+  = Just $ NonPortableFileName "unix"    (AbsoluteFileName posixPath)
   | FilePath.Windows.isAbsolute windowsPath
-  = throwM $ NonPortableFileName "windows" (AbsoluteFileName windowsPath)
+  = Just $ NonPortableFileName "windows" (AbsoluteFileName windowsPath)
 
   | any (=="..") (FilePath.Posix.splitDirectories posixPath)
-  = throwM $ NonPortableFileName "unix"    (InvalidFileName posixPath)
+  = Just $ NonPortableFileName "unix"    (InvalidFileName posixPath)
   | any (=="..") (FilePath.Windows.splitDirectories windowsPath)
-  = throwM $ NonPortableFileName "windows" (InvalidFileName windowsPath)
+  = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath)
 
-  | otherwise = pure ()
+  | otherwise = Nothing
 
   where
     posixPath   = entryTarPath entry
@@ -259,3 +287,10 @@ instance Show PortabilityError where
     = "Non-portable character in archive entry name: " ++ show posixPath
   show (NonPortableFileName platform err)
     = showFileNameError (Just platform) err
+
+--------------------------
+-- Utils
+
+checkEntries :: (GenEntry a b -> Maybe e') -> GenEntries a b e -> GenEntries a b (Either e e')
+checkEntries checkEntry =
+  mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))

Codec/Archive/Tar/Pack.hs

@@ -48,7 +48,7 @@ import System.IO
          ( IOMode(ReadMode), openBinaryFile, hFileSize )
 import System.IO.Unsafe (unsafeInterleaveIO)
 import Control.Exception (throwIO, SomeException)
-import Codec.Archive.Tar.Check.Internal (checkSecurity)
+import Codec.Archive.Tar.Check.Internal (checkEntrySecurity)
 
 -- | Creates a tar archive from a list of directory or files. Any directories
 -- specified will have their contents included recursively. Paths in the
@@ -69,21 +69,21 @@ pack
   :: FilePath   -- ^ Base directory
   -> [FilePath] -- ^ Files and directories to pack, relative to the base dir
   -> IO [Entry]
-pack = packAndCheck (const $ pure ())
+pack = packAndCheck (const Nothing)
 
 -- | Like 'pack', but allows to specify any sanity/security checks on the input
 -- filenames.
 --
 -- @since 0.6.0.0
 packAndCheck
-  :: CheckSecurityCallback
+  :: (GenEntry FilePath FilePath -> Maybe SomeException)
   -> FilePath   -- ^ Base directory
   -> [FilePath] -- ^ Files and directories to pack, relative to the base dir
   -> IO [Entry]
 packAndCheck secCB baseDir relpaths = do
   paths <- preparePaths baseDir relpaths
   entries <- packPaths baseDir paths
-  traverse_ secCB entries
+  traverse_ (maybe (pure ()) throwIO . secCB) entries
   pure $ concatMap encodeLongNames entries
 
 preparePaths :: FilePath -> [FilePath] -> IO [FilePath]

Codec/Archive/Tar/Types.hs

@@ -29,7 +29,6 @@ module Codec.Archive.Tar.Types (
   DevMajor,
   DevMinor,
   Format(..),
-  CheckSecurityCallback,
 
   simpleEntry,
   longLinkEntry,
@@ -353,7 +352,7 @@ instance Show TarPath where
 --
 -- * The tar path may be an absolute path or may contain @\"..\"@ components.
 --   For security reasons this should not usually be allowed, but it is your
---   responsibility to check for these conditions (eg using 'checkSecurity').
+--   responsibility to check for these conditions (eg using 'checkEntrySecurity').
 --
 fromTarPath :: TarPath -> FilePath
 fromTarPath = BS.Char8.unpack . fromTarPathInternal FilePath.Native.pathSeparator
@@ -611,7 +610,7 @@ foldEntries next done fail' = fold
 -- value.
 --
 foldlEntries :: (a -> Entry -> a) -> a -> Entries e -> Either (e, a) a
-foldlEntries f z = go z
+foldlEntries f = go
   where
     go !acc (Next e es) = go (f acc e) es
     go !acc  Done       = Right acc
@@ -622,15 +621,18 @@ foldlEntries f z = go z
 --
 -- If your mapping function cannot fail it may be more convenient to use
 -- 'mapEntriesNoFail'
-mapEntries :: (Entry -> Either e' Entry) -> Entries e -> Entries (Either e e')
+mapEntries
+  :: (GenEntry tarPath linkTarget -> Either e' (GenEntry tarPath linkTarget))
+  -> GenEntries tarPath linkTarget e
+  -> GenEntries tarPath linkTarget (Either e e')
 mapEntries f =
-  foldEntries (\entry rest -> either (Fail . Right) (flip Next rest) (f entry)) Done (Fail . Left)
+  foldEntries (\entry rest -> either (Fail . Right) (`Next` rest) (f entry)) Done (Fail . Left)
 
 -- | Like 'mapEntries' but the mapping function itself cannot fail.
 --
 mapEntriesNoFail :: (Entry -> Entry) -> Entries e -> Entries e
 mapEntriesNoFail f =
-  foldEntries (\entry -> Next (f entry)) Done Fail
+  foldEntries (Next . f) Done Fail
 
 -- | @since 0.5.1.0
 instance Sem.Semigroup (GenEntries tarPath linkTarget e) where
@@ -644,10 +646,3 @@ instance NFData e => NFData (GenEntries tarPath linkTarget e) where
   rnf (Next e es) = rnf e `seq` rnf es
   rnf  Done       = ()
   rnf (Fail e)    = rnf e
-
--- | @since 0.6.0.0
-type CheckSecurityCallback =
-  forall m.
-     MonadThrow m
-  => GenEntry FilePath FilePath
-  -> m ()

Codec/Archive/Tar/Unpack.hs

@@ -2,6 +2,10 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE RankNTypes #-}
+
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use for_" #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Codec.Archive.Tar
@@ -16,7 +20,7 @@
 -----------------------------------------------------------------------------
 module Codec.Archive.Tar.Unpack (
   unpack,
-  unpackWith,
+  unpackAndCheck,
   ) where
 
 import Codec.Archive.Tar.Types
@@ -57,9 +61,7 @@ import GHC.IO.Exception (IOErrorType(InappropriateType, IllegalOperation, Permis
 import Data.Time.Clock.POSIX
          ( posixSecondsToUTCTime )
 import Control.Exception as Exception
-         ( catch )
-
-
+         ( catch, SomeException(..) )
 
 -- | Create local files and directories based on the entries of a tar archive.
 --
@@ -76,18 +78,23 @@ import Control.Exception as Exception
 -- into an empty directory so that you can easily clean up if unpacking fails
 -- part-way.
 --
--- On its own, this function only checks for security (using 'checkSecurity').
--- Use 'unpackWith' if you need more checks.
+-- On its own, this function only checks for security (using 'checkEntrySecurity').
+-- Use 'unpackAndCheck' if you need more checks.
 --
 unpack :: Exception e => FilePath -> Entries e -> IO ()
-unpack = unpackWith checkSecurity
+unpack = unpackAndCheck (fmap SomeException . checkEntrySecurity)
 
 -- | Like 'unpack', but does not perform any sanity/security checks on the tar entries.
--- You can do so yourself, e.g.: @unpackRaw@ 'checkSecurity' @dir@ @entries@.
+-- You can do so yourself, e.g.: @unpackRaw@ 'checkEntrySecurity' @dir@ @entries@.
 --
 -- @since 0.6.0.0
-unpackWith :: Exception e => CheckSecurityCallback -> FilePath -> Entries e -> IO ()
-unpackWith secCB baseDir entries = do
+unpackAndCheck
+  :: Exception e
+  => (GenEntry FilePath FilePath -> Maybe SomeException)
+  -> FilePath
+  -> Entries e
+  -> IO ()
+unpackAndCheck secCB baseDir entries = do
   let resolvedEntries = decodeLongNames entries
   uEntries <- unpackEntries [] resolvedEntries
   let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries
@@ -108,7 +115,10 @@ unpackWith secCB baseDir entries = do
     unpackEntries _     (Fail err)      = either throwIO throwIO err
     unpackEntries links Done            = return links
     unpackEntries links (Next entry es) = do
-      secCB entry
+      case secCB entry of
+        Nothing -> pure ()
+        Just e -> throwIO e
+
       case entryContent entry of
         NormalFile file _ -> do
           extractFile (entryPermissions entry) (entryTarPath entry) file (entryTime entry)

changelog.md

@@ -18,7 +18,7 @@ See also http://pvp.haskell.org/faq
   * Switch to trailer parsing mode only after a full block of `NUL`
   * Drop deprecated `emptyIndex` and `finaliseIndex`
   * Extend `FileNameError` with `UnsafeLinkTarget` constructor
-  * Add `CheckSecurityCallback`, `packWith`, `unpackWith`
+  * Add `packAndCheck` and `unpackAndCheck`
   * Generalize `Entries`, `Entry` and `EntryContent` to `GenEntries`, `GenEntry` and `GenEntryContent`
 
 0.5.1.1 Herbert Valerio Riedel <[email protected]> August 2019