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

module Hercules.CLI.Secret where

import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import qualified Data.Map as M
import qualified Data.Text as T
import Hercules.CLI.Common (exitMsg, runAuthenticated)
import Hercules.CLI.JSON as JSON
import Hercules.CLI.Options (mkCommand, subparser)
import Hercules.CLI.Project (ProjectPath (projectPathOwner, projectPathSite), getProjectPath, projectOption, projectPathProject)
import Hercules.Formats.Secret (Secret (Secret))
import qualified Hercules.Formats.Secret as Secret
import Hercules.UserException (UserException (UserException))
import qualified Options.Applicative as Optparse
import Protolude
import System.Environment (lookupEnv)
import System.FilePath (takeDirectory, (</>))
import UnliftIO.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)

commandParser, initLocal, add, echo :: Optparse.Parser (IO ())
commandParser :: Parser (IO ())
commandParser =
  Mod CommandFields (IO ()) -> Parser (IO ())
forall a. Mod CommandFields a -> Parser a
subparser
    ( String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
        String
"init-local"
        (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Create a local secrets file in ~/.config/hercules-ci/secrets/<site>/<owner>")
        Parser (IO ())
initLocal
        Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          String
"add"
          (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Insert a secret into the local secrets file")
          Parser (IO ())
add
        Mod CommandFields (IO ())
-> Mod CommandFields (IO ()) -> Mod CommandFields (IO ())
forall a. Semigroup a => a -> a -> a
<> String
-> InfoMod (IO ()) -> Parser (IO ()) -> Mod CommandFields (IO ())
forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a
mkCommand
          String
"echo"
          (String -> InfoMod (IO ())
forall a. String -> InfoMod a
Optparse.progDesc String
"Assemble a secret for stdout")
          Parser (IO ())
echo
    )
initLocal :: Parser (IO ())
initLocal = do
  Maybe ProjectPath
projectOptionMaybe <- Parser ProjectPath -> Parser (Maybe ProjectPath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  pure $ RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
    ProjectPath
projectPath <- Maybe ProjectPath
-> RIO (HerculesClientToken, HerculesClientEnv) ProjectPath
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r ProjectPath
getProjectPath Maybe ProjectPath
projectOptionMaybe
    String
secretsFilePath <- IO String -> RIO (HerculesClientToken, HerculesClientEnv) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO (HerculesClientToken, HerculesClientEnv) String)
-> IO String -> RIO (HerculesClientToken, HerculesClientEnv) String
forall a b. (a -> b) -> a -> b
$ ProjectPath -> IO String
getSecretsFilePath ProjectPath
projectPath
    String -> RIO (HerculesClientToken, HerculesClientEnv) Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
secretsFilePath RIO (HerculesClientToken, HerculesClientEnv) Bool
-> (Bool -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> do
        Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: Secrets file already existed. Path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
secretsFilePath
      Bool
False -> do
        IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
secretsFilePath)
        IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> IO ()
writeFile String
secretsFilePath Text
"{}"
        Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: Secrets file created. Path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
secretsFilePath
add :: Parser (IO ())
add = do
  Text
secretName <- Mod ArgumentFields Text -> Parser Text
forall s. IsString s => Mod ArgumentFields s -> Parser s
Optparse.strArgument (String -> Mod ArgumentFields Text
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
Optparse.metavar String
"SECRET_NAME" Mod ArgumentFields Text
-> Mod ArgumentFields Text -> Mod ArgumentFields Text
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields Text
forall (f :: * -> *) a. String -> Mod f a
Optparse.help String
"Organization/account-wide name for the secret")
  Maybe Text -> IO Value
mkJson <- Parser (Maybe Text -> IO Value)
JSON.options
  Maybe ProjectPath
projectOptionMaybe <- Parser ProjectPath -> Parser (Maybe ProjectPath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  pure $ RIO (HerculesClientToken, HerculesClientEnv) () -> IO ()
forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b
runAuthenticated do
    Value
secretDataValue <- IO Value -> RIO (HerculesClientToken, HerculesClientEnv) Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Text -> IO Value
mkJson (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
secretName))
    Map Text Value
secretData <- case (Value -> Parser (Map Text Value))
-> Value -> Result (Map Text Value)
forall a b. (a -> Parser b) -> a -> Result b
A.parse Value -> Parser (Map Text Value)
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
secretDataValue of
      A.Error String
e -> UserException
-> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (UserException
 -> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value))
-> UserException
-> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Text -> UserException
UserException (Text -> UserException) -> Text -> UserException
forall a b. (a -> b) -> a -> b
$ Text
"The secret data must be an object. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
e
      A.Success Map Text Value
a -> Map Text Value
-> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Value
a
    ProjectPath
projectPath <- Maybe ProjectPath
-> RIO (HerculesClientToken, HerculesClientEnv) ProjectPath
forall r.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
Maybe ProjectPath -> RIO r ProjectPath
getProjectPath Maybe ProjectPath
projectOptionMaybe
    String
secretsFilePath <- IO String -> RIO (HerculesClientToken, HerculesClientEnv) String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> RIO (HerculesClientToken, HerculesClientEnv) String)
-> IO String -> RIO (HerculesClientToken, HerculesClientEnv) String
forall a b. (a -> b) -> a -> b
$ ProjectPath -> IO String
getSecretsFilePath ProjectPath
projectPath
    IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$
      String -> IO Bool
forall (m :: * -> *). MonadIO m => String -> m Bool
doesFileExist String
secretsFilePath IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> Text -> IO ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"No secrets file found. If the account is correct, use `hci init-local`. (path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
secretsFilePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
        Bool
True -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    Map Text Value
secrets <- IO (Map Text Value)
-> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map Text Value)
 -> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value))
