{-# 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
      -- TODO: version
      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))