{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NumericUnderscores #-}
module Hercules.CLI.Login
( commandParser,
)
where
import qualified Hercules.API.Accounts as Accounts
import Hercules.API.Accounts.CLIAuthorizationRequestCreate (CLIAuthorizationRequestCreate (CLIAuthorizationRequestCreate))
import qualified Hercules.API.Accounts.CLIAuthorizationRequestCreate as CLIAuthorizationRequestCreate
import qualified Hercules.API.Accounts.CLIAuthorizationRequestCreateResponse as CLIAuthorizationRequestCreateResponse
import qualified Hercules.API.Accounts.CLIAuthorizationRequestStatus as CLIAuthorizationRequestStatus
import Hercules.CLI.Client
import qualified Hercules.CLI.Credentials as Credentials
import Network.HostName (getHostName)
import qualified Options.Applicative as Optparse
import Protolude
import RIO (runRIO)
import System.Posix.User
commandParser :: Optparse.Parser (IO ())
commandParser :: Parser (IO ())
commandParser = forall (f :: * -> *) a. Applicative f => a -> f a
pure do
String
hostname <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getHostName
String
username <- IO String
getLoginName
HerculesClientEnv
clientEnv <- IO HerculesClientEnv
Hercules.CLI.Client.init
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ((), HerculesClientEnv
clientEnv) do
CLIAuthorizationRequestCreateResponse
r <- forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' do
forall auth f.
AccountsAPI auth f
-> f
:- (Summary "Create a request to authorize the CLI."
:> ("auth"
:> ("cli"
:> ("authorization"
:> ("request"
:> (ReqBody '[JSON] CLIAuthorizationRequestCreate
:> Post '[JSON] CLIAuthorizationRequestCreateResponse))))))
Accounts.postCLIAuthorizationRequest
AccountsAPI ClientAuth (AsClientT ClientM)
accountsClient
CLIAuthorizationRequestCreate
{ description :: Text
description = forall a b. ConvertText a b => a -> b
toS String
username forall a. Semigroup a => a -> a -> a
<> Text
"@" forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS String
hostname
}
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Please confirm your login at "
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
" " forall a. Semigroup a => a -> a -> a
<> CLIAuthorizationRequestCreateResponse -> Text
CLIAuthorizationRequestCreateResponse.browserURL CLIAuthorizationRequestCreateResponse
r
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Waiting for you to confirm using the link..."
let tmpTok :: Text
tmpTok = CLIAuthorizationRequestCreateResponse -> Text
CLIAuthorizationRequestCreateResponse.temporaryCLIToken CLIAuthorizationRequestCreateResponse
r
pollLoop :: RIO ((), HerculesClientEnv) CLIAuthorization
pollLoop = do
CLIAuthorizationRequestStatus
s <- forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' do
forall auth f.
AccountsAPI auth f
-> f
:- (Summary "Check the request status"
:> ("auth"
:> ("cli"
:> ("authorization"
:> ("request"
:> ("status"
:> (Capture "temporaryToken" Text
:> Get '[JSON] CLIAuthorizationRequestStatus)))))))
Accounts.getCLIAuthorizationRequestStatus AccountsAPI ClientAuth (AsClientT ClientM)
accountsClient Text
tmpTok
case CLIAuthorizationRequestStatus -> CLIAuthorizationStatus
CLIAuthorizationRequestStatus.status CLIAuthorizationRequestStatus
s of
CLIAuthorizationRequestStatus.Pending {} -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Int -> IO ()
threadDelay Int
1_000_000)
RIO ((), HerculesClientEnv) CLIAuthorization
pollLoop
CLIAuthorizationRequestStatus.Granted CLIAuthorization
g -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIAuthorization
g
CLIAuthorization
granted <- RIO ((), HerculesClientEnv) CLIAuthorization
pollLoop
Text
domain <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
Credentials.determineDomain
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Text -> IO ()
Credentials.writePersonalToken Text
domain (CLIAuthorization -> Text
CLIAuthorizationRequestStatus.token CLIAuthorization
granted))
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (CLIAuthorization -> [Text]
CLIAuthorizationRequestStatus.userIdentities CLIAuthorization
granted) \Text
userIdentity ->
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci is configured to perform operations for " forall a. Semigroup a => a -> a -> a
<> Text
userIdentity forall a. Semigroup a => a -> a -> a
<> Text
" on " forall a. Semigroup a => a -> a -> a
<> Text
domain