-> IO (Map Text Value)
-> RIO (HerculesClientToken, HerculesClientEnv) (Map Text Value)
forall a b. (a -> b) -> a -> b
$ String -> IO (Map Text Value)
forall b. FromJSON b => String -> IO b
readJsonFile String
secretsFilePath
    case Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
secretName Map Text Value
secrets of
      Just Value
_ -> do
        Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => Text -> m a
exitMsg (Text -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"Secret " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
secretName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
secretsFilePath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
      Maybe Value
Nothing -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (f :: * -> *). Applicative f => f ()
pass
    let secret :: Secret
secret =
          Secret :: Map Text Value -> Maybe Condition -> Secret
Secret
            { data_ :: Map Text Value
data_ = Map Text Value
secretData,
              condition :: Maybe Condition
condition =
                Condition -> Maybe Condition
forall a. a -> Maybe a
Just (Condition -> Maybe Condition) -> Condition -> Maybe Condition
forall a b. (a -> b) -> a -> b
$
                  [Condition] -> Condition
Secret.And
                    [ Text -> Condition
Secret.IsOwner (ProjectPath -> Text
projectPathOwner ProjectPath
projectPath),
                      Text -> Condition
Secret.IsRepo (ProjectPath -> Text
projectPathProject ProjectPath
projectPath),
                      Condition
Secret.IsDefaultBranch
                    ]
            }

        secrets' :: Map Text Value
secrets' = Map Text Value
secrets Map Text Value
-> (Map Text Value -> Map Text Value) -> Map Text Value
forall a b. a -> (a -> b) -> b
& Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
secretName (Secret -> Value
forall a. ToJSON a => a -> Value
A.toJSON Secret
secret)
    IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> IO () -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ String -> Map Text Value -> IO ()
forall a. ToJSON a => String -> a -> IO ()
writeJsonFile String
secretsFilePath Map Text Value
secrets'
    Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> RIO (HerculesClientToken, HerculesClientEnv) ())
-> Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"hci: Successfully wrote " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
secretName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
secretsFilePath
    Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"     It is only available for the detected or passed project's default branch."
    Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"     You can edit the condition to suit your needs."
    Text -> RIO (HerculesClientToken, HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"     NOTE: Remember to synchronize this file with your agents!"
echo :: Parser (IO ())
echo = do
  Maybe Text -> IO Value
mkJson <- Parser (Maybe Text -> IO Value)
JSON.options
  Maybe ProjectPath
projectOptionMaybe <- Parser ProjectPath -> Parser (Maybe ProjectPath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ProjectPath
projectOption
  pure do
    Value
secretDataValue <- IO Value -> IO Value
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe Text -> IO Value
mkJson Maybe Text
forall a. Maybe a
Nothing)
    Map Text Value
secretData <- case (Value -> Parser (Map Text Value))
-> Value -> Result (Map Text Value)
forall a b. (a -> Parser b) -> a -> Result b
A.parse Value -> Parser (Map Text Value)
forall a. FromJSON a => Value -> Parser a
A.parseJSON Value
secretDataValue of
      A.Error String
e -> UserException -> IO (Map Text Value)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (UserException -> IO (Map Text Value))
-> UserException -> IO (Map Text Value)
forall a b. (a -> b) -> a -> b
$ Text -> UserException
UserException (Text -> UserException) -> Text -> UserException
forall a b. (a -> b) -> a -> b
$ Text
"The secret data must be an object. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
e
      A.Success Map Text Value
a -> Map Text Value -> IO (Map Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text Value
a
    let secret :: Secret
secret =
          Secret :: Map Text Value -> Maybe Condition -> Secret
Secret
            { data_ :: Map Text Value
data_ = Map Text Value
secretData,
              condition :: Maybe Condition
condition =
                Maybe ProjectPath
projectOptionMaybe Maybe ProjectPath -> (ProjectPath -> Condition) -> Maybe Condition
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ProjectPath
projectPath ->
                  [Condition] -> Condition
Secret.And
                    [ Text -> Condition
Secret.IsOwner (ProjectPath -> Text
projectPathOwner ProjectPath
projectPath),
                      Text -> Condition
Secret.IsRepo (ProjectPath -> Text
projectPathProject ProjectPath
projectPath),
                      Condition
Secret.IsDefaultBranch
                    ]
            }
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Secret -> IO ()
forall a. ToJSON a => a -> IO ()
JSON.printJson Secret
secret

getSecretsFilePath :: ProjectPath -> IO FilePath
getSecretsFilePath :: ProjectPath -> IO String
getSecretsFilePath ProjectPath
projectPath = do
  String -> IO (Maybe String)
lookupEnv String
"HERCULES_CI_SECRETS_JSON" IO (Maybe String) -> (Maybe String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> ProjectPath -> IO String
getSecretsFilePathXdg ProjectPath
projectPath
    Just String
x -> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
x

getSecretsFilePathXdg :: ProjectPath -> IO FilePath
getSecretsFilePathXdg :: ProjectPath -> IO String
getSecretsFilePathXdg ProjectPath
projectPath = do
  String
dir <- XdgDirectory -> String -> IO String
forall (m :: * -> *).
MonadIO m =>
XdgDirectory -> String -> m String
getXdgDirectory XdgDirectory
XdgConfig String
"hercules-ci"
  let toPathElement :: Text -> String
toPathElement = Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> Text -> Text
T.map (\case Char
'/' -> Char
'_'; Char
x -> Char
x)
  String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
"secrets" String -> String -> String
</> Text -> String
toPathElement (ProjectPath -> Text
projectPathSite ProjectPath
projectPath) String -> String -> String
</> Text -> String
toPathElement (ProjectPath -> Text
projectPathOwner ProjectPath
projectPath) String -> String -> String
</> String
"secrets.json"