{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}

-- | Manages the ~/.config/hercules-ci/credentials.json
module Hercules.CLI.Credentials where

import Control.Lens ((^?))
import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT))
import Data.Aeson (FromJSON, ToJSON, eitherDecode)
import qualified Data.Aeson as A
import Data.Aeson.Lens (key, _String)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.Text as T
import Hercules.CLI.Client (determineDefaultApiBaseUrl)
import Hercules.CLI.JSON (writeJsonFile)
import Hercules.Error
import qualified Network.URI as URI
import Protolude
import System.Directory (XdgDirectory (XdgConfig), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
import qualified System.Environment
import System.FilePath (takeDirectory, (</>))

data Credentials = Credentials
  { Credentials -> Map Text DomainCredentials
domains :: Map Text DomainCredentials
  }
  deriving (Credentials -> Credentials -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Credentials -> Credentials -> Bool
$c/= :: Credentials -> Credentials -> Bool
== :: Credentials -> Credentials -> Bool
$c== :: Credentials -> Credentials -> Bool
Eq, forall x. Rep Credentials x -> Credentials
forall x. Credentials -> Rep Credentials x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Credentials x -> Credentials
$cfrom :: forall x. Credentials -> Rep Credentials x
Generic, Value -> Parser [Credentials]
Value -> Parser Credentials
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Credentials]
$cparseJSONList :: Value -> Parser [Credentials]
parseJSON :: Value -> Parser Credentials
$cparseJSON :: Value -> Parser Credentials
FromJSON, [Credentials] -> Encoding
[Credentials] -> Value
Credentials -> Encoding
Credentials -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Credentials] -> Encoding
$ctoEncodingList :: [Credentials] -> Encoding
toJSONList :: [Credentials] -> Value
$ctoJSONList :: [Credentials] -> Value
toEncoding :: Credentials -> Encoding
$ctoEncoding :: Credentials -> Encoding
toJSON :: Credentials -> Value
$ctoJSON :: Credentials -> Value
ToJSON)

data DomainCredentials = DomainCredentials
  { DomainCredentials -> Text
personalToken :: Text
  }
  deriving (DomainCredentials -> DomainCredentials -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DomainCredentials -> DomainCredentials -> Bool
$c/= :: DomainCredentials -> DomainCredentials -> Bool
== :: DomainCredentials -> DomainCredentials -> Bool
$c== :: DomainCredentials -> DomainCredentials -> Bool
Eq, forall x. Rep DomainCredentials x -> DomainCredentials
forall x. DomainCredentials -> Rep DomainCredentials x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DomainCredentials x -> DomainCredentials
$cfrom :: forall x. DomainCredentials -> Rep DomainCredentials x
Generic, Value -> Parser [DomainCredentials]
Value -> Parser DomainCredentials
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [DomainCredentials]
$cparseJSONList :: Value -> Parser [DomainCredentials]
parseJSON :: Value -> Parser DomainCredentials
$cparseJSON :: Value -> Parser DomainCredentials
FromJSON, [DomainCredentials] -> Encoding
[DomainCredentials] -> Value
DomainCredentials -> Encoding
DomainCredentials -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [DomainCredentials] -> Encoding
$ctoEncodingList :: [DomainCredentials] -> Encoding
toJSONList :: [DomainCredentials] -> Value
$ctoJSONList :: [DomainCredentials] -> Value
toEncoding :: DomainCredentials -> Encoding
$ctoEncoding :: DomainCredentials -> Encoding
toJSON :: DomainCredentials -> Value
$ctoJSON :: DomainCredentials -> Value
ToJSON)

data CredentialsParsingException = CredentialsParsingException
  { CredentialsParsingException -> String
filePath :: FilePath,
    CredentialsParsingException -> Text
message :: Text
  }
  deriving (Int -> CredentialsParsingException -> ShowS
[CredentialsParsingException] -> ShowS
CredentialsParsingException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CredentialsParsingException] -> ShowS
$cshowList :: [CredentialsParsingException] -> ShowS
show :: CredentialsParsingException -> String
$cshow :: CredentialsParsingException -> String
showsPrec :: Int -> CredentialsParsingException -> ShowS
$cshowsPrec :: Int -> CredentialsParsingException -> ShowS
Show, CredentialsParsingException -> CredentialsParsingException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CredentialsParsingException -> CredentialsParsingException -> Bool
$c/= :: CredentialsParsingException -> CredentialsParsingException -> Bool
== :: CredentialsParsingException -> CredentialsParsingException -> Bool
$c== :: CredentialsParsingException -> CredentialsParsingException -> Bool
Eq)

instance Exception CredentialsParsingException where
  displayException :: CredentialsParsingException -> String
