{-# 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
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
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