{-# 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 = pure do hostname <- liftIO getHostName username <- getLoginName clientEnv <- Hercules.CLI.Client.init runRIO ((), clientEnv) do r <- runHerculesClient' do Accounts.postCLIAuthorizationRequest accountsClient CLIAuthorizationRequestCreate { description = toS username <> "@" <> toS hostname } putErrText "Please confirm your login at " putErrText $ " " <> CLIAuthorizationRequestCreateResponse.browserURL r putErrText "Waiting for you to confirm using the link..." let tmpTok = CLIAuthorizationRequestCreateResponse.temporaryCLIToken r -- TODO do something pretty with 404 pollLoop = do s <- runHerculesClient' do Accounts.getCLIAuthorizationRequestStatus accountsClient tmpTok case CLIAuthorizationRequestStatus.status s of CLIAuthorizationRequestStatus.Pending {} -> do liftIO (threadDelay 1_000_000) pollLoop CLIAuthorizationRequestStatus.Granted g -> pure g granted <- pollLoop domain <- liftIO Credentials.determineDomain liftIO (Credentials.writePersonalToken domain (CLIAuthorizationRequestStatus.token granted)) for_ (CLIAuthorizationRequestStatus.userIdentities granted) \userIdentity -> putErrText $ "hci is configured to perform operations for " <> userIdentity <> " on " <> domain