{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module App.Commands.SyncToArchive
  ( cmdSyncToArchive
  ) where

import Antiope.Core                     (Region (..), toText)
import Antiope.Env                      (mkEnv)
import Antiope.Options.Applicative
import App.Commands.Options.Parser      (text)
import App.Commands.Options.Types       (SyncToArchiveOptions (SyncToArchiveOptions))
import Control.Applicative
import Control.Lens                     hiding ((<.>))
import Control.Monad.Except
import Control.Monad.Trans.Resource     (runResourceT)
import Data.Generics.Product.Any        (the)
import Data.List                        ((\\))
import Data.Maybe
import HaskellWorks.CabalCache.AppError
import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>))
import HaskellWorks.CabalCache.Metadata (createMetadata)
import HaskellWorks.CabalCache.Show
import HaskellWorks.CabalCache.Topology (buildPlanData, canShare)
import HaskellWorks.CabalCache.Version  (archiveVersion)
import Options.Applicative              hiding (columns)
import System.Directory                 (doesDirectoryExist)

import qualified App.Commands.Options.Types         as Z
import qualified App.Static                         as AS
import qualified Control.Concurrent.STM             as STM
import qualified Data.ByteString.Lazy               as LBS
import qualified Data.ByteString.Lazy.Char8         as LC8
import qualified Data.Text                          as Text
import qualified Data.Text                          as T
import qualified HaskellWorks.CabalCache.AWS.Env    as AWS
import qualified HaskellWorks.CabalCache.Core       as Z
import qualified HaskellWorks.CabalCache.GhcPkg     as GhcPkg
import qualified HaskellWorks.CabalCache.Hash       as H
import qualified HaskellWorks.CabalCache.IO.Console as CIO
import qualified HaskellWorks.CabalCache.IO.Error   as IO
import qualified HaskellWorks.CabalCache.IO.File    as IO
import qualified HaskellWorks.CabalCache.IO.Lazy    as IO
import qualified HaskellWorks.CabalCache.IO.Tar     as IO
import qualified Network.HTTP.Types                 as HTTP
import qualified System.Directory                   as IO
import qualified System.IO                          as IO
import qualified System.IO.Temp                     as IO
import qualified System.IO.Unsafe                   as IO
import qualified UnliftIO.Async                     as IO

{- HLINT ignore "Monoid law, left identity" -}
{- HLINT ignore "Redundant do"              -}
{- HLINT ignore "Reduce duplication"        -}

runSyncToArchive :: Z.SyncToArchiveOptions -> IO ()
runSyncToArchive :: SyncToArchiveOptions -> IO ()
runSyncToArchive SyncToArchiveOptions
opts = do
  let storePath :: [Char]
storePath           = SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting [Char] SyncToArchiveOptions [Char] -> [Char]
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 "storePath" s t a b => Lens s t a b
the @"storePath"
  let archiveUri :: Location
archiveUri          = SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting Location SyncToArchiveOptions Location -> Location
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 "archiveUri" s t a b => Lens s t a b
the @"archiveUri"
  let threads :: Int
threads             = SyncToArchiveOptions
opts SyncToArchiveOptions -> Getting Int SyncToArchiveOptions Int -> Int
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 "threads" s t a b => Lens s t a b
the @"threads"
  let awsLogLevel :: Maybe LogLevel
awsLogLevel         = SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting (Maybe LogLevel) SyncToArchiveOptions (Maybe LogLevel)
-> Maybe LogLevel
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 "awsLogLevel" s t a b => Lens s t a b
the @"awsLogLevel"
  let versionedArchiveUri :: Location
versionedArchiveUri = Location
archiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> Text
forall s. IsString s => s
archiveVersion
  let storePathHash :: [Char]
storePathHash       = SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting (Maybe [Char]) SyncToArchiveOptions (Maybe [Char])
-> Maybe [Char]
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 "storePathHash" s t a b => Lens s t a b
the @"storePathHash" Maybe [Char] -> (Maybe [Char] -> [Char]) -> [Char]
forall a b. a -> (a -> b) -> b
& [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
H.hashStorePath [Char]
storePath)
  let scopedArchiveUri :: Location
scopedArchiveUri    = Location
versionedArchiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
storePathHash

  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Store path: "       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. ToText a => a -> Text
toText [Char]
storePath
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Store path hash: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
storePathHash
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Archive URI: "      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Location -> Text
forall a. ToText a => a -> Text
toText Location
archiveUri
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Archive version: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall s. IsString s => s
archiveVersion
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Threads: "          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
threads
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"AWS Log level: "    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe LogLevel -> Text
forall a. Show a => a -> Text
tshow Maybe LogLevel
awsLogLevel

  TVar Bool
tEarlyExit <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
STM.newTVarIO Bool
False

  Either AppError PlanJson
mbPlan <- [Char] -> IO (Either AppError PlanJson)
Z.loadPlan ([Char] -> IO (Either AppError PlanJson))
-> [Char] -> IO (Either AppError PlanJson)
forall a b. (a -> b) -> a -> b
$ SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting [Char] SyncToArchiveOptions [Char] -> [Char]
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 "buildPath" s t a b => Lens s t a b
the @"buildPath"

  case Either AppError PlanJson
mbPlan of
    Right PlanJson
planJson -> do
      Either Text CompilerContext
compilerContextResult <- ExceptT Text IO CompilerContext -> IO (Either Text CompilerContext)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO CompilerContext
 -> IO (Either Text CompilerContext))
-> ExceptT Text IO CompilerContext
-> IO (Either Text CompilerContext)
forall a b. (a -> b) -> a -> b
$ PlanJson -> ExceptT Text IO CompilerContext
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PlanJson -> ExceptT Text m CompilerContext
Z.mkCompilerContext PlanJson
planJson

      case Either Text CompilerContext
compilerContextResult of
        Right CompilerContext
compilerContext -> do
          let compilerId :: Text
compilerId = PlanJson
planJson PlanJson -> Getting Text PlanJson Text -> Text
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 "compilerId" s t a b => Lens s t a b
the @"compilerId"
          Env
envAws <- IO Env -> IO Env
forall a. IO a -> IO a
IO.unsafeInterleaveIO (IO Env -> IO Env) -> IO Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Region -> (LogLevel -> ByteString -> IO ()) -> IO Env
mkEnv (SyncToArchiveOptions
opts SyncToArchiveOptions
-> Getting Region SyncToArchiveOptions Region -> Region
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 "region" s t a b => Lens s t a b
the @"region") (Maybe LogLevel -> LogLevel -> ByteString -> IO ()
AWS.awsLogger Maybe LogLevel
awsLogLevel)
          let archivePath :: Location
archivePath       = Location
versionedArchiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> Text
compilerId
          let scopedArchivePath :: Location
scopedArchivePath = Location
scopedArchiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> Text
compilerId
          Location -> IO ()
forall (m :: * -> *). (MonadCatch m, MonadIO m) => Location -> m ()
IO.createLocalDirectoryIfMissing Location
archivePath
          Location -> IO ()
forall (m :: * -> *). (MonadCatch m, MonadIO m) => Location -> m ()
IO.createLocalDirectoryIfMissing Location
scopedArchivePath

          [PackageInfo]
packages     <- [Char] -> PlanJson -> IO [PackageInfo]
Z.getPackages [Char]
storePath PlanJson
planJson
          [PackageInfo]
nonShareable <- [PackageInfo]
packages [PackageInfo]
-> ([PackageInfo] -> IO [PackageInfo]) -> IO [PackageInfo]
forall a b. a -> (a -> b) -> b
& (PackageInfo -> IO Bool) -> [PackageInfo] -> IO [PackageInfo]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (IO Bool -> IO Bool)
-> (PackageInfo -> IO Bool) -> PackageInfo -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PackageInfo -> IO Bool
forall (m :: * -> *). MonadIO m => [Char] -> PackageInfo -> m Bool
isShareable [Char]
storePath)
          let planData :: PlanData
