{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

module HaskellWorks.CabalCache.IO.Tar
  ( TarGroup(..)
  , createTar
  , extractTar
  ) where

import Control.DeepSeq                  (NFData)
import Control.Lens
import Control.Monad.Except
import Data.Generics.Product.Any
import GHC.Generics
import HaskellWorks.CabalCache.AppError
import HaskellWorks.CabalCache.Show

import qualified System.Exit    as IO
import qualified System.Process as IO

data TarGroup = TarGroup
  { TarGroup -> FilePath
basePath   :: FilePath
  , TarGroup -> [FilePath]
entryPaths :: [FilePath]
  } deriving (Int -> TarGroup -> ShowS
[TarGroup] -> ShowS
TarGroup -> FilePath
(Int -> TarGroup -> ShowS)
-> (TarGroup -> FilePath) -> ([TarGroup] -> ShowS) -> Show TarGroup
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TarGroup] -> ShowS
$cshowList :: [TarGroup] -> ShowS
show :: TarGroup -> FilePath
$cshow :: TarGroup -> FilePath
showsPrec :: Int -> TarGroup -> ShowS
$cshowsPrec :: Int -> TarGroup -> ShowS
Show, TarGroup -> TarGroup -> Bool
(TarGroup -> TarGroup -> Bool)
-> (TarGroup -> TarGroup -> Bool) -> Eq TarGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TarGroup -> TarGroup -> Bool
$c/= :: TarGroup -> TarGroup -> Bool
== :: TarGroup -> TarGroup -> Bool
$c== :: TarGroup -> TarGroup -> Bool
Eq, (forall x. TarGroup -> Rep TarGroup x)
-> (forall x. Rep TarGroup x -> TarGroup) -> Generic TarGroup
forall x. Rep TarGroup x -> TarGroup
forall x. TarGroup -> Rep TarGroup x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TarGroup x -> TarGroup
$cfrom :: forall x. TarGroup -> Rep TarGroup x
Generic, TarGroup -> ()
(TarGroup -> ()) -> NFData TarGroup
forall a. (a -> ()) -> NFData a
rnf :: TarGroup -> ()
$crnf :: TarGroup -> ()
NFData)

createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT AppError m ()
createTar :: FilePath -> [TarGroup] -> ExceptT AppError m ()
createTar FilePath
tarFile [TarGroup]
groups = do
  let args :: [FilePath]
args = [FilePath
"-zcf", FilePath
tarFile] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> (TarGroup -> [FilePath]) -> [TarGroup] -> [FilePath]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TarGroup -> [FilePath]
tarGroupToArgs [TarGroup]
groups
  ProcessHandle
process <- IO ProcessHandle -> ExceptT AppError m ProcessHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> ExceptT AppError m ProcessHandle)
-> IO ProcessHandle -> ExceptT AppError m ProcessHandle
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ProcessHandle
IO.spawnProcess FilePath
"tar" [FilePath]
args
  ExitCode
exitCode <- IO ExitCode -> ExceptT AppError m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> ExceptT AppError m ExitCode)
-> IO ExitCode -> ExceptT AppError m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
process
  case ExitCode
exitCode of
    ExitCode
IO.ExitSuccess   -> () -> ExceptT AppError m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO.ExitFailure Int
n -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AppError -> ExceptT AppError m ())
-> AppError -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ Text -> AppError
GenericAppError (Text -> AppError) -> Text -> AppError
forall a b. (a -> b) -> a -> b
$ Text
"Failed to create tar. Exit code: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n

extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT AppError m ()
extractTar :: FilePath -> FilePath -> ExceptT AppError m ()
extractTar FilePath
tarFile FilePath
targetPath = do
  ProcessHandle
process <- IO ProcessHandle -> ExceptT AppError m ProcessHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> ExceptT AppError m ProcessHandle)
-> IO ProcessHandle -> ExceptT AppError m ProcessHandle
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> IO ProcessHandle
IO.spawnProcess FilePath
"tar" [FilePath
"-C", FilePath
targetPath, FilePath
"-zxf", FilePath
tarFile]
  ExitCode
exitCode <- IO ExitCode -> ExceptT AppError m ExitCode
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> ExceptT AppError m ExitCode)
-> IO ExitCode -> ExceptT AppError m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
process
  case ExitCode
exitCode of
    ExitCode
IO.ExitSuccess   -> () -> ExceptT AppError m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO.ExitFailure Int
n -> AppError -> ExceptT AppError m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (AppError -> ExceptT AppError m ())
-> AppError -> ExceptT AppError m ()
forall a b. (a -> b) -> a -> b
$ Text -> AppError
GenericAppError (Text -> AppError) -> Text -> AppError
forall a b. (a -> b) -> a -> b
$ Text
"Failed to extract tar.  Exit code: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
n

tarGroupToArgs :: TarGroup -> [String]
tarGroupToArgs :: TarGroup -> [FilePath]
tarGroupToArgs TarGroup
tarGroup = [FilePath
"-C", TarGroup
tarGroup TarGroup -> Getting FilePath TarGroup FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "basePath" s t a b => Lens s t a b
the @"basePath"] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> TarGroup
tarGroup TarGroup -> Getting [FilePath] TarGroup [FilePath] -> [FilePath]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "entryPaths" s t a b => Lens s t a b
the @"entryPaths"