displayException CredentialsParsingException
e = String
"Could not parse credentials file " forall a. Semigroup a => a -> a -> a
<> CredentialsParsingException -> String
filePath CredentialsParsingException
e forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (CredentialsParsingException -> Text
message CredentialsParsingException
e)

data NoCredentialException = NoCredentialException
  { NoCredentialException -> Text
noCredentialDomain :: Text
  }
  deriving (Int -> NoCredentialException -> ShowS
[NoCredentialException] -> ShowS
NoCredentialException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NoCredentialException] -> ShowS
$cshowList :: [NoCredentialException] -> ShowS
show :: NoCredentialException -> String
$cshow :: NoCredentialException -> String
showsPrec :: Int -> NoCredentialException -> ShowS
$cshowsPrec :: Int -> NoCredentialException -> ShowS
Show, NoCredentialException -> NoCredentialException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoCredentialException -> NoCredentialException -> Bool
$c/= :: NoCredentialException -> NoCredentialException -> Bool
== :: NoCredentialException -> NoCredentialException -> Bool
$c== :: NoCredentialException -> NoCredentialException -> Bool
Eq)

instance Exception NoCredentialException where
  displayException :: NoCredentialException -> String
displayException NoCredentialException
e = String
"Could not find credentials for domain " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (NoCredentialException -> Text
noCredentialDomain NoCredentialException
e) forall a. Semigroup a => a -> a -> a
<> String
". Please run hci login."

data ApiBaseUrlParsingException = ApiBaseUrlParsingException
  { ApiBaseUrlParsingException -> Text
apiBaseUrlParsingMessage :: Text
  }
  deriving (Int -> ApiBaseUrlParsingException -> ShowS
[ApiBaseUrlParsingException] -> ShowS
ApiBaseUrlParsingException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiBaseUrlParsingException] -> ShowS
$cshowList :: [ApiBaseUrlParsingException] -> ShowS
show :: ApiBaseUrlParsingException -> String
$cshow :: ApiBaseUrlParsingException -> String
showsPrec :: Int -> ApiBaseUrlParsingException -> ShowS
$cshowsPrec :: Int -> ApiBaseUrlParsingException -> ShowS
Show, ApiBaseUrlParsingException -> ApiBaseUrlParsingException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiBaseUrlParsingException -> ApiBaseUrlParsingException -> Bool
$c/= :: ApiBaseUrlParsingException -> ApiBaseUrlParsingException -> Bool
== :: ApiBaseUrlParsingException -> ApiBaseUrlParsingException -> Bool
$c== :: ApiBaseUrlParsingException -> ApiBaseUrlParsingException -> Bool
Eq)

instance Exception ApiBaseUrlParsingException where
  displayException :: ApiBaseUrlParsingException -> String
displayException ApiBaseUrlParsingException
e = String
"Could not parse the api domain: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (ApiBaseUrlParsingException -> Text
apiBaseUrlParsingMessage ApiBaseUrlParsingException
e) forall a. Semigroup a => a -> a -> a
<> String
". Please correct the HERCULES_CI_API_BASE_URL environment variable."

getCredentialsFilePath :: IO FilePath
getCredentialsFilePath :: IO String
getCredentialsFilePath = do
  String
dir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgConfig String
"hercules-ci"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
dir String -> ShowS
</> String
"credentials.json"

readCredentials :: IO Credentials
readCredentials :: IO Credentials
readCredentials = do
  String
filePath_ <- IO String
getCredentialsFilePath
  String -> IO Bool
doesFileExist String
filePath_ forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text DomainCredentials -> Credentials
Credentials forall a. Monoid a => a
mempty)
    Bool
True -> do
      ByteString
bs <- String -> IO ByteString
BS.readFile String
filePath_
      forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate forall a b. (a -> b) -> a -> b
$ String
-> ByteString -> Either CredentialsParsingException Credentials
parseCredentials String
filePath_ ByteString
bs

parseCredentials :: FilePath -> ByteString -> Either CredentialsParsingException Credentials
parseCredentials :: String
-> ByteString -> Either CredentialsParsingException Credentials
parseCredentials String
filePath_ ByteString
bs =
  case forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
bs) of
    Right Credentials
a -> forall a b. b -> Either a b
Right Credentials
a
    Left String
e -> forall a b. a -> Either a b
Left (CredentialsParsingException {filePath :: String
filePath = String
filePath_, message :: Text
message = forall a b. ConvertText a b => a -> b
toS String
e})

writeCredentials :: Credentials -> IO ()
writeCredentials :: Credentials -> IO ()
writeCredentials Credentials
credentials = do
  String
filePath_ <- IO String
getCredentialsFilePath
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory String
filePath_)
  forall a. ToJSON a => String -> a -> IO ()
writeJsonFile String
filePath_ Credentials
credentials

