State.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}

module Hercules.CLI.State where

import Conduit (ConduitT, mapC, runConduitRes, sinkFile, sourceHandle, stdinC, stdoutC, (.|))
import Hercules.API (enterApiE)
import qualified Hercules.API.Projects.Project as Project
import Hercules.API.State
import Hercules.CLI.Client
import Hercules.CLI.Common (runAuthenticated)
import Hercules.CLI.Options (mkCommand, subparser)
import Hercules.CLI.Project (findProject, projectOption)
import Options.Applicative (bashCompleter, completer, help, long, metavar, strOption)
import qualified Options.Applicative as Optparse
import Protolude hiding (option)
import RIO (RIO, runRIO, withBinaryFile)
import Servant.API (Headers (Headers), fromSourceIO, toSourceIO)
import Servant.Conduit ()

commandParser, getCommandParser, putCommandParser :: Optparse.Parser (IO ())
commandParser =
  subparser
    ( mkCommand
        "get"
        (Optparse.progDesc "Download a state file")
        getCommandParser
        <> mkCommand
          "put"
          (Optparse.progDesc "Upload a state file")
          putCommandParser
    )
getCommandParser = do
  project <- projectOption
  name <- nameOption
  file <- fileOption
  pure do
    runAuthenticated do
      projectId <- Project.id <$> findProject project
      let projectStateClient = stateClient `enterApiE` \api -> byProjectId api projectId
      -- TODO: version
      runHerculesClientStream (getStateData projectStateClient name Nothing) \case
        Left e -> dieWithHttpError e
        Right (Headers r _) -> do
          runConduitRes $
            fromSourceIO r .| mapC fromRawBytes .| case file of
              "-" -> stdoutC
              _ -> sinkFile file
putCommandParser = do
  project <- projectOption
  name <- nameOption
  file <- fileOption
  pure do
    runAuthenticated do
      projectId <- Project.id <$> findProject project
      let withStream :: (ConduitT a RawBytes IO () -> RIO r b) -> RIO r b
          withStream = case file of
            "-" -> ($ (stdinC .| mapC RawBytes))
            _ -> \f -> do
              r <- ask
              liftIO $ withBinaryFile file ReadMode \h ->
                runRIO r $ f (sourceHandle h .| mapC RawBytes)
      withStream \stream -> do
        let projectStateClient = stateClient `enterApiE` \api -> byProjectId api projectId
        _noContent <- runHerculesClient (putStateData projectStateClient name (toSourceIO stream))
        pass
    putErrText $ "hci: State file upload successful for " <> name

nameOption :: Optparse.Parser Text
nameOption = strOption $ long "name" <> metavar "NAME" <> help "Name of the state file"

fileOption :: Optparse.Parser FilePath
fileOption = strOption $ long "file" <> metavar "FILE" <> help "Local path of the state file or - for stdio" <> completer (bashCompleter "file")