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

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

import Control.DeepSeq                  (NFData)
import Control.Monad.Except             (MonadError)
import Data.Generics.Product.Any        (HasAny(the))
import HaskellWorks.Prelude
import Lens.Micro

import qualified Control.Monad.Oops as OO
import qualified System.Exit        as IO
import qualified System.Process     as IO

data ArchiveError = ArchiveError Text deriving (ArchiveError -> ArchiveError -> Bool
(ArchiveError -> ArchiveError -> Bool)
-> (ArchiveError -> ArchiveError -> Bool) -> Eq ArchiveError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArchiveError -> ArchiveError -> Bool
== :: ArchiveError -> ArchiveError -> Bool
$c/= :: ArchiveError -> ArchiveError -> Bool
/= :: ArchiveError -> ArchiveError -> Bool
Eq, Int -> ArchiveError -> ShowS
[ArchiveError] -> ShowS
ArchiveError -> String
(Int -> ArchiveError -> ShowS)
-> (ArchiveError -> String)
-> ([ArchiveError] -> ShowS)
-> Show ArchiveError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArchiveError -> ShowS
showsPrec :: Int -> ArchiveError -> ShowS
$cshow :: ArchiveError -> String
show :: ArchiveError -> String
$cshowList :: [ArchiveError] -> ShowS
showList :: [ArchiveError] -> ShowS
Show, (forall x. ArchiveError -> Rep ArchiveError x)
-> (forall x. Rep ArchiveError x -> ArchiveError)
-> Generic ArchiveError
forall x. Rep ArchiveError x -> ArchiveError
forall x. ArchiveError -> Rep ArchiveError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ArchiveError -> Rep ArchiveError x
from :: forall x. ArchiveError -> Rep ArchiveError x
$cto :: forall x. Rep ArchiveError x -> ArchiveError
to :: forall x. Rep ArchiveError x -> ArchiveError
Generic)

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

createTar :: ()
  => MonadIO m
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` ArchiveError
  => Foldable t
  => [Char]
  -> t TarGroup
  -> m ()
createTar :: forall (m :: * -> *) (e :: [*]) (t :: * -> *).
(MonadIO m, MonadError (Variant e) m, CouldBe e ArchiveError,
 Foldable t) =>
String -> t TarGroup -> m ()
createTar String
tarFile t TarGroup
groups = do
  let args :: [String]
args = [String
"-zcf", String
tarFile] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (TarGroup -> [String]) -> t TarGroup -> [String]
forall m a. Monoid m => (a -> m) -> t a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TarGroup -> [String]
tarGroupToArgs t TarGroup
groups
  ProcessHandle
process <- IO ProcessHandle -> m ProcessHandle
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> m ProcessHandle)
-> IO ProcessHandle -> m ProcessHandle
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ProcessHandle
IO.spawnProcess String
"tar" [String]
args
  ExitCode
exitCode <- IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
process
  case ExitCode
exitCode of
    ExitCode
IO.ExitSuccess   -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO.ExitFailure Int
n -> ArchiveError -> m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (ArchiveError -> m ()) -> ArchiveError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ArchiveError
ArchiveError (Text -> ArchiveError) -> Text -> ArchiveError
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
  => MonadError (OO.Variant e) m
  => e `OO.CouldBe` ArchiveError
  => String
  -> String
  -> m ()
extractTar :: forall (m :: * -> *) (e :: [*]).
(MonadIO m, MonadError (Variant e) m, CouldBe e ArchiveError) =>
String -> String -> m ()
extractTar String
tarFile String
targetPath = do
  ProcessHandle
process <- IO ProcessHandle -> m ProcessHandle
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessHandle -> m ProcessHandle)
-> IO ProcessHandle -> m ProcessHandle
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IO ProcessHandle
IO.spawnProcess String
"tar" [String
"-C", String
targetPath, String
"-zxf", String
tarFile]
  ExitCode
exitCode <- IO ExitCode -> m ExitCode
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExitCode -> m ExitCode) -> IO ExitCode -> m ExitCode
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
IO.waitForProcess ProcessHandle
process
  case ExitCode
exitCode of
    ExitCode
IO.ExitSuccess   -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    IO.ExitFailure Int
n -> ArchiveError -> m ()
forall x (e :: [*]) (m :: * -> *) a.
(MonadError (Variant e) m, CouldBe e x) =>
x -> m a
OO.throw (ArchiveError -> m ()) -> ArchiveError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> ArchiveError
ArchiveError (Text -> ArchiveError) -> Text -> ArchiveError
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 -> [String]
tarGroupToArgs TarGroup
tarGroup = [String
"-C", TarGroup
tarGroup TarGroup -> Getting String TarGroup String -> String
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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"basePath"] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> TarGroup
tarGroup TarGroup -> Getting [String] TarGroup [String] -> [String]
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 (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"entryPaths"