IO.hs

-- | IO utilities
{-# LANGUAGE CPP #-}
module Hackage.Security.RepoTool.Util.IO (
    -- * Miscellaneous
    compress
  , getFileModTime
#ifndef mingw32_HOST_OS
  , createSymbolicLink
#endif
    -- * Tar archives
  , TarGzError
  , tarExtractFile
  ) where

import qualified Codec.Archive.Tar                 as Tar
import qualified Codec.Archive.Tar.Entry           as Tar
import qualified Codec.Compression.GZip            as GZip
import           Control.Exception
import qualified Data.ByteString.Lazy              as BS.L
import qualified System.Directory                  as Directory
import           System.IO.Error

-- hackage-security
import           Hackage.Security.Util.Path

-- hackage-repo-tool
import           Hackage.Security.RepoTool.Layout
import           Hackage.Security.RepoTool.Options
import           Hackage.Security.RepoTool.Paths

import           System.Posix.Types                (EpochTime)
#ifndef mingw32_HOST_OS
import qualified System.Posix.Files                as Posix
#endif

import           Data.Time.Clock.POSIX             (utcTimeToPOSIXSeconds)

-- | Get the modification time of the specified file
--
-- Returns 0 if the file does not exist .
getFileModTime :: GlobalOpts -> RepoLoc -> TargetPath' -> IO EpochTime
getFileModTime opts repoLoc targetPath =
    handle handler $
      -- Underlying implementation of 'Directory.getModificationTime' converts
      -- from POSIX seconds, so there shouldn't be loss of precision.
      -- NB: Apparently, this has low clock resolution on GHC < 7.8.
      -- I don't think we care.
      fromInteger . floor . utcTimeToPOSIXSeconds
        <$> Directory.getModificationTime (toFilePath fp)
  where
    fp :: Path Absolute
    fp = anchorTargetPath' opts repoLoc targetPath

    handler :: IOException -> IO EpochTime
    handler ex = if isDoesNotExistError ex then return 0
                                           else throwIO ex

compress :: Path Absolute -> Path Absolute -> IO ()
compress src dst =
    withFile dst WriteMode $ \h ->
      BS.L.hPut h =<< GZip.compress <$> readLazyByteString src

#ifndef mingw32_HOST_OS
-- | Create a symbolic link (unix only)
--
-- Create the directory for the target if it does not exist.
--
-- TODO: Currently this always creates links to absolute locations, whether the
-- user specified an absolute or a relative target.
createSymbolicLink :: (FsRoot root, FsRoot root')
                   => Path root  -- ^ Link target
                   -> Path root' -- ^ Link location
                   -> IO ()
createSymbolicLink linkTarget linkLoc = do
    createDirectoryIfMissing True (takeDirectory linkLoc)
    linkTarget' <- toAbsoluteFilePath linkTarget
    linkLoc'    <- toAbsoluteFilePath linkLoc
    Posix.createSymbolicLink linkTarget' linkLoc'
#endif

{-------------------------------------------------------------------------------
  Working with tar archives
-------------------------------------------------------------------------------}

-- | Extract a file from a tar archive
--
-- Throws an exception if there is an error in the archive or when the entry
-- is not a file. Returns nothing if the entry cannot be found.
tarExtractFile :: GlobalOpts
               -> RepoLoc
               -> TargetPath'
               -> FilePath
               -> IO (Maybe (BS.L.ByteString, Tar.FileSize))
tarExtractFile opts repoLoc pathTarGz pathToExtract =
     handle (throwIO . TarGzError (prettyTargetPath' opts pathTarGz)) $ do
       let pathTarGz' = anchorTargetPath' opts repoLoc pathTarGz
       go =<< Tar.read . GZip.decompress <$> readLazyByteString pathTarGz'
  where
    go :: Exception e => Tar.Entries e -> IO (Maybe (BS.L.ByteString, Tar.FileSize))
    go Tar.Done        = return Nothing
    go (Tar.Fail err)  = throwIO err
    go (Tar.Next e es) =
      if Tar.entryPath e == pathToExtract
        then case Tar.entryContent e of
               Tar.NormalFile bs sz -> return $ Just (bs, sz)
               _ -> throwIO $ userError
                            $ "tarExtractFile: "
                           ++ pathToExtract ++ " not a normal file"
        else do -- putStrLn $ show (Tar.entryPath e) ++ " /= " ++ show path
                go es

data TarGzError = TarGzError FilePath SomeException

instance Exception TarGzError where
  displayException (TarGzError path e) = path ++ ": " ++ displayException e

deriving instance Show TarGzError