{-# 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 = forall a. Mod CommandFields a -> Parser a subparser ( forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a mkCommand String "init-local" (forall a. String -> InfoMod a Optparse.progDesc String "Create a local secrets file in ~/.config/hercules-ci/secrets/<site>/<owner>") Parser (IO ()) initLocal forall a. Semigroup a => a -> a -> a <> forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a mkCommand String "add" (forall a. String -> InfoMod a Optparse.progDesc String "Insert a secret into the local secrets file") Parser (IO ()) add forall a. Semigroup a => a -> a -> a <> forall a. String -> InfoMod a -> Parser a -> Mod CommandFields a mkCommand String "echo" (forall a. String -> InfoMod a Optparse.progDesc String "Assemble a secret for stdout") Parser (IO ()) echo ) initLocal :: Parser (IO ()) initLocal = do Maybe ProjectPath projectOptionMaybe <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional Parser ProjectPath projectOption pure $ forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b runAuthenticated do ProjectPath projectPath <- forall r. (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r ProjectPath getProjectPath Maybe ProjectPath projectOptionMaybe String secretsFilePath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ ProjectPath -> IO String getSecretsFilePath ProjectPath projectPath forall (m :: * -> *). MonadIO m => String -> m Bool doesFileExist String secretsFilePath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Bool True -> do forall (m :: * -> *). MonadIO m => Text -> m () putErrText forall a b. (a -> b) -> a -> b $ Text "hci: Secrets file already existed. Path: " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String secretsFilePath Bool False -> do forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). MonadIO m => Bool -> String -> m () createDirectoryIfMissing Bool True (String -> String takeDirectory String secretsFilePath) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ String -> Text -> IO () writeFile String secretsFilePath Text "{}" forall (m :: * -> *). MonadIO m => Text -> m () putErrText forall a b. (a -> b) -> a -> b $ Text "hci: Secrets file created. Path: " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String secretsFilePath add :: Parser (IO ()) add = do Text secretName <- forall s. IsString s => Mod ArgumentFields s -> Parser s Optparse.strArgument (forall (f :: * -> *) a. HasMetavar f => String -> Mod f a Optparse.metavar String "SECRET_NAME" forall a. Semigroup a => a -> a -> a <> 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 <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional Parser ProjectPath projectOption pure $ forall b. RIO (HerculesClientToken, HerculesClientEnv) b -> IO b runAuthenticated do Value secretDataValue <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Maybe Text -> IO Value mkJson (forall a. a -> Maybe a Just Text secretName)) Map Text Value secretData <- case forall a b. (a -> Parser b) -> a -> Result b A.parse forall a. FromJSON a => Value -> Parser a A.parseJSON Value secretDataValue of A.Error String e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a throwIO forall a b. (a -> b) -> a -> b $ Text -> UserException UserException forall a b. (a -> b) -> a -> b $ Text "The secret data must be an object. " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String e A.Success Map Text Value a -> forall (f :: * -> *) a. Applicative f => a -> f a pure Map Text Value a ProjectPath projectPath <- forall r. (Has HerculesClientToken r, Has HerculesClientEnv r) => Maybe ProjectPath -> RIO r ProjectPath getProjectPath Maybe ProjectPath projectOptionMaybe String secretsFilePath <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ ProjectPath -> IO String getSecretsFilePath ProjectPath projectPath forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). MonadIO m => String -> m Bool doesFileExist String secretsFilePath forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case Bool False -> forall (m :: * -> *) a. MonadIO m => Text -> m a exitMsg forall a b. (a -> b) -> a -> b $ Text "No secrets file found. If the account is correct, use `hci init-local`. (path: " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String secretsFilePath forall a. Semigroup a => a -> a -> a <> Text ")" Bool True -> forall (f :: * -> *). Applicative f => f () pass Map Text Value secrets <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall b. FromJSON b => String -> IO b readJsonFile String secretsFilePath case forall k a. Ord k => k -> Map k a -> Maybe a M.lookup Text secretName Map Text Value secrets of Just Value _ -> do forall (m :: * -> *) a. MonadIO m => Text -> m a exitMsg forall a b. (a -> b) -> a -> b $ Text "Secret " forall a. Semigroup a => a -> a -> a <> Text secretName forall a. Semigroup a => a -> a -> a <> Text " already exists in " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String secretsFilePath forall a. Semigroup a => a -> a -> a <> Text "." Maybe Value Nothing -> forall (f :: * -> *). Applicative f => f () pass let secret :: Secret secret = Secret { data_ :: Map Text Value data_ = Map Text Value secretData, condition :: Maybe Condition condition = forall a. a -> Maybe a Just 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 forall a b. a -> (a -> b) -> b & forall k a. Ord k => k -> a -> Map k a -> Map k a M.insert Text secretName (forall a. ToJSON a => a -> Value A.toJSON Secret secret) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ forall a. ToJSON a => String -> a -> IO () writeJsonFile String secretsFilePath Map Text Value secrets' forall (m :: * -> *). MonadIO m => Text -> m () putErrText forall a b. (a -> b) -> a -> b $ Text "hci: Successfully wrote " forall a. Semigroup a => a -> a -> a <> Text secretName forall a. Semigroup a => a -> a -> a <> Text " to " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String secretsFilePath forall (m :: * -> *). MonadIO m => Text -> m () putErrText Text " It is only available for the detected or passed project's default branch." forall (m :: * -> *). MonadIO m => Text -> m () putErrText Text " You can edit the condition to suit your needs." 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 <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a) optional Parser ProjectPath projectOption pure do Value secretDataValue <- forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (Maybe Text -> IO Value mkJson forall a. Maybe a Nothing) Map Text Value secretData <- case forall a b. (a -> Parser b) -> a -> Result b A.parse forall a. FromJSON a => Value -> Parser a A.parseJSON Value secretDataValue of A.Error String e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a throwIO forall a b. (a -> b) -> a -> b $ Text -> UserException UserException forall a b. (a -> b) -> a -> b $ Text "The secret data must be an object. " forall a. Semigroup a => a -> a -> a <> forall a b. ConvertText a b => a -> b toS String e A.Success Map Text Value a -> forall (f :: * -> *) a. Applicative f => a -> f a pure Map Text Value a let secret :: Secret secret = Secret { data_ :: Map Text Value data_ = Map Text Value secretData, condition :: Maybe Condition condition = Maybe ProjectPath projectOptionMaybe 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 ] } forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ 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" 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 -> 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 <- forall (m :: * -> *). MonadIO m => XdgDirectory -> String -> m String getXdgDirectory XdgDirectory XdgConfig String "hercules-ci" let toPathElement :: Text -> String toPathElement = forall a b. ConvertText a b => a -> b toS forall b c a. (b -> c) -> (a -> b) -> a -> c . (Char -> Char) -> Text -> Text T.map (\case Char '/' -> Char '_'; Char x -> Char x) forall (f :: * -> *) a. Applicative f => a -> f a pure 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"