{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar
-- Copyright   :  (c) 2007 Bjorn Bringert,
--                    2008 Andrea Vezzosi,
--                    2008-2009, 2012, 2016 Duncan Coutts
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Codec.Archive.Tar.Unpack (
  unpack,
  ) where

import Codec.Archive.Tar.Types
import Codec.Archive.Tar.Check

import qualified Data.ByteString.Lazy as BS
import System.FilePath
         ( (</>) )
import qualified System.FilePath as FilePath.Native
         ( takeDirectory )
import System.Directory
         ( createDirectoryIfMissing, copyFile )
import Control.Exception
         ( Exception, throwIO )
#if MIN_VERSION_directory(1,2,3)
import System.Directory
         ( setModificationTime )
import Data.Time.Clock.POSIX
         ( posixSecondsToUTCTime )
import Control.Exception as Exception
         ( catch )
import System.IO.Error
         ( isPermissionError )
#endif


-- | Create local files and directories based on the entries of a tar archive.
--
-- This is a portable implementation of unpacking suitable for portable
-- archives. It handles 'NormalFile' and 'Directory' entries and has simulated
-- support for 'SymbolicLink' and 'HardLink' entries. Links are implemented by
-- copying the target file. This therefore works on Windows as well as Unix.
-- All other entry types are ignored, that is they are not unpacked and no
-- exception is raised.
--
-- If the 'Entries' ends in an error then it is raised an an exception. Any
-- files or directories that have been unpacked before the error was
-- encountered will not be deleted. For this reason you may want to unpack
-- 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').
-- You can do other checks by applying checking functions to the 'Entries' that
-- you pass to this function. For example:
--
-- > unpack dir (checkTarbomb expectedDir entries)
--
-- If you care about the priority of the reported errors then you may want to
-- use 'checkSecurity' before 'checkTarbomb' or other checks.
--
unpack :: Exception e => FilePath -> Entries e -> IO ()
unpack :: FilePath -> Entries e -> IO ()
unpack FilePath
baseDir Entries e
entries = [(FilePath, FilePath)]
-> Entries (Either e FileNameError) -> IO [(FilePath, FilePath)]
forall e e.
(Exception e, Exception e) =>
[(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries [] (Entries e -> Entries (Either e FileNameError)
forall e. Entries e -> Entries (Either e FileNameError)
checkSecurity Entries e
entries)
                     IO [(FilePath, FilePath)]
-> ([(FilePath, FilePath)] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(FilePath, FilePath)] -> IO ()
emulateLinks

  where
    -- We're relying here on 'checkSecurity' to make sure we're not scribbling
    -- files all over the place.

    unpackEntries :: [(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries [(FilePath, FilePath)]
_     (Fail Either e e
err)      = (e -> IO [(FilePath, FilePath)])
-> (e -> IO [(FilePath, FilePath)])
-> Either e e
-> IO [(FilePath, FilePath)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> IO [(FilePath, FilePath)]
forall e a. Exception e => e -> IO a
throwIO e -> IO [(FilePath, FilePath)]
forall e a. Exception e => e -> IO a
throwIO Either e e
err
    unpackEntries [(FilePath, FilePath)]
links Entries (Either e e)
Done            = [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
links
    unpackEntries [(FilePath, FilePath)]
links (Next Entry
entry Entries (Either e e)
es) = case Entry -> EntryContent
entryContent Entry
entry of
      NormalFile ByteString
file FileSize
_ -> FilePath -> ByteString -> FileSize -> IO ()
extractFile FilePath
path ByteString
file FileSize
mtime
                        IO () -> IO [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries [(FilePath, FilePath)]
links Entries (Either e e)
es
      EntryContent
Directory         -> FilePath -> FileSize -> IO ()
extractDir FilePath
path FileSize
mtime
                        IO () -> IO [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries [(FilePath, FilePath)]
links Entries (Either e e)
es
      HardLink     LinkTarget
link -> ([(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries ([(FilePath, FilePath)]
 -> Entries (Either e e) -> IO [(FilePath, FilePath)])
-> [(FilePath, FilePath)]
-> Entries (Either e e)
-> IO [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$! FilePath
-> LinkTarget -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall (t :: * -> *) a.
Foldable t =>
t a -> LinkTarget -> [(t a, FilePath)] -> [(t a, FilePath)]
saveLink FilePath
path LinkTarget
link [(FilePath, FilePath)]
links) Entries (Either e e)
es
      SymbolicLink LinkTarget
link -> ([(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries ([(FilePath, FilePath)]
 -> Entries (Either e e) -> IO [(FilePath, FilePath)])
-> [(FilePath, FilePath)]
-> Entries (Either e e)
-> IO [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$! FilePath
-> LinkTarget -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall (t :: * -> *) a.
Foldable t =>
t a -> LinkTarget -> [(t a, FilePath)] -> [(t a, FilePath)]
saveLink FilePath
path LinkTarget
link [(FilePath, FilePath)]
links) Entries (Either e e)
es
      EntryContent
_                 -> [(FilePath, FilePath)]
-> Entries (Either e e) -> IO [(FilePath, FilePath)]
unpackEntries [(FilePath, FilePath)]
links Entries (Either e e)
es --ignore other file types
      where
        path :: FilePath
path  = Entry -> FilePath
entryPath Entry
entry
        mtime :: FileSize
mtime = Entry -> FileSize
entryTime Entry
entry

    extractFile :: FilePath -> ByteString -> FileSize -> IO ()
extractFile FilePath
path ByteString
content FileSize
mtime = do
      -- Note that tar archives do not make sure each directory is created
      -- before files they contain, indeed we may have to create several
      -- levels of directory.
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
absDir
      FilePath -> ByteString -> IO ()
BS.writeFile FilePath
absPath ByteString
content
      FilePath -> FileSize -> IO ()
setModTime FilePath
absPath FileSize
mtime
      where
        absDir :: FilePath
absDir  = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
FilePath.Native.takeDirectory FilePath
path
        absPath :: FilePath
absPath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
path

    extractDir :: FilePath -> FileSize -> IO ()
extractDir FilePath
path FileSize
mtime = do
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
absPath
      FilePath -> FileSize -> IO ()
setModTime FilePath
absPath FileSize
mtime
      where
        absPath :: FilePath
absPath = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
path

    saveLink :: t a -> LinkTarget -> [(t a, FilePath)] -> [(t a, FilePath)]
saveLink t a
path LinkTarget
link [(t a, FilePath)]
links = Int -> [(t a, FilePath)] -> [(t a, FilePath)]
seq (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
path)
                             ([(t a, FilePath)] -> [(t a, FilePath)])
-> [(t a, FilePath)] -> [(t a, FilePath)]
forall a b. (a -> b) -> a -> b
$ Int -> [(t a, FilePath)] -> [(t a, FilePath)]
seq (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
link')
                             ([(t a, FilePath)] -> [(t a, FilePath)])
-> [(t a, FilePath)] -> [(t a, FilePath)]
forall a b. (a -> b) -> a -> b
$ (t a
path, FilePath
link')(t a, FilePath) -> [(t a, FilePath)] -> [(t a, FilePath)]
forall a. a -> [a] -> [a]
:[(t a, FilePath)]
links
      where link' :: FilePath
link' = LinkTarget -> FilePath
fromLinkTarget LinkTarget
link

    emulateLinks :: [(FilePath, FilePath)] -> IO ()
emulateLinks = ((FilePath, FilePath) -> IO ()) -> [(FilePath, FilePath)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (((FilePath, FilePath) -> IO ())
 -> [(FilePath, FilePath)] -> IO ())
-> ((FilePath, FilePath) -> IO ())
-> [(FilePath, FilePath)]
-> IO ()
forall a b. (a -> b) -> a -> b
$ \(FilePath
relPath, FilePath
relLinkTarget) ->
      let absPath :: FilePath
absPath   = FilePath
baseDir FilePath -> FilePath -> FilePath
</> FilePath
relPath
          absTarget :: FilePath
absTarget = FilePath -> FilePath
FilePath.Native.takeDirectory FilePath
absPath FilePath -> FilePath -> FilePath
</> FilePath
relLinkTarget
       in FilePath -> FilePath -> IO ()
copyFile FilePath
absTarget FilePath
absPath

setModTime :: FilePath -> EpochTime -> IO ()
#if MIN_VERSION_directory(1,2,3)
-- functionality only supported as of directory-1.2.3.x
setModTime :: FilePath -> FileSize -> IO ()
setModTime FilePath
path FileSize
t =
    FilePath -> UTCTime -> IO ()
setModificationTime FilePath
path (POSIXTime -> UTCTime
posixSecondsToUTCTime (FileSize -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileSize
t))
      IO () -> (IOError -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \IOError
e ->
        if IOError -> Bool
isPermissionError IOError
e then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else IOError -> IO ()
forall e a. Exception e => e -> IO a
throwIO IOError
e
#else
setModTime _path _t = return ()
#endif