{-# 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
        -- TODO do something pretty with 404
        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