planData = PlanJson -> [Text] -> PlanData
buildPlanData PlanJson
planJson ([PackageInfo]
nonShareable [PackageInfo] -> Getting (Endo [Text]) [PackageInfo] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. (PackageInfo -> Const (Endo [Text]) PackageInfo)
-> [PackageInfo] -> Const (Endo [Text]) [PackageInfo]
forall s t a b. Each s t a b => Traversal s t a b
each ((PackageInfo -> Const (Endo [Text]) PackageInfo)
 -> [PackageInfo] -> Const (Endo [Text]) [PackageInfo])
-> ((Text -> Const (Endo [Text]) Text)
    -> PackageInfo -> Const (Endo [Text]) PackageInfo)
-> Getting (Endo [Text]) [PackageInfo] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 "packageId" s t a b => Lens s t a b
the @"packageId")

          let storeCompilerPath :: [Char]
storeCompilerPath           = [Char]
storePath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> Text -> [Char]
T.unpack Text
compilerId
          let storeCompilerPackageDbPath :: [Char]
storeCompilerPackageDbPath  = [Char]
storeCompilerPath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
"package.db"

          Bool
storeCompilerPackageDbPathExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
storeCompilerPackageDbPath

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
storeCompilerPackageDbPathExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            CompilerContext -> [Char] -> IO ()
GhcPkg.init CompilerContext
compilerContext [Char]
storeCompilerPackageDbPath

          Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Syncing " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow ([PackageInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PackageInfo]
packages) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" packages"

          [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m a) -> m a
IO.withSystemTempDirectory [Char]
"cabal-cache" (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
tempPath -> do
            Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Temp path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. Show a => a -> Text
tshow [Char]
tempPath

            Int -> [PackageInfo] -> (PackageInfo -> IO ()) -> IO ()
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Foldable t) =>
Int -> t a -> (a -> m b) -> m ()
IO.pooledForConcurrentlyN_ (SyncToArchiveOptions
opts SyncToArchiveOptions -> Getting Int SyncToArchiveOptions Int -> Int
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 "threads" s t a b => Lens s t a b
the @"threads") [PackageInfo]
packages ((PackageInfo -> IO ()) -> IO ())
-> (PackageInfo -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackageInfo
pInfo -> do
              Bool
earlyExit <- TVar Bool -> IO Bool
forall a. TVar a -> IO a
STM.readTVarIO TVar Bool
tEarlyExit
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
earlyExit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                let archiveFileBasename :: [Char]
archiveFileBasename = PackageInfo -> [Char]
Z.packageDir PackageInfo
pInfo [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
<.> [Char]
".tar.gz"
                let archiveFile :: Location
archiveFile         = Location
versionedArchiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
archiveFileBasename
                let scopedArchiveFile :: Location
scopedArchiveFile   = Location
versionedArchiveUri Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
storePathHash Text -> Text -> Text
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
archiveFileBasename
                let packageStorePath :: [Char]
packageStorePath    = [Char]
storePath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> PackageInfo -> [Char]
Z.packageDir PackageInfo
pInfo

                -- either write "normal" package, or a user-specific one if the package cannot be shared
                let targetFile :: Location
targetFile = if PlanData -> Text -> Bool
canShare PlanData
planData (PackageInfo -> Text
Z.packageId PackageInfo
pInfo) then Location
archiveFile else Location
scopedArchiveFile

                Bool
archiveFileExists <- ResourceT IO Bool -> IO Bool
forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT (ResourceT IO Bool -> IO Bool) -> ResourceT IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> Location -> ResourceT IO Bool
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m, MonadIO m) =>
Env -> Location -> m Bool
IO.resourceExists Env
envAws Location
targetFile

                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
archiveFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  Bool
packageStorePathExists <- [Char] -> IO Bool
doesDirectoryExist [Char]
packageStorePath

                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
packageStorePathExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Either AppError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either AppError ()) -> IO ())
-> IO (Either AppError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT AppError IO () -> IO (Either AppError ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT AppError IO () -> IO (Either AppError ()))
-> ExceptT AppError IO () -> IO (Either AppError ())
forall a b. (a -> b) -> a -> b
$ ExceptT AppError IO () -> ExceptT AppError IO ()
forall (m :: * -> *) a.
MonadIO m =>
ExceptT AppError m a -> ExceptT AppError m a
IO.exceptWarn (ExceptT AppError IO () -> ExceptT AppError IO ())
-> ExceptT AppError IO () -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ do
                    let workingStorePackagePath :: [Char]
workingStorePackagePath = [Char]
tempPath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> PackageInfo -> [Char]
Z.packageDir PackageInfo
pInfo
                    IO () -> ExceptT AppError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AppError IO ())