urlDomain :: Text -> Either Text Text
urlDomain :: Text -> Either Text Text
urlDomain Text
urlText = do
  URI
uri <- forall e a. e -> Maybe a -> Either e a
maybeToEither Text
"could not parse HERCULES_CI_API_BASE_URL" forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
URI.parseAbsoluteURI (forall a b. ConvertText a b => a -> b
toS Text
urlText)
  URIAuth
authority <- forall e a. e -> Maybe a -> Either e a
maybeToEither Text
"HERCULES_CI_API_BASE_URL has no domain/authority part" forall a b. (a -> b) -> a -> b
$ URI -> Maybe URIAuth
URI.uriAuthority URI
uri
  let name :: String
name = URIAuth -> String
URI.uriRegName URIAuth
authority
  forall e a. e -> Maybe a -> Either e a
maybeToEither Text
"HERCULES_CI_API_BASE_URL domain name must not be empty" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
name forall a. Eq a => a -> a -> Bool
/= String
"")
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. ConvertText a b => a -> b
toS String
name)

determineDomain :: IO Text
determineDomain :: IO Text
determineDomain = do
  Text
baseUrl <- IO Text
determineDefaultApiBaseUrl
  forall exc (m :: * -> *) l a.
(Exception exc, MonadThrow m) =>
(l -> exc) -> Either l a -> m a
escalateAs Text -> ApiBaseUrlParsingException
ApiBaseUrlParsingException (Text -> Either Text Text
urlDomain Text
baseUrl)

writePersonalToken :: Text -> Text -> IO ()
writePersonalToken :: Text -> Text -> IO ()
writePersonalToken Text
domain Text
token = do
  Credentials
creds <- IO Credentials
readCredentials
  let creds' :: Credentials
creds' = Credentials
creds {domains :: Map Text DomainCredentials
domains = Credentials -> Map Text DomainCredentials
domains Credentials
creds forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
domain (Text -> DomainCredentials
DomainCredentials Text
token)}
  Credentials -> IO ()
writeCredentials Credentials
creds'

readPersonalToken :: Text -> IO Text
readPersonalToken :: Text -> IO Text
readPersonalToken Text
domain = do
  Credentials
creds <- IO Credentials
readCredentials
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
domain (Credentials -> Map Text DomainCredentials
domains Credentials
creds) of
    Maybe DomainCredentials
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO NoCredentialException {noCredentialDomain :: Text
noCredentialDomain = Text
domain}
    Just DomainCredentials
cred -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (DomainCredentials -> Text
personalToken DomainCredentials
cred)

-- | Try to get a token from the local environment.
--
-- 1. HERCULES_CI_API_TOKEN
-- 2. HERCULES_CI_SECRETS_JSON
tryReadEffectToken :: IO (Maybe Text)
tryReadEffectToken :: IO (Maybe Text)
tryReadEffectToken = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ MaybeT IO Text
tryReadEffectTokenFromEnv forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO Text
tryReadEffectTokenFromFile

tryReadEffectTokenFromEnv :: MaybeT IO Text
tryReadEffectTokenFromEnv :: MaybeT IO Text
tryReadEffectTokenFromEnv = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (String -> IO (Maybe String)
System.Environment.lookupEnv String
"HERCULES_CI_API_TOKEN")

tryReadEffectTokenFromFile :: MaybeT IO Text
tryReadEffectTokenFromFile :: MaybeT IO Text
tryReadEffectTokenFromFile = do
  String
inEffect <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
System.Environment.lookupEnv String
"IN_HERCULES_CI_EFFECT"
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ String
inEffect forall a. Eq a => a -> a -> Bool
== String
"true"
  String
secretsJsonPath <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
System.Environment.lookupEnv String
"HERCULES_CI_SECRETS_JSON"
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
    ByteString
bs <- String -> IO ByteString
BS.readFile String
secretsJsonPath
    Value
json <- case forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
bs) of
      Right Value
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value
x :: A.Value)
      Left String
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"HERCULES_CI_SECRETS_JSON, " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
secretsJsonPath forall a. Semigroup a => a -> a -> a
<> Text
" has invalid JSON: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
e
    case Value
json forall s a. s -> Getting (First a) s a -> Maybe a
^? forall t. AsValue t => Key -> Traversal' t Value
key Key
"hercules-ci" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"data" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"token" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t Text
_String of
      Just Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
      Maybe Text
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"HERCULES_CI_SECRETS_JSON, " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
secretsJsonPath forall a. Semigroup a => a -> a -> a
<> Text
" doesn't have key hercules-ci.data.token"

readToken :: IO Text -> IO Text
readToken :: IO Text -> IO Text
readToken IO Text
getDomain = do
  IO (Maybe Text)
tryReadEffectToken forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
x
    Maybe Text
Nothing -> Text -> IO Text
readPersonalToken forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Text
getDomain