{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RankNTypes #-}
-- | This module provides the login interface for Matterhorn.
--
-- * Overview
--
-- The interface provides a set of form fields for the user to use to
-- enter their server information and credentials. The user enters
-- this information and presses Enter, and then this module
-- attempts to connect to the server. The module's main function,
-- interactiveGetLoginSession, returns the result of that connection
-- attempt, if any.
--
-- * Details
--
-- The interactiveGetLoginSession function takes the Matterhorn
-- configuration's initial connection information as input. If the
-- configuration provided a complete set of values needed to make a
-- login attempt, this module goes ahead and immediately makes a login
-- attempt before even showing the user the login form. This case is
-- the case where the configuration provided all four values needed:
-- server host name, port, username, and password. When the interface
-- immediately makes a login attempt under these conditions, this is
-- referred to as an "initial" attempt in various docstrings below.
-- Otherwise, the user is prompted to fill out the form to enter any
-- missing values. On pressing Enter, a login attempt is made.
--
-- A status message about whether a connection is underway is shown in
-- both cases: in the case where the user has edited the credentials and
-- pressed Enter, and in the case where the original credentials
-- provided to interactiveGetLoginSession caused an initial connection
-- attempt.
--
-- The "initial" login case is special because in addition to not
-- showing the form, we want to ensure that the "connecting to..."
-- status message that is shown is shown long enough for the user to
-- see what is happening (rather than just flashing by in the case
-- of a fast server connection). For this usability reason, we have
-- a "startup timer" thread: the thread waits a specified number
-- of milliseconds (see 'startupTimerMilliseconds' below) and then
-- notifies the interface that it has timed out. If there is an initial
-- connection attempt underway that succeeds *before* the timer
-- fires, we wait until the timer fires before quitting the Login
-- application and returning control to Matterhorn. This ensures that
-- the "connecting to..." message stays on the screen long enough to not
-- be jarring, and to show the user what is happening. If the connection
-- fails before the timer fires, we just resume normal operation and
-- show the login form so the user can intervene.
module Matterhorn.Login
  ( LoginSuccess(..)
  , interactiveGetLoginSession
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import           Brick
import           Brick.BChan
import           Brick.Focus
import           Brick.Forms
import           Brick.Widgets.Border
import           Brick.Widgets.Center
import           Brick.Widgets.Edit
import           Control.Concurrent ( forkIO, threadDelay )
import           Control.Exception ( SomeException, catch, try )
import           Data.Char (isHexDigit)
import           Data.List (tails, inits)
import           System.IO.Error ( catchIOError )
import qualified Data.Text as T
import           Graphics.Vty
import           Lens.Micro.Platform ( (.~), (.=), Lens', makeLenses )
import qualified System.IO.Error as Err
import           Network.URI ( URI(..), URIAuth(..), parseURI )

import           Network.Mattermost ( ConnectionData )
import           Network.Mattermost.Types.Internal ( Token(..) )
import           Network.Mattermost.Types ( Session(..), User, Login(..), ConnectionPoolConfig(..)
                                          , initConnectionData, ConnectionType(..), UserParam(..) )
import           Network.Mattermost.Exceptions ( LoginFailureException(..), MattermostError(..) )
import           Network.Mattermost.Endpoints ( mmGetUser, mmGetLimitedClientConfiguration, mmLogin )

import           Matterhorn.Draw.RichText
import           Matterhorn.Themes ( clientEmphAttr )
import           Matterhorn.Types ( ConnectionInfo(..)
                       , ciPassword, ciUsername, ciHostname, ciUrlPath
                       , ciPort, ciType, AuthenticationException(..)
                       , LogManager, LogCategory(..), ioLogWithManager
                       , ciAccessToken, ciOTPToken, SemEq(..)
                       )

-- | Resource names for the login interface.
data Name =
      Server
    | Username
    | Password
    | OTPToken
    | AccessToken
    deriving (Eq Name
Eq Name =>
(Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Name -> Name -> Ordering
compare :: Name -> Name -> Ordering
$c< :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
>= :: Name -> Name -> Bool
$cmax :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
min :: Name -> Name -> Name
Ord, Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
/= :: Name -> Name -> Bool
Eq, Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Name -> ShowS
showsPrec :: Int -> Name -> ShowS
$cshow :: Name -> String
show :: Name -> String
$cshowList :: [Name] -> ShowS
showList :: [Name] -> ShowS
Show)

instance SemEq Name where
    semeq :: Name -> Name -> Bool
semeq = Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==)

-- | The result of an authentication attempt.
data LoginAttempt =
    AttemptFailed AuthenticationException
    -- ^ The attempt failed with the corresponding error.
    | MFATokenRequired ConnectionInfo
    -- ^ The attempt succeeded, but additional MFA token is required.
    | AttemptSucceeded ConnectionInfo ConnectionData Session User (Maybe Text) --team
    -- ^ The attempt succeeded.

-- | The result of a successfull login attempt.
data LoginSuccess =
    LoginSuccess ConnectionData Session User (Maybe Text) --team
    -- ^ Data associated with the new logged-in session.

-- | The state of the login interface: whether a login attempt is
-- currently in progress.
data LoginState =
    Idle
    -- ^ No login attempt is in progress.
    | Connecting Bool Text
    -- ^ A login attempt to the specified host is in progress. The
    -- boolean flag indicates whether this login was user initiated
    -- (False) or triggered immediately when starting the interface
    -- (True). This "initial" flag is used to determine whether the
    -- login form is shown while the connection attempt is underway.
    deriving (LoginState -> LoginState -> Bool
(LoginState -> LoginState -> Bool)
-> (LoginState -> LoginState -> Bool) -> Eq LoginState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LoginState -> LoginState -> Bool
== :: LoginState -> LoginState -> Bool
$c/= :: LoginState -> LoginState -> Bool
/= :: LoginState -> LoginState -> Bool
Eq)

-- | Requests that we can make to the login worker thead.
data LoginRequest =
    DoLogin Bool ConnectionInfo
    -- ^ Request a login using the specified connection information.
    -- The boolean flag is the "initial" flag value corresponding to the
    -- "Connecting" constructor flag of the "LoginState" type.

-- | The messages that the login worker thread can send to the user
-- interface event handler.
data LoginEvent =
    StartConnect Bool Text
    -- ^ A connection to the specified host has begun. The boolean
    -- value is whether this was an "initial" connection attempt (see
    -- LoginState).
    | LoginResult LoginAttempt
    -- ^ A login attempt finished with the specified result.
    | StartupTimeout
    -- ^ The startup timer thread fired.

-- | The login application state.
data State =
    State { State -> Form ConnectionInfo LoginEvent Name
_loginForm :: Form ConnectionInfo LoginEvent Name
          , State -> Maybe LoginAttempt
_lastAttempt :: Maybe LoginAttempt
          , State -> LoginState
_currentState :: LoginState
          , State -> BChan LoginRequest
_reqChan :: BChan LoginRequest
          , State -> Bool
_timeoutFired :: Bool
          }

makeLenses ''State

-- | The HTTP connection pool settings for the login worker thread.
poolCfg :: ConnectionPoolConfig
poolCfg :: ConnectionPoolConfig
poolCfg = ConnectionPoolConfig { cpIdleConnTimeout :: NominalDiffTime
cpIdleConnTimeout = NominalDiffTime
60
                               , cpStripesCount :: Int
cpStripesCount = Int
1
                               , cpMaxConnCount :: Int
cpMaxConnCount = Int
5
                               }

-- | Error code used when login succeeds, but additional MFA token is required
invalidMFATokenError :: T.Text
invalidMFATokenError :: Text
invalidMFATokenError = Text
"mfa.validate_token.authenticate.app_error"

-- | Run an IO action and convert various kinds of thrown exceptions
-- into a returned AuthenticationException.
convertLoginExceptions :: IO a -> IO (Either AuthenticationException a)
convertLoginExceptions :: forall a. IO a -> IO (Either AuthenticationException a)
convertLoginExceptions IO a
act =
    (a -> Either AuthenticationException a
forall a b. b -> Either a b
Right (a -> Either AuthenticationException a)
-> IO a -> IO (Either AuthenticationException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act)
        IO (Either AuthenticationException a)
-> (HostNotResolved -> IO (Either AuthenticationException a))
-> IO (Either AuthenticationException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\HostNotResolved
e -> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthenticationException a
 -> IO (Either AuthenticationException a))
-> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> Either AuthenticationException a
forall a b. a -> Either a b
Left (AuthenticationException -> Either AuthenticationException a)
-> AuthenticationException -> Either AuthenticationException a
forall a b. (a -> b) -> a -> b
$ HostNotResolved -> AuthenticationException
ResolveError HostNotResolved
e)
        IO (Either AuthenticationException a)
-> (HostCannotConnect -> IO (Either AuthenticationException a))
-> IO (Either AuthenticationException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\HostCannotConnect
e -> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthenticationException a
 -> IO (Either AuthenticationException a))
-> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> Either AuthenticationException a
forall a b. a -> Either a b
Left (AuthenticationException -> Either AuthenticationException a)
-> AuthenticationException -> Either AuthenticationException a
forall a b. (a -> b) -> a -> b
$ HostCannotConnect -> AuthenticationException
ConnectError HostCannotConnect
e)
        IO (Either AuthenticationException a)
-> (IOError -> IO (Either AuthenticationException a))
-> IO (Either AuthenticationException a)
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthenticationException a
 -> IO (Either AuthenticationException a))
-> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> Either AuthenticationException a
forall a b. a -> Either a b
Left (AuthenticationException -> Either AuthenticationException a)
-> AuthenticationException -> Either AuthenticationException a
forall a b. (a -> b) -> a -> b
$ IOError -> AuthenticationException
AuthIOError IOError
e)
        IO (Either AuthenticationException a)