-> IO () -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
IO.createDirectoryIfMissing Bool
True [Char]
workingStorePackagePath

                    let rp2 :: [TarGroup]
rp2 = [Char] -> PackageInfo -> [TarGroup]
Z.relativePaths [Char]
storePath PackageInfo
pInfo

                    Text -> ExceptT AppError IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> ExceptT AppError IO ()) -> Text -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Creating " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Location -> Text
forall a. ToText a => a -> Text
toText Location
targetFile

                    let tempArchiveFile :: [Char]
tempArchiveFile = [Char]
tempPath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
archiveFileBasename

                    TarGroup
metas <- [Char]
-> PackageInfo
-> [(Text, ByteString)]
-> ExceptT AppError IO TarGroup
forall (m :: * -> *).
MonadIO m =>
[Char] -> PackageInfo -> [(Text, ByteString)] -> m TarGroup
createMetadata [Char]
tempPath PackageInfo
pInfo [(Text
"store-path", [Char] -> ByteString
LC8.pack [Char]
storePath)]

                    [Char] -> [TarGroup] -> ExceptT AppError IO ()
forall (m :: * -> *).
MonadIO m =>
[Char] -> [TarGroup] -> ExceptT AppError m ()
IO.createTar [Char]
tempArchiveFile ([TarGroup]
rp2 [TarGroup] -> [TarGroup] -> [TarGroup]
forall a. Semigroup a => a -> a -> a
<> [TarGroup
metas])

                    ExceptT AppError IO () -> ExceptT AppError IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT AppError IO () -> ExceptT AppError IO ())
-> ExceptT AppError IO () -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ ExceptT AppError IO ()
-> (AppError -> ExceptT AppError IO ()) -> ExceptT AppError IO ()
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (IO ByteString -> ExceptT AppError IO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO ByteString
LBS.readFile [Char]
tempArchiveFile) ExceptT AppError IO ByteString
-> (ByteString -> ExceptT AppError IO ()) -> ExceptT AppError IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Env -> Location -> ByteString -> ExceptT AppError IO ()
forall (m :: * -> *).
(MonadUnliftIO m, MonadCatch m) =>
Env -> Location -> ByteString -> ExceptT AppError m ()
IO.writeResource Env
envAws Location
targetFile) ((AppError -> ExceptT AppError IO ()) -> ExceptT AppError IO ())
-> (AppError -> ExceptT AppError IO ()) -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ \case
                      e :: AppError
e@(AwsAppError (HTTP.Status Int
301 ByteString
_)) -> do
                        IO () -> ExceptT AppError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT AppError IO ())
-> IO () -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar Bool
tEarlyExit Bool
True
                        Handle -> Text -> ExceptT AppError IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> ExceptT AppError IO ()) -> Text -> ExceptT AppError IO ()
