{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
module Hercules.CLI.State (commandParser, getProjectAndClient) where
import Conduit (ConduitT, mapC, runConduitRes, sinkFile, sourceHandle, stdinC, stdoutC, (.|))
import Data.Has (Has)
import Hercules.API (ClientAuth, enterApiE)
import Hercules.API.Name (Name (Name))
import Hercules.API.State
import Hercules.CLI.Client
import Hercules.CLI.Common (runAuthenticated)
import Hercules.CLI.Options (mkCommand, subparser)
import Hercules.CLI.Project (ProjectPath (projectPathOwner, projectPathProject, projectPathSite), findProjectContextually, projectOption)
import Options.Applicative (auto, bashCompleter, completer, help, long, metavar, option, strOption)
import qualified Options.Applicative as Optparse
import Protolude
import RIO (RIO, runRIO, withBinaryFile)
import Servant.API (Headers (Headers), fromSourceIO, toSourceIO)
import Servant.Client.Generic (AsClientT)
import Servant.Client.Internal.HttpClient.Streaming (ClientM)
import Servant.Conduit ()
commandParser, getCommandParser, putCommandParser :: Optparse.Parser (IO ())
commandParser :: Parser (IO ())
commandParser =
forall a. Mod CommandFields a -> Parser a
subparser
( forall a. FilePath -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
FilePath
"get"
(forall a. FilePath -> InfoMod a
Optparse.progDesc FilePath
"Download a state file")
Parser (IO ())
getCommandParser
forall a. Semigroup a => a -> a -> a
<> forall a. FilePath -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
FilePath
"put"
(forall a. FilePath -> InfoMod a
Optparse.progDesc FilePath
"Upload a state file")
Parser (IO ())
putCommandParser
)
getCommandParser :: Parser (IO ())
getCommandParser = do
Maybe ProjectPath
projectMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
Text
name <- Parser Text
nameOption
FilePath
file <- Parser FilePath
fileOption
Maybe Int
versionMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Int
versionOption
pure do
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe
forall r a b.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> (Either ClientError a -> IO b) -> RIO r b
runHerculesClientStream (forall auth f.
ProjectStateResourceGroup auth f
-> f
:- (Summary "Download a state file"
:> ("state"
:> (Capture' '[Required, Strict] "stateName" Text
:> ("data"
:> (QueryParam' '[Optional, Strict] "version" Int
:> (auth
:> StreamGet
NoFraming
OctetStream
(Headers
'[ContentLength, ContentDisposition] (SourceIO RawBytes))))))))
getStateData ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient Text
name Maybe Int
versionMaybe) \case
Left ClientError
e -> forall a. ClientError -> IO a
dieWithHttpError ClientError
e
Right (Headers SourceIO RawBytes
r HList '[ContentLength, ContentDisposition]
_) -> do
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes forall a b. (a -> b) -> a -> b
$
forall chunk a. FromSourceIO chunk a => SourceIO chunk -> a
fromSourceIO SourceIO RawBytes
r forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC RawBytes -> ByteString
fromRawBytes forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| case FilePath
file of
FilePath
"-" -> forall (m :: * -> *) o. MonadIO m => ConduitT ByteString o m ()
stdoutC
FilePath
_ -> forall (m :: * -> *) o.
MonadResource m =>
FilePath -> ConduitT ByteString o m ()
sinkFile FilePath
file
putCommandParser :: Parser (IO ())
putCommandParser = do
Maybe ProjectPath
projectMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
Text
name <- Parser Text
nameOption
FilePath
file <- Parser FilePath
fileOption
pure do
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe
let withStream :: (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b
withStream :: forall a r b. (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b
withStream = case FilePath
file of
FilePath
"-" -> (forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) i. MonadIO m => ConduitT i ByteString m ()
stdinC forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC ByteString -> RawBytes
RawBytes))
FilePath
_ -> \ConduitT a RawBytes IO () -> RIO r b
f -> do
r
r <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
FilePath -> IOMode -> (Handle -> m a) -> m a
withBinaryFile FilePath
file IOMode
ReadMode \Handle
h ->
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO r
r forall a b. (a -> b) -> a -> b
$ ConduitT a RawBytes IO () -> RIO r b
f (forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
h forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
mapC ByteString -> RawBytes
RawBytes)
forall a r b. (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b
withStream \ConduitT Any RawBytes IO ()
stream -> do
NoContent
_noContent <- forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient (forall auth f.
ProjectStateResourceGroup auth f
-> f
:- (Summary "Upload a state file"
:> ("state"
:> (Capture' '[Required, Strict] "stateName" Text
:> ("data"
:> (StreamBody NoFraming OctetStream (SourceIO RawBytes)
:> (auth :> Put '[JSON] NoContent))))))
putStateData ProjectStateResourceGroup ClientAuth (AsClientT ClientM)
projectStateClient Text
name (forall chunk a. ToSourceIO chunk a => a -> SourceIO chunk
toSourceIO ConduitT Any RawBytes IO ()
stream))
forall (f :: * -> *). Applicative f => f ()
pass
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci: State file upload successful for " forall a. Semigroup a => a -> a -> a
<> Text
name
nameOption :: Optparse.Parser Text
nameOption :: Parser Text
nameOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"name" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"NAME" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Name of the state file"
fileOption :: Optparse.Parser FilePath
fileOption :: Parser FilePath
fileOption = forall s. IsString s => Mod OptionFields s -> Parser s
strOption forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"file" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILE" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Local path of the state file or - for stdio" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasCompleter f => Completer -> Mod f a
completer (FilePath -> Completer
bashCompleter FilePath
"file")
versionOption :: Optparse.Parser Int
versionOption :: Parser Int
versionOption = forall a. ReadM a -> Mod OptionFields a -> Parser a
option forall a. Read a => ReadM a
auto forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"version" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"INT" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Version of the state file to retrieve"
getProjectAndClient :: (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient :: forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath
-> RIO r (ProjectStateResourceGroup ClientAuth (AsClientT ClientM))
getProjectAndClient Maybe ProjectPath
projectMaybe =
case Maybe ProjectPath
projectMaybe of
Just ProjectPath
projectPath ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateAPI ClientAuth (AsClientT ClientM)
stateClient forall {k} (subapi :: k -> * -> *) (api :: k -> * -> *) mode
(a :: k).
GenericServant (subapi a) mode =>
api a mode
-> (api a mode -> ToServant (subapi a) mode) -> subapi a mode
`enterApiE` \StateAPI ClientAuth (AsClientT ClientM)
api -> forall auth f.
StateAPI auth f
-> f
:- Substitute
("site"
:> (Capture' '[Required, Strict] "site" (Name Forge)
:> ("account"
:> (Capture' '[Required, Strict] "account" (Name Account)
:> ("project"
:> (Capture' '[Required, Strict] "project" (Name Project)
:> Placeholder))))))
(ToServantApi (ProjectStateResourceGroup auth))
byProjectName StateAPI ClientAuth (AsClientT ClientM)
api (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathSite ProjectPath
projectPath) (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathOwner ProjectPath
projectPath) (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathProject ProjectPath
projectPath))
Maybe ProjectPath
Nothing -> do
(Maybe (Id Project)
projectIdMaybe, ProjectPath
projectPath) <- forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
RIO r (Maybe (Id Project), ProjectPath)
findProjectContextually
case Maybe (Id Project)
projectIdMaybe of
Just Id Project
projectId ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateAPI ClientAuth (AsClientT ClientM)
stateClient forall {k} (subapi :: k -> * -> *) (api :: k -> * -> *) mode
(a :: k).
GenericServant (subapi a) mode =>
api a mode
-> (api a mode -> ToServant (subapi a) mode) -> subapi a mode
`enterApiE` \StateAPI ClientAuth (AsClientT ClientM)
api -> forall auth f.
StateAPI auth f
-> f
:- Substitute
("projects"
:> (Capture' '[Required, Strict] "projectId" (Id Project)
:> Placeholder))
(ToServantApi (ProjectStateResourceGroup auth))
byProjectId StateAPI ClientAuth (AsClientT ClientM)
api Id Project
projectId)
Maybe (Id Project)
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StateAPI ClientAuth (AsClientT ClientM)
stateClient forall {k} (subapi :: k -> * -> *) (api :: k -> * -> *) mode
(a :: k).
GenericServant (subapi a) mode =>
api a mode
-> (api a mode -> ToServant (subapi a) mode) -> subapi a mode
`enterApiE` \StateAPI ClientAuth (AsClientT ClientM)
api -> forall auth f.
StateAPI auth f
-> f
:- Substitute
("site"
:> (Capture' '[Required, Strict] "site" (Name Forge)
:> ("account"
:> (Capture' '[Required, Strict] "account" (Name Account)
:> ("project"
:> (Capture' '[Required, Strict] "project" (Name Project)
:> Placeholder))))))
(ToServantApi (ProjectStateResourceGroup auth))
byProjectName StateAPI ClientAuth (AsClientT ClientM)
api (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathSite ProjectPath
projectPath) (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathOwner ProjectPath
projectPath) (forall k (a :: k). Text -> Name a
Name forall a b. (a -> b) -> a -> b
$ ProjectPath -> Text
projectPathProject ProjectPath
projectPath))