-> (MattermostError -> IO (Either AuthenticationException a))
-> IO (Either AuthenticationException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\MattermostError
e -> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthenticationException a
 -> IO (Either AuthenticationException a))
-> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> Either AuthenticationException a
forall a b. a -> Either a b
Left (AuthenticationException -> Either AuthenticationException a)
-> AuthenticationException -> Either AuthenticationException a
forall a b. (a -> b) -> a -> b
$ MattermostError -> AuthenticationException
MattermostServerError MattermostError
e)
        IO (Either AuthenticationException a)
-> (SomeException -> IO (Either AuthenticationException a))
-> IO (Either AuthenticationException a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\SomeException
e -> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthenticationException a
 -> IO (Either AuthenticationException a))
-> Either AuthenticationException a
-> IO (Either AuthenticationException a)
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> Either AuthenticationException a
forall a b. a -> Either a b
Left (AuthenticationException -> Either AuthenticationException a)
-> AuthenticationException -> Either AuthenticationException a
forall a b. (a -> b) -> a -> b
$ SomeException -> AuthenticationException
OtherAuthError SomeException
e)

-- | The login worker thread.
loginWorker :: (ConnectionData -> ConnectionData)
            -- ^ The function used to set the logger on the
            -- ConnectionData that results from a successful login
            -- attempt.
            -> LogManager
            -- ^ The log manager used to do logging.
            -> BChan LoginRequest
            -- ^ The channel on which we'll await requests.
            -> BChan LoginEvent
            -- ^ The channel to which we'll send login attempt results.
            -> IO ()
loginWorker :: (ConnectionData -> ConnectionData)
-> LogManager -> BChan LoginRequest -> BChan LoginEvent -> IO ()
loginWorker ConnectionData -> ConnectionData
setLogger LogManager
logMgr BChan LoginRequest
requestChan BChan LoginEvent
respChan = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    LoginRequest
req <- BChan LoginRequest -> IO LoginRequest
forall a. BChan a -> IO a
readBChan BChan LoginRequest
requestChan
    case LoginRequest
req of
        DoLogin Bool
initial ConnectionInfo
connInfo -> do
            BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Text -> LoginEvent
StartConnect Bool
initial (Text -> LoginEvent) -> Text -> LoginEvent
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname
            let doLog :: Text -> IO ()
doLog = LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()
ioLogWithManager LogManager
logMgr Maybe LogContext
forall a. Maybe a
Nothing LogCategory
LogGeneral

            Text -> IO ()
doLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Attempting authentication to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname

            Either SomeException (ConnectionData, Maybe Text)
cdResult <- ConnectionInfo
-> IO (Either SomeException (ConnectionData, Maybe Text))
findConnectionData ConnectionInfo
connInfo
            case Either SomeException (ConnectionData, Maybe Text)
cdResult of
              Left SomeException
e ->
                do BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed (AuthenticationException -> LoginAttempt)
-> AuthenticationException -> LoginAttempt
forall a b. (a -> b) -> a -> b
$ SomeException -> AuthenticationException
OtherAuthError SomeException
e
              Right (ConnectionData
cd_, Maybe Text
mbTeam) -> do
                  let cd :: ConnectionData
cd = ConnectionData -> ConnectionData
setLogger ConnectionData
cd_
                      accessToken :: Text
accessToken = ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciAccessToken
                  case Text -> Bool
T.null Text
accessToken of
                      Bool
False -> do
                          let sess :: Session
sess = ConnectionData -> Token -> Session
Session ConnectionData
cd (Token -> Session) -> Token -> Session
forall a b. (a -> b) -> a -> b
$ String -> Token
Token (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
accessToken

                          Either SomeException User
userResult <- IO User -> IO (Either SomeException User)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO User -> IO (Either SomeException User))
-> IO User -> IO (Either SomeException User)
forall a b. (a -> b) -> a -> b
$ UserParam -> Session -> IO User
mmGetUser UserParam
UserMe Session
sess
                          BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ case Either SomeException User
userResult of
                              Left (SomeException
e::SomeException) ->
                                  LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed (AuthenticationException -> LoginAttempt)
-> AuthenticationException -> LoginAttempt
forall a b. (a -> b) -> a -> b
$ SomeException -> AuthenticationException
OtherAuthError SomeException
e
                              Right User
user ->
                                  LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
-> ConnectionData -> Session -> User -> Maybe Text -> LoginAttempt
AttemptSucceeded ConnectionInfo
connInfo ConnectionData
cd Session
sess User
user Maybe Text
mbTeam
                      Bool
True -> do
                          let login :: Login
login = Login { username :: Text
username = ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUsername
                                            , otpToken :: Maybe Text
otpToken = ConnectionInfo
connInfoConnectionInfo
-> Getting (Maybe Text) ConnectionInfo (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Text) ConnectionInfo (Maybe Text)
Lens' ConnectionInfo (Maybe Text)
ciOTPToken
                                            , password :: Text
password = ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciPassword
                                            }

                          Either
  AuthenticationException
  (Either LoginFailureException (Session, User))
result <- IO (Either LoginFailureException (Session, User))
-> IO
     (Either
        AuthenticationException
        (Either LoginFailureException (Session, User)))
forall a. IO a -> IO (Either AuthenticationException a)
convertLoginExceptions (IO (Either LoginFailureException (Session, User))
 -> IO
      (Either
         AuthenticationException
         (Either LoginFailureException (Session, User))))
-> IO (Either LoginFailureException (Session, User))
-> IO
     (Either
        AuthenticationException
        (Either LoginFailureException (Session, User)))
forall a b. (a -> b) -> a -> b
$ ConnectionData
-> Login -> IO (Either LoginFailureException (Session, User))
mmLogin ConnectionData
cd Login
login
                          case Either
  AuthenticationException
  (Either LoginFailureException (Session, User))
result of
                              Left (MattermostServerError (MattermostError {mattermostErrorId :: MattermostError -> Text
mattermostErrorId = Text
errorId})) | Text
errorId Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
invalidMFATokenError -> do
                                  Text -> IO ()
doLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Authenticated successfully to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but MFA token is required"
                                  BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ ConnectionInfo -> LoginAttempt
MFATokenRequired ConnectionInfo
connInfo
                              Left AuthenticationException
e -> do
                                  Text -> IO ()
doLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error authenticating to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> String
forall a. Show a => a -> String
show AuthenticationException
e)
                                  BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed AuthenticationException
e
                              Right (Left LoginFailureException
e) -> do
                                  Text -> IO ()
doLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Error authenticating to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ LoginFailureException -> String
forall a. Show a => a -> String
show LoginFailureException
e)
                                  BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed (AuthenticationException -> LoginAttempt)
-> AuthenticationException -> LoginAttempt
forall a b. (a -> b) -> a -> b
$ LoginFailureException -> AuthenticationException
LoginError LoginFailureException
e
                              Right (Right (Session
sess, User
user)) -> do
                                  Text -> IO ()
doLog (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Authenticated successfully to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" as " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUsername
                                  BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan (LoginEvent -> IO ()) -> LoginEvent -> IO ()
forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult (LoginAttempt -> LoginEvent) -> LoginAttempt -> LoginEvent
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
-> ConnectionData -> Session -> User -> Maybe Text -> LoginAttempt
AttemptSucceeded ConnectionInfo
connInfo ConnectionData
cd Session
sess User
user Maybe Text
mbTeam



-- | Searches prefixes of the given URL to determine Mattermost API URL
-- path and team name
findConnectionData :: ConnectionInfo -> IO (Either SomeException (ConnectionData, Maybe Text))
findConnectionData :: ConnectionInfo
-> IO (Either SomeException (ConnectionData, Maybe Text))
findConnectionData ConnectionInfo
connInfo = IO (Either SomeException (ConnectionData, Maybe Text))
startSearch
  where
    components :: [Text]
components = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ((Char -> Bool) -> Text -> [Text]
T.split (Char
'/'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUrlPath))

    -- the candidates list is never empty because inits never returns an
    -- empty list
    ((Text, Maybe Text)
primary, [(Text, Maybe Text)]
alternatives) = case [(Text, Maybe Text)]
componentList of
        ((Text, Maybe Text)
p:[(Text, Maybe Text)]
as) -> ((Text, Maybe Text)
p, [(Text, Maybe Text)]
as)
        [(Text, Maybe Text)]
_ -> String -> ((Text, Maybe Text), [(Text, Maybe Text)])
forall a. HasCallStack => String -> a
error (String -> ((Text, Maybe Text), [(Text, Maybe Text)]))
-> String -> ((Text, Maybe Text), [(Text, Maybe Text)])
forall a b. (a -> b) -> a -> b
$ String
"BUG: findConnectionData: got failed pattern match on component list: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(Text, Maybe Text)] -> String
forall a. Show a => a -> String
show [(Text, Maybe Text)]
componentList

    componentList :: [(Text, Maybe Text)]
componentList =
        [(Text, Maybe Text)] -> [(Text, Maybe Text)]
forall a. [a] -> [a]
reverse
        [ (Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
l, [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe [Text]
r)
        | ([Text]
l,[Text]
r) <- [[Text]] -> [[Text]] -> [([Text], [Text])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Text] -> [[Text]]
forall a. [a] -> [[a]]
inits [Text]
components) ([Text] -> [[Text]]
forall a. [a] -> [[a]]
tails [Text]
components)
        ]

    tryCandidate :: (Text, Maybe Text)
                 -> IO (Either SomeException (ConnectionData, Maybe Text))
    tryCandidate :: (Text, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
tryCandidate (Text
path, Maybe Text
team) =
       do ConnectionData
cd  <- Text
-> Int
-> Text
-> ConnectionType
-> ConnectionPoolConfig
-> IO ConnectionData
initConnectionData (ConnectionInfo
connInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname)
                                    (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConnectionInfo
connInfoConnectionInfo -> Getting Int ConnectionInfo Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int ConnectionInfo Int
Lens' ConnectionInfo Int
ciPort))
                                    Text
path (ConnectionInfo
connInfoConnectionInfo
-> Getting ConnectionType ConnectionInfo ConnectionType
-> ConnectionType
forall s a. s -> Getting a s a -> a
^.Getting ConnectionType ConnectionInfo ConnectionType
Lens' ConnectionInfo ConnectionType
ciType) ConnectionPoolConfig
poolCfg
          Either SomeException LimitedClientConfig
res <- IO LimitedClientConfig
-> IO (Either SomeException LimitedClientConfig)
forall e a. Exception e => IO a -> IO (Either e a)
try (ConnectionData -> IO LimitedClientConfig
mmGetLimitedClientConfiguration ConnectionData
cd)
          Either SomeException (ConnectionData, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (ConnectionData, Maybe Text)
 -> IO (Either SomeException (ConnectionData, Maybe Text)))
-> Either SomeException (ConnectionData, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
forall a b. (a -> b) -> a -> b
$! case Either SomeException LimitedClientConfig
res of
                    Left SomeException
e  -> SomeException -> Either SomeException (ConnectionData, Maybe Text)
forall a b. a -> Either a b
Left SomeException
e
                    Right{} -> (ConnectionData, Maybe Text)
-> Either SomeException (ConnectionData, Maybe Text)
forall a b. b -> Either a b
Right (ConnectionData
cd, Maybe Text
team)

    -- This code prefers to report the error from the URL corresponding
    -- to what the user actually provided. Errors from derived URLs are
    -- lost in favor of this first error.
    startSearch :: IO (Either SomeException (ConnectionData, Maybe Text))
startSearch =
      do Either SomeException (ConnectionData, Maybe Text)
res1 <- (Text, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
tryCandidate (Text, Maybe Text)
primary
         case Either SomeException (ConnectionData, Maybe Text)
res1 of
           Left SomeException
e -> SomeException
-> [(Text, Maybe Text)]
-> IO (Either SomeException (ConnectionData, Maybe Text))
forall {t}.
t
-> [(Text, Maybe Text)]
-> IO (Either t (ConnectionData, Maybe Text))
search SomeException
e [(Text, Maybe Text)]
alternatives
           Right (ConnectionData, Maybe Text)
cd -> Either SomeException (ConnectionData, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ConnectionData, Maybe Text)
-> Either SomeException (ConnectionData, Maybe Text)
forall a b. b -> Either a b
Right (ConnectionData, Maybe Text)
cd)

    search :: t
-> [(Text, Maybe Text)]
-> IO (Either t (ConnectionData, Maybe Text))
search t
e [] = Either t (ConnectionData, Maybe Text)
-> IO (Either t (ConnectionData, Maybe Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t -> Either t (ConnectionData, Maybe Text)
forall a b. a -> Either a b
Left t
e)
    search t
e ((Text, Maybe Text)
x:[(Text, Maybe Text)]
xs) =
      do Either SomeException (ConnectionData, Maybe Text)
res <- (Text, Maybe Text)
-> IO (Either SomeException (ConnectionData, Maybe Text))
tryCandidate (Text, Maybe Text)
x
         case Either SomeException (ConnectionData, Maybe Text)
res of
           Left {}  -> t
-> [(Text, Maybe Text)]
-> IO (Either t (ConnectionData, Maybe Text))
search t
e [(Text, Maybe Text)]
xs
           Right (ConnectionData, Maybe Text)
cd -> Either t (ConnectionData, Maybe Text)
-> IO (Either t (ConnectionData, Maybe Text))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ConnectionData, Maybe Text)
-> Either t (ConnectionData, Maybe Text)
forall a b. b -> Either a b
Right (ConnectionData, Maybe Text)
cd)


-- | The amount of time that the startup timer thread will wait before
-- firing.
startupTimerMilliseconds :: Int
startupTimerMilliseconds :: Int
startupTimerMilliseconds = Int
750

-- | The startup timer thread.
startupTimer :: BChan LoginEvent -> IO ()
startupTimer :: BChan LoginEvent -> IO ()
startupTimer BChan LoginEvent
respChan = do
    Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
startupTimerMilliseconds Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000
    BChan LoginEvent -> LoginEvent -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan LoginEvent
StartupTimeout

-- | The main function of this module: interactively present a login
-- interface, get the user's input, and attempt to log into the user's
-- specified mattermost server.
--
-- This always returns the final terminal state handle. If the user
-- makes no login attempt, this returns Nothing. Otherwise it returns
-- Just the result of the latest attempt.
interactiveGetLoginSession :: Vty
                           -- ^ The initial terminal state handle to use.
                           -> IO Vty
                           -- ^ An action to build a new state handle
                           -- if one is needed. (In practice this
                           -- never fires since the login app doesn't
                           -- use suspendAndResume, but we need it to
                           -- satisfy the Brick API.)
                           -> (ConnectionData -> ConnectionData)
                           -- ^ The function to set the logger on
                           -- connection handles.
                           -> LogManager
                           -- ^ The log manager used to do logging.
                           -> ConnectionInfo
                           -- ^ Initial connection info to use to
                           -- populate the login form. If the connection
                           -- info provided here is fully populated, an
                           -- initial connection attempt is made without
                           -- first getting the user to hit Enter.
                           -> IO (Maybe LoginSuccess, Vty)
interactiveGetLoginSession :: Vty
-> IO Vty
-> (ConnectionData -> ConnectionData)
-> LogManager
-> ConnectionInfo
-> IO (Maybe LoginSuccess, Vty)
interactiveGetLoginSession Vty
vty IO Vty
mkVty ConnectionData -> ConnectionData
setLogger LogManager
logMgr ConnectionInfo
initialConfig = do
    BChan LoginRequest
requestChan <- Int -> IO (BChan LoginRequest)
forall a. Int -> IO (BChan a)
newBChan Int
10
    BChan LoginEvent
respChan <- Int -> IO (BChan LoginEvent)
forall a. Int -> IO (BChan a)
newBChan Int
10

    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ (ConnectionData -> ConnectionData)
-> LogManager -> BChan LoginRequest -> BChan LoginEvent -> IO ()
loginWorker ConnectionData -> ConnectionData
setLogger LogManager
logMgr BChan LoginRequest
requestChan BChan LoginEvent
respChan
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ BChan LoginEvent -> IO ()
startupTimer BChan LoginEvent
respChan

    let initialState :: State
initialState = ConnectionInfo -> BChan LoginRequest -> State
mkState ConnectionInfo
initialConfig BChan LoginRequest
requestChan

    State
startState <- case (ConnectionInfo -> Bool
populatedConnectionInfo ConnectionInfo
initialConfig) of
        Bool
True -> do
            BChan LoginRequest -> LoginRequest -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginRequest
requestChan (LoginRequest -> IO ()) -> LoginRequest -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> ConnectionInfo -> LoginRequest
DoLogin Bool
True ConnectionInfo
initialConfig
            State -> IO State
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> IO State) -> State -> IO State
forall a b. (a -> b) -> a -> b
$ State
initialState State -> (State -> State) -> State
forall a b. a -> (a -> b) -> b
& (LoginState -> Identity LoginState) -> State -> Identity State
Lens' State LoginState
currentState ((LoginState -> Identity LoginState) -> State -> Identity State)
-> LoginState -> State -> State
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> Text -> LoginState
Connecting Bool
True (ConnectionInfo
initialConfigConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname)
        Bool
False -> do
            State -> IO State
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return State
initialState

    (State
finalSt, Vty
finalVty) <- Vty
-> IO Vty
-> Maybe (BChan LoginEvent)
-> App State LoginEvent Name
-> State
-> IO (State, Vty)
forall n e s.
Ord n =>
Vty -> IO Vty -> Maybe (BChan e) -> App s e n -> s -> IO (s, Vty)
customMainWithVty Vty
vty IO Vty
mkVty (BChan LoginEvent -> Maybe (BChan LoginEvent)
forall a. a -> Maybe a
Just BChan LoginEvent
respChan) App State LoginEvent Name
app State
startState

    (Maybe LoginSuccess, Vty) -> IO (Maybe LoginSuccess, Vty)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe LoginSuccess, Vty) -> IO (Maybe LoginSuccess, Vty))
-> (Maybe LoginSuccess, Vty) -> IO (Maybe LoginSuccess, Vty)
forall a b. (a -> b) -> a -> b
$ case State
finalStState
-> Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> Maybe LoginAttempt
forall s a. s -> Getting a s a -> a
^.Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt of
        Just (AttemptSucceeded ConnectionInfo
_ ConnectionData
cd Session
sess User
user Maybe Text
mbTeam) -> (LoginSuccess -> Maybe LoginSuccess
forall a. a -> Maybe a
Just (LoginSuccess -> Maybe LoginSuccess)
-> LoginSuccess -> Maybe LoginSuccess
forall a b. (a -> b) -> a -> b
$ ConnectionData -> Session -> User -> Maybe Text -> LoginSuccess
LoginSuccess ConnectionData
cd Session
sess User
user Maybe Text
mbTeam, Vty
finalVty)
        Maybe LoginAttempt
_ -> (Maybe LoginSuccess
forall a. Maybe a
Nothing, Vty
finalVty)

-- | Is the specified ConnectionInfo sufficiently populated for us to
-- bother attempting to use it to connect?
populatedConnectionInfo :: ConnectionInfo -> Bool
populatedConnectionInfo :: ConnectionInfo -> Bool
populatedConnectionInfo ConnectionInfo
ci =
    [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname
        , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUsername
                   , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciPassword
                   ]
             , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciAccessToken
             ]
        , ConnectionInfo
ciConnectionInfo -> Getting Int ConnectionInfo Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int ConnectionInfo Int
Lens' ConnectionInfo Int
ciPort Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
        ]

-- | Make an initial login application state.
mkState :: ConnectionInfo -> BChan LoginRequest -> State
mkState :: ConnectionInfo -> BChan LoginRequest -> State
mkState ConnectionInfo
cInfo BChan LoginRequest
chan = State
state
    where
        state :: State
state = State { _loginForm :: Form ConnectionInfo LoginEvent Name
_loginForm = Form ConnectionInfo LoginEvent Name
forall {e}. Form ConnectionInfo e Name
form { formFocus = focusSetCurrent initialFocus (formFocus form)
                                          }
                      , _currentState :: LoginState
_currentState = LoginState
Idle
                      , _lastAttempt :: Maybe LoginAttempt
_lastAttempt = Maybe LoginAttempt
forall a. Maybe a
Nothing
                      , _reqChan :: BChan LoginRequest
_reqChan = BChan LoginRequest
chan
                      , _timeoutFired :: Bool
_timeoutFired = Bool
False
                      }
        form :: Form ConnectionInfo e Name
form = ConnectionInfo -> Form ConnectionInfo e Name
forall e. ConnectionInfo -> Form ConnectionInfo e Name
mkForm ConnectionInfo
cInfo
        initialFocus :: Name
initialFocus = if | Text -> Bool
T.null (ConnectionInfo
cInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname) -> Name
Server
                          | Text -> Bool
T.null (ConnectionInfo
cInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUsername) -> Name
Username
                          | Text -> Bool
T.null (ConnectionInfo
cInfoConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciPassword) -> Name
Password
                          | Bool
otherwise                  -> Name
Server

app :: App State LoginEvent Name
app :: App State LoginEvent Name
app = App
  { appDraw :: State -> [Widget Name]
appDraw         = State -> [Widget Name]
credsDraw
  , appChooseCursor :: State -> [CursorLocation Name] -> Maybe (CursorLocation Name)
appChooseCursor = State -> [CursorLocation Name] -> Maybe (CursorLocation Name)
forall s n. s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor
  , appHandleEvent :: BrickEvent Name LoginEvent -> EventM Name State ()
appHandleEvent  = BrickEvent Name LoginEvent -> EventM Name State ()
onEvent
  , appStartEvent :: EventM Name State ()
appStartEvent   = () -> EventM Name State ()
forall a. a -> EventM Name State a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  , appAttrMap :: State -> AttrMap
appAttrMap      = AttrMap -> State -> AttrMap
forall a b. a -> b -> a
const AttrMap
colorTheme
  }

onEvent :: BrickEvent Name LoginEvent -> EventM Name State ()
onEvent :: BrickEvent Name LoginEvent -> EventM Name State ()
onEvent (VtyEvent (EvKey Key
KEsc [])) = do
    (Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
-> State -> Identity State
Lens' State (Maybe LoginAttempt)
lastAttempt ((Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
 -> State -> Identity State)
-> Maybe LoginAttempt -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe LoginAttempt
forall a. Maybe a
Nothing
    EventM Name State ()
forall n s. EventM n s ()
halt
onEvent (AppEvent (StartConnect Bool
initial Text
host)) = do
    (LoginState -> Identity LoginState) -> State -> Identity State
Lens' State LoginState
currentState ((LoginState -> Identity LoginState) -> State -> Identity State)
-> LoginState -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool -> Text -> LoginState
Connecting Bool
initial Text
host
    (Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
-> State -> Identity State
Lens' State (Maybe LoginAttempt)
lastAttempt ((Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
 -> State -> Identity State)
-> Maybe LoginAttempt -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe LoginAttempt
forall a. Maybe a
Nothing
onEvent (AppEvent LoginEvent
StartupTimeout) = do
    -- If the startup timer fired and we have already succeeded, halt.
    Maybe LoginAttempt
a <- Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> EventM Name State (Maybe LoginAttempt)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt
    case Maybe LoginAttempt
a of
        Just (AttemptSucceeded {}) -> EventM Name State ()
forall n s. EventM n s ()
halt
        Maybe LoginAttempt
_ -> (Bool -> Identity Bool) -> State -> Identity State
Lens' State Bool
timeoutFired ((Bool -> Identity Bool) -> State -> Identity State)
-> Bool -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
onEvent (AppEvent (LoginResult LoginAttempt
attempt)) = do
    (Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
-> State -> Identity State
Lens' State (Maybe LoginAttempt)
lastAttempt ((Maybe LoginAttempt -> Identity (Maybe LoginAttempt))
 -> State -> Identity State)
-> Maybe LoginAttempt -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LoginAttempt -> Maybe LoginAttempt
forall a. a -> Maybe a
Just LoginAttempt
attempt
    (LoginState -> Identity LoginState) -> State -> Identity State
Lens' State LoginState
currentState ((LoginState -> Identity LoginState) -> State -> Identity State)
-> LoginState -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= LoginState
Idle

    case LoginAttempt
attempt of
        AttemptSucceeded {} -> do
            -- If the startup timer already fired, halt. Otherwise wait
            -- until that timer fires.
            Bool
fired <- Getting Bool State Bool -> EventM Name State Bool
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Bool State Bool
Lens' State Bool
timeoutFired
            Bool -> EventM Name State () -> EventM Name State ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fired EventM Name State ()
forall n s. EventM n s ()
halt
        AttemptFailed {} -> () -> EventM Name State ()
forall a. a -> EventM Name State a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        MFATokenRequired ConnectionInfo
connInfo ->
            (Form ConnectionInfo LoginEvent Name
 -> Identity (Form ConnectionInfo LoginEvent Name))
-> State -> Identity State
Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm ((Form ConnectionInfo LoginEvent Name
  -> Identity (Form ConnectionInfo LoginEvent Name))
 -> State -> Identity State)
-> Form ConnectionInfo LoginEvent Name -> EventM Name State ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (ConnectionInfo -> Form ConnectionInfo LoginEvent Name
forall e. ConnectionInfo -> Form ConnectionInfo e Name
mkOTPForm ConnectionInfo
connInfo)

onEvent (VtyEvent (EvKey Key
KEnter [])) = do
    -- Ignore the keypress if we are already attempting a connection, or
    -- if have already successfully connected but are waiting on the
    -- startup timer.
    LoginState
s <- Getting LoginState State LoginState -> EventM Name State LoginState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting LoginState State LoginState
Lens' State LoginState
currentState
    case LoginState
s of
        Connecting {} -> () -> EventM Name State ()
forall a. a -> EventM Name State a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LoginState
Idle -> do
            Maybe LoginAttempt
a <- Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> EventM Name State (Maybe LoginAttempt)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt
            case Maybe LoginAttempt
a of
                Just (AttemptSucceeded {}) -> () -> EventM Name State ()
forall a. a -> EventM Name State a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Maybe LoginAttempt
_ -> do
                    ConnectionInfo
ci <- Form ConnectionInfo LoginEvent Name -> ConnectionInfo
forall s e n. Form s e n -> s
formState (Form ConnectionInfo LoginEvent Name -> ConnectionInfo)
-> EventM Name State (Form ConnectionInfo LoginEvent Name)
-> EventM Name State ConnectionInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Form ConnectionInfo LoginEvent Name)
  State
  (Form ConnectionInfo LoginEvent Name)
-> EventM Name State (Form ConnectionInfo LoginEvent Name)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Form ConnectionInfo LoginEvent Name)
  State
  (Form ConnectionInfo LoginEvent Name)
Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm
                    Bool -> EventM Name State () -> EventM Name State ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnectionInfo -> Bool
populatedConnectionInfo ConnectionInfo
ci) (EventM Name State () -> EventM Name State ())
-> EventM Name State () -> EventM Name State ()
forall a b. (a -> b) -> a -> b
$ do
                        BChan LoginRequest
chan <- Getting (BChan LoginRequest) State (BChan LoginRequest)
-> EventM Name State (BChan LoginRequest)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (BChan LoginRequest) State (BChan LoginRequest)
Lens' State (BChan LoginRequest)
reqChan
                        IO () -> EventM Name State ()
forall a. IO a -> EventM Name State a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM Name State ()) -> IO () -> EventM Name State ()
forall a b. (a -> b) -> a -> b
$ BChan LoginRequest -> LoginRequest -> IO ()
forall a. BChan a -> a -> IO ()
writeBChan BChan LoginRequest
chan (LoginRequest -> IO ()) -> LoginRequest -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> ConnectionInfo -> LoginRequest
DoLogin Bool
False ConnectionInfo
ci
onEvent BrickEvent Name LoginEvent
e = do
    LensLike'
  (Zoomed (EventM Name (Form ConnectionInfo LoginEvent Name)) ())
  State
  (Form ConnectionInfo LoginEvent Name)
-> EventM Name (Form ConnectionInfo LoginEvent Name) ()
-> EventM Name State ()
forall c.
LensLike'
  (Zoomed (EventM Name (Form ConnectionInfo LoginEvent Name)) c)
  State
  (Form ConnectionInfo LoginEvent Name)
-> EventM Name (Form ConnectionInfo LoginEvent Name) c
-> EventM Name State c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom (Form ConnectionInfo LoginEvent Name
 -> Focusing
      (StateT (EventState Name) IO)
      ()
      (Form ConnectionInfo LoginEvent Name))
-> State -> Focusing (StateT (EventState Name) IO) () State
LensLike'
  (Zoomed (EventM Name (Form ConnectionInfo LoginEvent Name)) ())
  State
  (Form ConnectionInfo LoginEvent Name)
Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm (BrickEvent Name LoginEvent
-> EventM Name (Form ConnectionInfo LoginEvent Name) ()
forall n e s. Eq n => BrickEvent n e -> EventM n (Form s e n) ()
handleFormEvent BrickEvent Name LoginEvent
e)

mkForm :: ConnectionInfo -> Form ConnectionInfo e Name
mkForm :: forall e. ConnectionInfo -> Form ConnectionInfo e Name
mkForm =
    let label :: String -> Widget n -> Widget n
label String
s Widget n
w = Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
                    (Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit Int
1 (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit Int
22 (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ String -> Widget n
forall n. String -> Widget n
str String
s Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Char -> Widget n
forall n. Char -> Widget n
fill Char
' ') Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Widget n
w
        above :: String -> Widget n -> Widget n
above String
s Widget n
w = Widget n -> Widget n
forall n. Widget n -> Widget n
hCenter (String -> Widget n
forall n. String -> Widget n
str String
s) Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<=> Widget n
w
    in [ConnectionInfo -> FormFieldState ConnectionInfo e Name]
-> ConnectionInfo -> Form ConnectionInfo e Name
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [ String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
label String
"Server URL:"     (Widget Name -> Widget Name)
-> (ConnectionInfo -> FormFieldState ConnectionInfo e Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= ConnectionInfo -> FormFieldState ConnectionInfo e Name
forall e. ConnectionInfo -> FormFieldState ConnectionInfo e Name
editServer
               , (String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
above String
"Provide a username and password:" (Widget Name -> Widget Name)
-> (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
label String
"Username:")     (Widget Name -> Widget Name)
-> (ConnectionInfo -> FormFieldState ConnectionInfo e Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= Lens' ConnectionInfo Text
-> Name
-> Maybe Int
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> Maybe Int -> s -> FormFieldState s e n
editTextField (Text -> f Text) -> ConnectionInfo -> f ConnectionInfo
Lens' ConnectionInfo Text
ciUsername Name
Username (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
               , String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
label String
"Password:"       (Widget Name -> Widget Name)
-> (ConnectionInfo -> FormFieldState ConnectionInfo e Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= Lens' ConnectionInfo Text
-> Name -> ConnectionInfo -> FormFieldState ConnectionInfo e Name
forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> s -> FormFieldState s e n
editPasswordField (Text -> f Text) -> ConnectionInfo -> f ConnectionInfo
Lens' ConnectionInfo Text
ciPassword Name
Password
               , (String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
above String
"Or provide a Session or Personal Access Token:" (Widget Name -> Widget Name)
-> (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
label String
"Access Token:") (Widget Name -> Widget Name)
-> (ConnectionInfo -> FormFieldState ConnectionInfo e Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= Lens' ConnectionInfo Text
-> Name -> ConnectionInfo -> FormFieldState ConnectionInfo e Name
forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> s -> FormFieldState s e n
editPasswordField (Text -> f Text) -> ConnectionInfo -> f ConnectionInfo
Lens' ConnectionInfo Text
ciAccessToken Name
AccessToken
               ]

-- | This form deliberately doesn't provide fields other than the OTP token,
-- because they have already been validated by an initial authenticatin
-- attempty by the time this is used.
mkOTPForm :: ConnectionInfo -> Form ConnectionInfo e Name
mkOTPForm :: forall e. ConnectionInfo -> Form ConnectionInfo e Name
mkOTPForm =
    let label :: String -> Widget n -> Widget n
label String
s Widget n
w = Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
                    (Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit Int
1 (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit Int
10 (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ String -> Widget n
forall n. String -> Widget n
str String
s Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Char -> Widget n
forall n. Char -> Widget n
fill Char
' ') Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Widget n
w
    in [ConnectionInfo -> FormFieldState ConnectionInfo e Name]
-> ConnectionInfo -> Form ConnectionInfo e Name
forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [String -> Widget Name -> Widget Name
forall {n}. String -> Widget n -> Widget n
label String
"OTP Token:" (Widget Name -> Widget Name)
-> (ConnectionInfo -> FormFieldState ConnectionInfo e Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= Lens' ConnectionInfo (Maybe Text)
-> Name -> ConnectionInfo -> FormFieldState ConnectionInfo e Name
forall n s e.
(Show n, Ord n) =>
Lens' s (Maybe Text) -> n -> s -> FormFieldState s e n
editOptionalTextField (Maybe Text -> f (Maybe Text))
-> ConnectionInfo -> f ConnectionInfo
Lens' ConnectionInfo (Maybe Text)
ciOTPToken Name
OTPToken]

serverLens :: Lens' ConnectionInfo (Text, Int, Text, ConnectionType)
serverLens :: Lens' ConnectionInfo (Text, Int, Text, ConnectionType)
serverLens (Text, Int, Text, ConnectionType)
-> f (Text, Int, Text, ConnectionType)
f ConnectionInfo
ci = ((Text, Int, Text, ConnectionType) -> ConnectionInfo)
-> f (Text, Int, Text, ConnectionType) -> f ConnectionInfo
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
x,Int
y,Text
z,ConnectionType
w) -> ConnectionInfo
ci { _ciHostname = x, _ciPort = y, _ciUrlPath = z, _ciType = w})
                       ((Text, Int, Text, ConnectionType)
-> f (Text, Int, Text, ConnectionType)
f (ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname, ConnectionInfo
ciConnectionInfo -> Getting Int ConnectionInfo Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int ConnectionInfo Int
Lens' ConnectionInfo Int
ciPort, ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciUrlPath, ConnectionInfo
ciConnectionInfo
-> Getting ConnectionType ConnectionInfo ConnectionType
-> ConnectionType
forall s a. s -> Getting a s a -> a
^.Getting ConnectionType ConnectionInfo ConnectionType
Lens' ConnectionInfo ConnectionType
ciType))

-- | Validate a server URI @hostname[:port][/path]@. Result is either an error message
-- indicating why validation failed or a tuple of (hostname, port, path)
validServer :: [Text] -> Either String (Text, Int, Text, ConnectionType)
validServer :: [Text] -> Either String (Text, Int, Text, ConnectionType)
validServer [Text]
ts =

  do Text
t <- case [Text]
ts of
            []  -> String -> Either String Text
forall a b. a -> Either a b
Left String
"No input"
            [Text
t] -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
t
            [Text]
_   -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Too many lines"

     let inputWithScheme :: Text
inputWithScheme
           | Text
"://" Text -> Text -> Bool
`T.isInfixOf` Text
t = Text
t
           | Bool
otherwise = Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t

     URI
uri <- case String -> Maybe URI
parseURI (Text -> String
T.unpack Text
inputWithScheme) of
              Maybe URI
Nothing  -> String -> Either String URI
forall a b. a -> Either a b
Left String
"Unable to parse URI"
              Just URI
uri -> URI -> Either String URI
forall a b. b -> Either a b
Right URI
uri

     URIAuth
auth <- case URI -> Maybe URIAuth
uriAuthority URI
uri of
               Maybe URIAuth
Nothing   -> String -> Either String URIAuth
forall a b. a -> Either a b
Left String
"Missing authority part"
               Just URIAuth
auth -> URIAuth -> Either String URIAuth
forall a b. b -> Either a b
Right URIAuth
auth

     ConnectionType
ty <- case URI -> String
uriScheme URI
uri of
             String
"http:"           -> ConnectionType -> Either String ConnectionType
forall a b. b -> Either a b
Right ConnectionType
ConnectHTTP
             String
"https:"          -> ConnectionType -> Either String ConnectionType
forall a b. b -> Either a b
Right (Bool -> ConnectionType
ConnectHTTPS Bool
True)
             String
"https-insecure:" -> ConnectionType -> Either String ConnectionType
forall a b. b -> Either a b
Right (Bool -> ConnectionType
ConnectHTTPS Bool
False)
             String
_                 -> String -> Either String ConnectionType
forall a b. a -> Either a b
Left String
"Unknown scheme"

     Int
port <- case (ConnectionType
ty, URIAuth -> String
uriPort URIAuth
auth) of
               (ConnectionType
ConnectHTTP   , String
"") -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
80
               (ConnectHTTPS{}, String
"") -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
443
               (ConnectionType
_, Char
':':String
portStr)
                 | Just Int
port <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
portStr -> Int -> Either String Int
forall a b. b -> Either a b
Right Int
port
               (ConnectionType, String)
_ -> String -> Either String Int
forall a b. a -> Either a b
Left String
"Invalid port"

     let host :: String
host
           | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> String
uriRegName URIAuth
auth))
           , Char
'[' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Char
forall a. HasCallStack => [a] -> a
head (URIAuth -> String
uriRegName URIAuth
auth)
           , Char
']' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Char
forall a. HasCallStack => [a] -> a
last (URIAuth -> String
uriRegName URIAuth
auth)
           = ShowS
forall a. HasCallStack => [a] -> [a]
init (ShowS
forall a. HasCallStack => [a] -> [a]
tail (URIAuth -> String
uriRegName URIAuth
auth))
           | Bool
otherwise = URIAuth -> String
uriRegName URIAuth
auth

     if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> String
uriRegName URIAuth
auth) then String -> Either String ()
forall a b. a -> Either a b
Left String
"Missing server name" else () -> Either String ()
forall a b. b -> Either a b
Right ()
     if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriQuery URI
uri) then () -> Either String ()
forall a b. b -> Either a b
Right () else String -> Either String ()
forall a b. a -> Either a b
Left String
"Unexpected URI query"
     if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URI -> String
uriFragment URI
uri) then () -> Either String ()
forall a b. b -> Either a b
Right () else String -> Either String ()
forall a b. a -> Either a b
Left String
"Unexpected URI fragment"
     if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (URIAuth -> String
uriUserInfo URIAuth
auth) then () -> Either String ()
forall a b. b -> Either a b
Right () else String -> Either String ()
forall a b. a -> Either a b
Left String
"Unexpected credentials"

     (Text, Int, Text, ConnectionType)
-> Either String (Text, Int, Text, ConnectionType)
forall a b. b -> Either a b
Right (String -> Text
T.pack String
host, Int
port, String -> Text
T.pack (URI -> String
uriPath URI
uri), ConnectionType
ty)


renderServer :: (Text, Int, Text, ConnectionType) -> Text
renderServer :: (Text, Int, Text, ConnectionType) -> Text
renderServer (Text
h,Int
p,Text
u,ConnectionType
t) = Text
scheme Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
portStr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
uStr
  where
    hStr :: Text
hStr
      | (Char -> Bool) -> Text -> Bool
T.all (\Char
x -> Char -> Bool
isHexDigit Char
x Bool -> Bool -> Bool
|| Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
x) Text
h
      , (Char -> Bool) -> Text -> Bool
T.any (Char
':'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) Text
h = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
h Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
      | Bool
otherwise = Text
h

    scheme :: Text
scheme =
      case ConnectionType
t of
        ConnectionType
ConnectHTTP        -> Text
"http://"
        ConnectHTTPS Bool
True  -> Text
""
        ConnectHTTPS Bool
False -> Text
"https-insecure://"

    uStr :: Text
uStr
      | Text -> Bool
T.null Text
u = Text
u
      | Bool
otherwise = Char -> Text -> Text
T.cons Char
'/' ((Char -> Bool) -> Text -> Text
T.dropWhile (Char
'/'Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) Text
u)

    portStr :: Text
portStr =
      case ConnectionType
t of
        ConnectionType
ConnectHTTP    | Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==  Int
80 -> Text
T.empty
        ConnectHTTPS{} | Int
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
443 -> Text
T.empty
        ConnectionType
_                         -> String -> Text
T.pack (Char
':'Char -> ShowS
forall a. a -> [a] -> [a]
:Int -> String
forall a. Show a => a -> String
show Int
p)

editServer :: ConnectionInfo -> FormFieldState ConnectionInfo e Name
editServer :: forall e. ConnectionInfo -> FormFieldState ConnectionInfo e Name
editServer =
    let val :: [Text] -> Maybe (Text, Int, Text, ConnectionType)
val [Text]
ts = case [Text] -> Either String (Text, Int, Text, ConnectionType)
validServer [Text]
ts of
                   Left{} -> Maybe (Text, Int, Text, ConnectionType)
forall a. Maybe a
Nothing
                   Right (Text, Int, Text, ConnectionType)
x-> (Text, Int, Text, ConnectionType)
-> Maybe (Text, Int, Text, ConnectionType)
forall a. a -> Maybe a
Just (Text, Int, Text, ConnectionType)
x
        limit :: Maybe Int
limit = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        renderTxt :: [Text] -> Widget n
renderTxt [Text
""] = String -> Widget n
forall n. String -> Widget n
str String
"(Paste your Mattermost URL here)"
        renderTxt [Text]
ts = Text -> Widget n
forall n. Text -> Widget n
txt ([Text] -> Text
T.unlines [Text]
ts)
    in Lens' ConnectionInfo (Text, Int, Text, ConnectionType)
-> Name
-> Maybe Int
-> ((Text, Int, Text, ConnectionType) -> Text)
-> ([Text] -> Maybe (Text, Int, Text, ConnectionType))
-> ([Text] -> Widget Name)
-> (Widget Name -> Widget Name)
-> ConnectionInfo
-> FormFieldState ConnectionInfo e Name
forall n s a e.
(Ord n, Show n) =>
Lens' s a
-> n
-> Maybe Int
-> (a -> Text)
-> ([Text] -> Maybe a)
-> ([Text] -> Widget n)
-> (Widget n -> Widget n)
-> s
-> FormFieldState s e n
editField ((Text, Int, Text, ConnectionType)
 -> f (Text, Int, Text, ConnectionType))
-> ConnectionInfo -> f ConnectionInfo
Lens' ConnectionInfo (Text, Int, Text, ConnectionType)
serverLens Name
Server Maybe Int
limit (Text, Int, Text, ConnectionType) -> Text
renderServer [Text] -> Maybe (Text, Int, Text, ConnectionType)
val [Text] -> Widget Name
forall {n}. [Text] -> Widget n
renderTxt Widget Name -> Widget Name
forall a. a -> a
id

editOptionalTextField :: (Show n, Ord n) => Lens' s (Maybe T.Text) -> n -> s -> FormFieldState s e n
editOptionalTextField :: forall n s e.
(Show n, Ord n) =>
Lens' s (Maybe Text) -> n -> s -> FormFieldState s e n
editOptionalTextField Lens' s (Maybe Text)
stLens n
n =
    let ini :: Maybe a -> a
ini Maybe a
Nothing = a
""
        ini (Just a
t) = a
t
        val :: [Text] -> Maybe (Maybe Text)
val [Text]
ls =
            let stripped :: Text
stripped = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text]
ls
            in if Text -> Bool
T.null Text
stripped
               then Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just Maybe Text
forall a. Maybe a
Nothing
               else Maybe Text -> Maybe (Maybe Text)
forall a. a -> Maybe a
Just (Maybe Text -> Maybe (Maybe Text))
-> Maybe Text -> Maybe (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stripped
        renderTxt :: [Text] -> Widget n
renderTxt [Text]
ts = Text -> Widget n
forall n. Text -> Widget n
txt ([Text] -> Text
T.unlines [Text]
ts)
    in Lens' s (Maybe Text)
-> n
-> Maybe Int
-> (Maybe Text -> Text)
-> ([Text] -> Maybe (Maybe Text))
-> ([Text] -> Widget n)
-> (Widget n -> Widget n)
-> s
-> FormFieldState s e n
forall n s a e.
(Ord n, Show n) =>
Lens' s a
-> n
-> Maybe Int
-> (a -> Text)
-> ([Text] -> Maybe a)
-> ([Text] -> Widget n)
-> (Widget n -> Widget n)
-> s
-> FormFieldState s e n
editField (Maybe Text -> f (Maybe Text)) -> s -> f s
Lens' s (Maybe Text)
stLens n
n (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Maybe Text -> Text
forall {a}. IsString a => Maybe a -> a
ini [Text] -> Maybe (Maybe Text)
val [Text] -> Widget n
forall {n}. [Text] -> Widget n
renderTxt Widget n -> Widget n
forall a. a -> a
id

errorAttr :: AttrName
errorAttr :: AttrName
errorAttr = String -> AttrName
attrName String
"errorMessage"

colorTheme :: AttrMap
colorTheme :: AttrMap
colorTheme = Attr -> [(AttrName, Attr)] -> AttrMap
attrMap Attr
defAttr
  [ (AttrName
editAttr, Color
black Color -> Color -> Attr
`on` Color
white)
  , (AttrName
editFocusedAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
  , (AttrName
errorAttr, Color -> Attr
fg Color
red)
  , (AttrName
focusedFormInputAttr, Color
black Color -> Color -> Attr
`on` Color
yellow)
  , (AttrName
invalidFormInputAttr, Color
white Color -> Color -> Attr
`on` Color
red)
  , (AttrName
clientEmphAttr, Color -> Attr
fg Color
white Attr -> Style -> Attr
`withStyle` Style
bold)
  ]

credsDraw :: State -> [Widget Name]
credsDraw :: State -> [Widget Name]
credsDraw State
st =
    [ Widget Name -> Widget Name
forall n. Widget n -> Widget n
center (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox [ if State -> Bool
shouldShowForm State
st then State -> Widget Name
credentialsForm State
st else Widget Name
forall n. Widget n
emptyWidget
                    , State -> Widget Name
currentStateDisplay State
st
                    , Maybe LoginAttempt -> Widget Name
lastAttemptDisplay (State
stState
-> Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> Maybe LoginAttempt
forall s a. s -> Getting a s a -> a
^.Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt)
                    ]
    ]

-- | Whether the login form should be displayed.
shouldShowForm :: State -> Bool
shouldShowForm :: State -> Bool
shouldShowForm State
st =
    case State
stState -> Getting LoginState State LoginState -> LoginState
forall s a. s -> Getting a s a -> a
^.Getting LoginState State LoginState
Lens' State LoginState
currentState of
        -- If we're connecting, only show the form if the connection
        -- attempt is not an initial one.
        Connecting Bool
initial Text
_ -> Bool -> Bool
not Bool
initial

        -- If we're idle, we want to show the form - unless we have
        -- already connected and are waiting for the startup timer to
        -- fire.
        LoginState
Idle -> case State
stState
-> Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> Maybe LoginAttempt
forall s a. s -> Getting a s a -> a
^.Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt of
            Just (AttemptSucceeded {}) -> State
stState -> Getting Bool State Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool State Bool
Lens' State Bool
timeoutFired
            Maybe LoginAttempt
_ -> Bool
True

-- | The "current state" of the login process. Show a connecting status
-- message if a connection is underway, or if one is already established
-- and the startup timer has not fired.
currentStateDisplay :: State -> Widget Name
currentStateDisplay :: State -> Widget Name
currentStateDisplay State
st =
    let msg :: Text -> Widget n
msg Text
host = Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Widget n -> Widget n
forall n. Widget n -> Widget n
hCenter (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
                   Text -> Widget n
forall n. Text -> Widget n
txt Text
"Connecting to " Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr (Text -> Widget n
forall n. Text -> Widget n
txt Text
host) Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Text -> Widget n
forall n. Text -> Widget n
txt Text
"..."
    in case State
stState -> Getting LoginState State LoginState -> LoginState
forall s a. s -> Getting a s a -> a
^.Getting LoginState State LoginState
Lens' State LoginState
currentState of
          LoginState
Idle -> case State
stState
-> Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
-> Maybe LoginAttempt
forall s a. s -> Getting a s a -> a
^.Getting (Maybe LoginAttempt) State (Maybe LoginAttempt)
Lens' State (Maybe LoginAttempt)
lastAttempt of
              Just (AttemptSucceeded ConnectionInfo
ci ConnectionData
_ Session
_ User
_ Maybe Text
_) -> Text -> Widget Name
forall n. Text -> Widget n
msg (ConnectionInfo
ciConnectionInfo -> Getting Text ConnectionInfo Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text ConnectionInfo Text
Lens' ConnectionInfo Text
ciHostname)
              Maybe LoginAttempt
_ -> Widget Name
forall n. Widget n
emptyWidget
          (Connecting Bool
_ Text
host) -> Text -> Widget Name
forall n. Text -> Widget n
msg Text
host

lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name
lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name
lastAttemptDisplay Maybe LoginAttempt
Nothing = Widget Name
forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (AttemptSucceeded {})) = Widget Name
forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (MFATokenRequired ConnectionInfo
_)) = Widget Name
forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (AttemptFailed AuthenticationException
e)) =
    Widget Name -> Widget Name
forall n. Widget n -> Widget n
hCenter (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
hLimit Int
uiWidth (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
    Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Widget Name -> Widget Name
forall n. Widget n -> Widget n
renderError (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
forall a. SemEq a => Text -> Widget a
renderText (Text -> Widget Name) -> Text -> Widget Name
forall a b. (a -> b) -> a -> b
$
    Text
"Error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AuthenticationException -> Text
renderAuthError AuthenticationException
e

renderAuthError :: AuthenticationException -> Text
renderAuthError :: AuthenticationException -> Text
renderAuthError (ConnectError HostCannotConnect
_) =
    Text
"Could not connect to server"
renderAuthError (ResolveError HostNotResolved
_) =
    Text
"Could not resolve server hostname"
renderAuthError (MattermostServerError MattermostError
e) =
    MattermostError -> Text
mattermostErrorMessage MattermostError
e
renderAuthError (AuthIOError IOError
err)
  | IOErrorType -> Bool
Err.isDoesNotExistErrorType (IOError -> IOErrorType
Err.ioeGetErrorType IOError
err) =
    Text
"Unable to connect to the network"
  | Bool
otherwise = Text
"GetAddrInfo: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (IOError -> String
Err.ioeGetErrorString IOError
err)
renderAuthError (OtherAuthError SomeException
e) =
    String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
renderAuthError (LoginError (LoginFailureException String
msg)) =
    String -> Text
T.pack String
msg

renderError :: Widget a -> Widget a
renderError :: forall n. Widget n -> Widget n
renderError = AttrName -> Widget a -> Widget a
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
errorAttr

uiWidth :: Int
uiWidth :: Int
uiWidth = Int
60

credentialsForm :: State -> Widget Name
credentialsForm :: State -> Widget Name
credentialsForm State
st =
    Widget Name -> Widget Name
forall n. Widget n -> Widget n
hCenter (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
hLimit Int
uiWidth (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Int -> Widget Name -> Widget Name
forall n. Int -> Widget n -> Widget n
vLimit Int
15 (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
    Widget Name -> Widget Name
forall n. Widget n -> Widget n
border (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$
    [Widget Name] -> Widget Name
forall n. [Widget n] -> Widget n
vBox [ Text -> Widget Name
forall a. SemEq a => Text -> Widget a
renderText Text
"Please enter your Mattermost credentials to log in."
         , Padding -> Widget Name -> Widget Name
forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Form ConnectionInfo LoginEvent Name -> Widget Name
forall n s e. Eq n => Form s e n -> Widget n
renderForm (State
stState
-> Getting
     (Form ConnectionInfo LoginEvent Name)
     State
     (Form ConnectionInfo LoginEvent Name)
-> Form ConnectionInfo LoginEvent Name
forall s a. s -> Getting a s a -> a
^.Getting
  (Form ConnectionInfo LoginEvent Name)
  State
  (Form ConnectionInfo LoginEvent Name)
Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm)
         , Widget Name -> Widget Name
forall n. Widget n -> Widget n
hCenter (Widget Name -> Widget Name) -> Widget Name -> Widget Name
forall a b. (a -> b) -> a -> b
$ Text -> Widget Name
forall a. SemEq a => Text -> Widget a
renderText Text
"Press Enter to log in or Esc to exit."
         ]