forall a b. (a -> b) -> a -> b
$ Text
forall a. Monoid a => a
mempty
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ERROR: No write access to archive uris: "
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
tshow ((Location -> Text) -> [Location] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> Text
forall a. ToText a => a -> Text
toText [Location
scopedArchiveFile, Location
archiveFile])
                          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AppError -> Text
displayAppError AppError
e

                      AppError
_ -> () -> ExceptT AppError IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left Text
msg -> Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr Text
msg

    Left (AppError
appError :: AppError) -> do
      Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: Unable to parse plan.json file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AppError -> Text
displayAppError AppError
appError

  Bool
earlyExit <- TVar Bool -> IO Bool
forall a. TVar a -> IO a
STM.readTVarIO TVar Bool
tEarlyExit

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
earlyExit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr Text
"Early exit due to error"

isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool
isShareable :: [Char] -> PackageInfo -> m Bool
isShareable [Char]
storePath PackageInfo
pkg =
  let packageSharePath :: [Char]
packageSharePath = [Char]
storePath [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> PackageInfo -> [Char]
Z.packageDir PackageInfo
pkg [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
"share"
  in [Char] -> m [[Char]]
forall (m :: * -> *). MonadIO m => [Char] -> m [[Char]]
IO.listMaybeDirectory [Char]
packageSharePath m [[Char]] -> ([[Char]] -> [[Char]]) -> m [[Char]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([[Char]] -> [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [a]
\\ [[Char]
"doc"]) m [[Char]] -> ([[Char]] -> Bool) -> m Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null

optsSyncToArchive :: Parser SyncToArchiveOptions
optsSyncToArchive :: Parser SyncToArchiveOptions
optsSyncToArchive = Region
-> Location
-> [Char]
-> [Char]
-> Maybe [Char]
-> Int
-> Maybe LogLevel
-> SyncToArchiveOptions
SyncToArchiveOptions
  (Region
 -> Location
 -> [Char]
 -> [Char]
 -> Maybe [Char]
 -> Int
 -> Maybe LogLevel
 -> SyncToArchiveOptions)
-> Parser Region
-> Parser
     (Location
      -> [Char]
      -> [Char]
      -> Maybe [Char]
      -> Int
      -> Maybe LogLevel
      -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Region -> Mod OptionFields Region -> Parser Region
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (ReadM Region
forall a. Read a => ReadM a
auto ReadM Region -> ReadM Region -> ReadM Region
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ReadM Region
forall a. FromText a => ReadM a
text)
      (  [Char] -> Mod OptionFields Region
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"region"
      Mod OptionFields Region
-> Mod OptionFields Region -> Mod OptionFields Region
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields Region
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"AWS_REGION"
      Mod OptionFields Region
-> Mod OptionFields Region -> Mod OptionFields Region
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Region
forall a (f :: * -> *). Show a => Mod f a
showDefault Mod OptionFields Region
-> Mod OptionFields Region -> Mod OptionFields Region
forall a. Semigroup a => a -> a -> a
<> Region -> Mod OptionFields Region
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Region
Oregon
      Mod OptionFields Region
-> Mod OptionFields Region -> Mod OptionFields Region
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields Region
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"The AWS region in which to operate"
      )
  Parser
  (Location
   -> [Char]
   -> [Char]
   -> Maybe [Char]
   -> Int
   -> Maybe LogLevel
   -> SyncToArchiveOptions)
-> Parser Location
-> Parser
     ([Char]
      -> [Char]
      -> Maybe [Char]
      -> Int
      -> Maybe LogLevel
      -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Location -> Mod OptionFields Location -> Parser Location
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (([Char] -> Maybe Location) -> ReadM Location
forall a. ([Char] -> Maybe a) -> ReadM a
maybeReader (Text -> Maybe Location
toLocation (Text -> Maybe Location)
-> ([Char] -> Text) -> [Char] -> Maybe Location
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
Text.pack))
      (   [Char] -> Mod OptionFields Location
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"archive-uri"
      Mod OptionFields Location
-> Mod OptionFields Location -> Mod OptionFields Location
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields Location
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Archive URI to sync to"
      Mod OptionFields Location
-> Mod OptionFields Location -> Mod OptionFields Location
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields Location
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"S3_URI"
      Mod OptionFields Location
-> Mod OptionFields Location -> Mod OptionFields Location
forall a. Semigroup a => a -> a -> a
<>  Location -> Mod OptionFields Location
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ([Char] -> Location
Local ([Char] -> Location) -> [Char] -> Location
forall a b. (a -> b) -> a -> b
$ [Char]
AS.cabalDirectory [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
"archive")
      )
  Parser
  ([Char]
   -> [Char]
   -> Maybe [Char]
   -> Int
   -> Maybe LogLevel
   -> SyncToArchiveOptions)
-> Parser [Char]
-> Parser
     ([Char]
      -> Maybe [Char] -> Int -> Maybe LogLevel -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"build-path"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help ([Char]
"Path to cabal build directory.  Defaults to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
AS.buildPath)
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"DIRECTORY"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
AS.buildPath
      )
  Parser
  ([Char]
   -> Maybe [Char] -> Int -> Maybe LogLevel -> SyncToArchiveOptions)
-> Parser [Char]
-> Parser
     (Maybe [Char] -> Int -> Maybe LogLevel -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"store-path"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Path to cabal store"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"DIRECTORY"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ([Char]
AS.cabalDirectory [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
"store")
      )
  Parser
  (Maybe [Char] -> Int -> Maybe LogLevel -> SyncToArchiveOptions)
-> Parser (Maybe [Char])
-> Parser (Int -> Maybe LogLevel -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char] -> Parser (Maybe [Char])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"store-path-hash"
        Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Store path hash (do not use)"
        Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"HASH"
        )
      )
  Parser (Int -> Maybe LogLevel -> SyncToArchiveOptions)
-> Parser Int -> Parser (Maybe LogLevel -> SyncToArchiveOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto
      (   [Char] -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"threads"
      Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields Int
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Number of concurrent threads"
      Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"NUM_THREADS"
      Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<>  Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
4
      )
  Parser (Maybe LogLevel -> SyncToArchiveOptions)
-> Parser (Maybe LogLevel) -> Parser SyncToArchiveOptions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser LogLevel -> Parser (Maybe LogLevel)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( ReadM LogLevel -> Mod OptionFields LogLevel -> Parser LogLevel
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM LogLevel
forall a. FromText a => ReadM a
autoText
        (   [Char] -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"aws-log-level"
        Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields LogLevel
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"AWS Log Level.  One of (Error, Info, Debug, Trace)"
        Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"AWS_LOG_LEVEL"
        )
      )

cmdSyncToArchive :: Mod CommandFields (IO ())
cmdSyncToArchive :: Mod CommandFields (IO ())
cmdSyncToArchive = [Char] -> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> ParserInfo a -> Mod CommandFields a
command [Char]
"sync-to-archive"  (ParserInfo (IO ()) -> Mod CommandFields (IO ()))
-> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a b. (a -> b) -> a -> b
$ (Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ()))
-> InfoMod (IO ()) -> Parser (IO ()) -> ParserInfo (IO ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ())
forall a. Parser a -> InfoMod a -> ParserInfo a
info InfoMod (IO ())
forall a. Monoid a => a
idm (Parser (IO ()) -> ParserInfo (IO ()))
-> Parser (IO ()) -> ParserInfo (IO ())
forall a b. (a -> b) -> a -> b
$ SyncToArchiveOptions -> IO ()
runSyncToArchive (SyncToArchiveOptions -> IO ())
-> Parser SyncToArchiveOptions -> Parser (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser SyncToArchiveOptions
optsSyncToArchive