{-# 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 = IO () -> Parser (IO ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
String
hostname <- IO String -> IO String
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
((), HerculesClientEnv) -> RIO ((), HerculesClientEnv) () -> IO ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ((), HerculesClientEnv
clientEnv) do
CLIAuthorizationRequestCreateResponse
r <- ClientM CLIAuthorizationRequestCreateResponse
-> RIO
((), HerculesClientEnv) CLIAuthorizationRequestCreateResponse
forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' do
AccountsAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
:- (Summary "Create a request to authorize the CLI."
:> ("auth"
:> ("cli"
:> ("authorization"
:> ("request"
:> (ReqBody '[JSON] CLIAuthorizationRequestCreate
:> Post '[JSON] CLIAuthorizationRequestCreateResponse))))))
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 :: Text -> CLIAuthorizationRequestCreate
CLIAuthorizationRequestCreate
{ description :: Text
description = String -> Text
forall a b. ConvertText a b => a -> b
toS String
username Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a b. ConvertText a b => a -> b
toS String
hostname
}
Text -> RIO ((), HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Please confirm your login at "
Text -> RIO ((), HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> RIO ((), HerculesClientEnv) ())
-> Text -> RIO ((), HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CLIAuthorizationRequestCreateResponse -> Text
CLIAuthorizationRequestCreateResponse.browserURL CLIAuthorizationRequestCreateResponse
r
Text -> RIO ((), HerculesClientEnv) ()
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 <- ClientM CLIAuthorizationRequestStatus
-> RIO ((), HerculesClientEnv) CLIAuthorizationRequestStatus
forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' do
AccountsAPI ClientAuth (AsClientT ClientM)
-> AsClientT ClientM
:- (Summary "Check the request status"
:> ("auth"
:> ("cli"
:> ("authorization"
:> ("request"
:> ("status"
:> (Capture "temporaryToken" Text
:> Get '[JSON] CLIAuthorizationRequestStatus)))))))
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
IO () -> RIO ((), HerculesClientEnv) ()
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 -> CLIAuthorization -> RIO ((), HerculesClientEnv) CLIAuthorization
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIAuthorization
g
CLIAuthorization
granted <- RIO ((), HerculesClientEnv) CLIAuthorization
pollLoop
Text
domain <- IO Text -> RIO ((), HerculesClientEnv) Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Text
Credentials.determineDomain
IO () -> RIO ((), HerculesClientEnv) ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Text -> IO ()
Credentials.writePersonalToken Text
domain (CLIAuthorization -> Text
CLIAuthorizationRequestStatus.token CLIAuthorization
granted))
[Text]
-> (Text -> RIO ((), HerculesClientEnv) ())
-> RIO ((), HerculesClientEnv) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (CLIAuthorization -> [Text]
CLIAuthorizationRequestStatus.userIdentities CLIAuthorization
granted) \Text
userIdentity ->
Text -> RIO ((), HerculesClientEnv) ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (Text -> RIO ((), HerculesClientEnv) ())
-> Text -> RIO ((), HerculesClientEnv) ()
forall a b. (a -> b) -> a -> b
$ Text
"hci is configured to perform operations for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
userIdentity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" on " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain