{-# 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 hiding (mkVty)
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
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
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$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
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
Ord, Name -> Name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq, Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show)

instance SemEq Name where
    semeq :: Name -> Name -> Bool
semeq = 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoginState -> LoginState -> Bool
$c/= :: LoginState -> LoginState -> Bool
== :: LoginState -> LoginState -> Bool
$c== :: 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 =
    (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act)
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\HostNotResolved
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HostNotResolved -> AuthenticationException
ResolveError HostNotResolved
e)
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\HostCannotConnect
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ HostCannotConnect -> AuthenticationException
ConnectError HostCannotConnect
e)
        forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOError -> AuthenticationException
AuthIOError IOError
e)
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\MattermostError
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ MattermostError -> AuthenticationException
MattermostServerError MattermostError
e)
        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left 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 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    LoginRequest
req <- forall a. BChan a -> IO a
readBChan BChan LoginRequest
requestChan
    case LoginRequest
req of
        DoLogin Bool
initial ConnectionInfo
connInfo -> do
            forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ Bool -> Text -> LoginEvent
StartConnect Bool
initial forall a b. (a -> b) -> a -> b
$ ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname
            let doLog :: Text -> IO ()
doLog = LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()
ioLogWithManager LogManager
logMgr forall a. Maybe a
Nothing LogCategory
LogGeneral

            Text -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ Text
"Attempting authentication to " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.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 forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed 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
connInfoforall s a. s -> Getting a s a -> a
^.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 forall a b. (a -> b) -> a -> b
$ String -> Token
Token forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
accessToken

                          Either SomeException User
userResult <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ UserParam -> Session -> IO User
mmGetUser UserParam
UserMe Session
sess
                          forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ case Either SomeException User
userResult of
                              Left (SomeException
e::SomeException) ->
                                  LoginAttempt -> LoginEvent
LoginResult forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed forall a b. (a -> b) -> a -> b
$ SomeException -> AuthenticationException
OtherAuthError SomeException
e
                              Right User
user ->
                                  LoginAttempt -> LoginEvent
LoginResult 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
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciUsername
                                            , otpToken :: Maybe Text
otpToken = ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo (Maybe Text)
ciOTPToken
                                            , password :: Text
password = ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciPassword
                                            }

                          Either
  AuthenticationException
  (Either LoginFailureException (Session, User))
result <- forall a. IO a -> IO (Either AuthenticationException a)
convertLoginExceptions 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 forall a. Eq a => a -> a -> Bool
== Text
invalidMFATokenError -> do
                                  Text -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ Text
"Authenticated successfully to " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname forall a. Semigroup a => a -> a -> a
<> Text
" but MFA token is required"
                                  forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult forall a b. (a -> b) -> a -> b
$ ConnectionInfo -> LoginAttempt
MFATokenRequired ConnectionInfo
connInfo
                              Left AuthenticationException
e -> do
                                  Text -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ Text
"Error authenticating to " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show AuthenticationException
e)
                                  forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed AuthenticationException
e
                              Right (Left LoginFailureException
e) -> do
                                  Text -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ Text
"Error authenticating to " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show LoginFailureException
e)
                                  forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult forall a b. (a -> b) -> a -> b
$ AuthenticationException -> LoginAttempt
AttemptFailed forall a b. (a -> b) -> a -> b
$ LoginFailureException -> AuthenticationException
LoginError LoginFailureException
e
                              Right (Right (Session
sess, User
user)) -> do
                                  Text -> IO ()
doLog forall a b. (a -> b) -> a -> b
$ Text
"Authenticated successfully to " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname forall a. Semigroup a => a -> a -> a
<> Text
" as " forall a. Semigroup a => a -> a -> a
<> ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciUsername
                                  forall a. BChan a -> a -> IO ()
writeBChan BChan LoginEvent
respChan forall a b. (a -> b) -> a -> b
$ LoginAttempt -> LoginEvent
LoginResult 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ((Char -> Bool) -> Text -> [Text]
T.split (Char
'/'forall a. Eq a => a -> a -> Bool
==) (ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.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)]
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"BUG: findConnectionData: got failed pattern match on component list: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [(Text, Maybe Text)]
componentList

    componentList :: [(Text, Maybe Text)]
componentList =
        forall a. [a] -> [a]
reverse
        [ (Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
l, forall a. [a] -> Maybe a
listToMaybe [Text]
r)
        | ([Text]
l,[Text]
r) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. [a] -> [[a]]
inits [Text]
components) (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
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname)
                                    (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Int
ciPort))
                                    Text
path (ConnectionInfo
connInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo ConnectionType
ciType) ConnectionPoolConfig
poolCfg
          Either SomeException LimitedClientConfig
res <- forall e a. Exception e => IO a -> IO (Either e a)
try (ConnectionData -> IO LimitedClientConfig
mmGetLimitedClientConfiguration ConnectionData
cd)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! case Either SomeException LimitedClientConfig
res of
                    Left SomeException
e  -> forall a b. a -> Either a b
Left SomeException
e
                    Right{} -> 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 -> forall {t}.
t
-> [(Text, Maybe Text)]
-> IO (Either t (ConnectionData, Maybe Text))
search SomeException
e [(Text, Maybe Text)]
alternatives
           Right (ConnectionData, Maybe Text)
cd -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 forall a b. (a -> b) -> a -> b
$ Int
startupTimerMilliseconds forall a. Num a => a -> a -> a
* Int
1000
    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 <- forall a. Int -> IO (BChan a)
newBChan Int
10
    BChan LoginEvent
respChan <- forall a. Int -> IO (BChan a)
newBChan Int
10

    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO 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
            forall a. BChan a -> a -> IO ()
writeBChan BChan LoginRequest
requestChan forall a b. (a -> b) -> a -> b
$ Bool -> ConnectionInfo -> LoginRequest
DoLogin Bool
True ConnectionInfo
initialConfig
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ State
initialState forall a b. a -> (a -> b) -> b
& Lens' State LoginState
currentState forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> Text -> LoginState
Connecting Bool
True (ConnectionInfo
initialConfigforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname)
        Bool
False -> do
            forall (m :: * -> *) a. Monad m => a -> m a
return State
initialState

    (State
finalSt, Vty
finalVty) <- 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 (forall a. a -> Maybe a
Just BChan LoginEvent
respChan) App State LoginEvent Name
app State
startState

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case State
finalStforall s a. s -> Getting a s a -> a
^.Lens' State (Maybe LoginAttempt)
lastAttempt of
        Just (AttemptSucceeded ConnectionInfo
_ ConnectionData
cd Session
sess User
user Maybe Text
mbTeam) -> (forall a. a -> Maybe a
Just 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
_ -> (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 =
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname
        , forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciUsername
                   , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciPassword
                   ]
             , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciAccessToken
             ]
        , ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Int
ciPort 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 = forall {e}. Form ConnectionInfo e Name
form { formFocus :: FocusRing Name
formFocus = forall n. Eq n => n -> FocusRing n -> FocusRing n
focusSetCurrent Name
initialFocus (forall s e n. Form s e n -> FocusRing n
formFocus forall {e}. Form ConnectionInfo e Name
form)
                                          }
                      , _currentState :: LoginState
_currentState = LoginState
Idle
                      , _lastAttempt :: Maybe LoginAttempt
_lastAttempt = forall a. Maybe a
Nothing
                      , _reqChan :: BChan LoginRequest
_reqChan = BChan LoginRequest
chan
                      , _timeoutFired :: Bool
_timeoutFired = Bool
False
                      }
        form :: Form ConnectionInfo e Name
form = forall e. ConnectionInfo -> Form ConnectionInfo e Name
mkForm ConnectionInfo
cInfo
        initialFocus :: Name
initialFocus = if | Text -> Bool
T.null (ConnectionInfo
cInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname) -> Name
Server
                          | Text -> Bool
T.null (ConnectionInfo
cInfoforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciUsername) -> Name
Username
                          | Text -> Bool
T.null (ConnectionInfo
cInfoforall s a. s -> Getting a s a -> a
^.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 = 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   = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  , appAttrMap :: State -> AttrMap
appAttrMap      = 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
    Lens' State (Maybe LoginAttempt)
lastAttempt forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Maybe a
Nothing
    forall n s. EventM n s ()
halt
onEvent (AppEvent (StartConnect Bool
initial Text
host)) = do
    Lens' State LoginState
currentState forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool -> Text -> LoginState
Connecting Bool
initial Text
host
    Lens' State (Maybe LoginAttempt)
lastAttempt forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. Maybe a
Nothing
onEvent (AppEvent LoginEvent
StartupTimeout) = do
    -- If the startup timer fired and we have already succeeded, halt.
    Maybe LoginAttempt
a <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State (Maybe LoginAttempt)
lastAttempt
    case Maybe LoginAttempt
a of
        Just (AttemptSucceeded {}) -> forall n s. EventM n s ()
halt
        Maybe LoginAttempt
_ -> Lens' State Bool
timeoutFired forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
onEvent (AppEvent (LoginResult LoginAttempt
attempt)) = do
    Lens' State (Maybe LoginAttempt)
lastAttempt forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just LoginAttempt
attempt
    Lens' State LoginState
currentState 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 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State Bool
timeoutFired
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fired forall n s. EventM n s ()
halt
        AttemptFailed {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        MFATokenRequired ConnectionInfo
connInfo ->
            Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= (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 <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State LoginState
currentState
    case LoginState
s of
        Connecting {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        LoginState
Idle -> do
            Maybe LoginAttempt
a <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State (Maybe LoginAttempt)
lastAttempt
            case Maybe LoginAttempt
a of
                Just (AttemptSucceeded {}) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Maybe LoginAttempt
_ -> do
                    ConnectionInfo
ci <- forall s e n. Form s e n -> s
formState forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnectionInfo -> Bool
populatedConnectionInfo ConnectionInfo
ci) forall a b. (a -> b) -> a -> b
$ do
                        BChan LoginRequest
chan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' State (BChan LoginRequest)
reqChan
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. BChan a -> a -> IO ()
writeBChan BChan LoginRequest
chan forall a b. (a -> b) -> a -> b
$ Bool -> ConnectionInfo -> LoginRequest
DoLogin Bool
False ConnectionInfo
ci
onEvent BrickEvent Name LoginEvent
e = do
    forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm (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 = forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$
                    (forall n. Int -> Widget n -> Widget n
vLimit Int
1 forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
hLimit Int
22 forall a b. (a -> b) -> a -> b
$ forall n. String -> Widget n
str String
s forall n. Widget n -> Widget n -> Widget n
<+> forall n. Char -> Widget n
fill Char
' ') forall n. Widget n -> Widget n -> Widget n
<+> Widget n
w
        above :: String -> Widget n -> Widget n
above String
s Widget n
w = forall n. Widget n -> Widget n
hCenter (forall n. String -> Widget n
str String
s) forall n. Widget n -> Widget n -> Widget n
<=> Widget n
w
    in forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [ forall {n}. String -> Widget n -> Widget n
label String
"Server URL:"     forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= forall e. ConnectionInfo -> FormFieldState ConnectionInfo e Name
editServer
               , (forall {n}. String -> Widget n -> Widget n
above String
"Provide a username and password:" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  forall {n}. String -> Widget n -> Widget n
label String
"Username:")     forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> Maybe Int -> s -> FormFieldState s e n
editTextField Lens' ConnectionInfo Text
ciUsername Name
Username (forall a. a -> Maybe a
Just Int
1)
               , forall {n}. String -> Widget n -> Widget n
label String
"Password:"       forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> s -> FormFieldState s e n
editPasswordField Lens' ConnectionInfo Text
ciPassword Name
Password
               , (forall {n}. String -> Widget n -> Widget n
above String
"Or provide a Session or Personal Access Token:" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  forall {n}. String -> Widget n -> Widget n
label String
"Access Token:") forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= forall n s e.
(Ord n, Show n) =>
Lens' s Text -> n -> s -> FormFieldState s e n
editPasswordField 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 = forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$
                    (forall n. Int -> Widget n -> Widget n
vLimit Int
1 forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
hLimit Int
10 forall a b. (a -> b) -> a -> b
$ forall n. String -> Widget n
str String
s forall n. Widget n -> Widget n -> Widget n
<+> forall n. Char -> Widget n
fill Char
' ') forall n. Widget n -> Widget n -> Widget n
<+> Widget n
w
    in forall s e n. [s -> FormFieldState s e n] -> s -> Form s e n
newForm [forall {n}. String -> Widget n -> Widget n
label String
"OTP Token:" forall n s e.
(Widget n -> Widget n)
-> (s -> FormFieldState s e n) -> s -> FormFieldState s e n
@@= forall n s e.
(Show n, Ord n) =>
Lens' s (Maybe Text) -> n -> s -> FormFieldState s e n
editOptionalTextField 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
x,Int
y,Text
z,ConnectionType
w) -> ConnectionInfo
ci { _ciHostname :: Text
_ciHostname = Text
x, _ciPort :: Int
_ciPort = Int
y, _ciUrlPath :: Text
_ciUrlPath = Text
z, _ciType :: ConnectionType
_ciType = ConnectionType
w})
                       ((Text, Int, Text, ConnectionType)
-> f (Text, Int, Text, ConnectionType)
f (ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname, ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Int
ciPort, ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciUrlPath, ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.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
            []  -> forall a b. a -> Either a b
Left String
"No input"
            [Text
t] -> forall a b. b -> Either a b
Right Text
t
            [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://" 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  -> forall a b. a -> Either a b
Left String
"Unable to parse URI"
              Just URI
uri -> forall a b. b -> Either a b
Right URI
uri

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

     ConnectionType
ty <- case URI -> String
uriScheme URI
uri of
             String
"http:"           -> forall a b. b -> Either a b
Right ConnectionType
ConnectHTTP
             String
"https:"          -> forall a b. b -> Either a b
Right (Bool -> ConnectionType
ConnectHTTPS Bool
True)
             String
"https-insecure:" -> forall a b. b -> Either a b
Right (Bool -> ConnectionType
ConnectHTTPS Bool
False)
             String
_                 -> 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
"") -> forall a b. b -> Either a b
Right Int
80
               (ConnectHTTPS{}, String
"") -> forall a b. b -> Either a b
Right Int
443
               (ConnectionType
_, Char
':':String
portStr)
                 | Just Int
port <- forall a. Read a => String -> Maybe a
readMaybe String
portStr -> forall a b. b -> Either a b
Right Int
port
               (ConnectionType, String)
_ -> forall a b. a -> Either a b
Left String
"Invalid port"

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

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

     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 forall a. Semigroup a => a -> a -> a
<> Text
hStr forall a. Semigroup a => a -> a -> a
<> Text
portStr 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
':'forall a. Eq a => a -> a -> Bool
==Char
x) Text
h
      , (Char -> Bool) -> Text -> Bool
T.any (Char
':'forall a. Eq a => a -> a -> Bool
==) Text
h = Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
h 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
'/'forall a. Eq a => a -> a -> Bool
==) Text
u)

    portStr :: Text
portStr =
      case ConnectionType
t of
        ConnectionType
ConnectHTTP    | Int
p forall a. Eq a => a -> a -> Bool
==  Int
80 -> Text
T.empty
        ConnectHTTPS{} | Int
p forall a. Eq a => a -> a -> Bool
== Int
443 -> Text
T.empty
        ConnectionType
_                         -> String -> Text
T.pack (Char
':'forall a. a -> [a] -> [a]
: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{} -> forall a. Maybe a
Nothing
                   Right (Text, Int, Text, ConnectionType)
x-> forall a. a -> Maybe a
Just (Text, Int, Text, ConnectionType)
x
        limit :: Maybe Int
limit = forall a. a -> Maybe a
Just Int
1
        renderTxt :: [Text] -> Widget n
renderTxt [Text
""] = forall n. String -> Widget n
str String
"(Paste your Mattermost URL here)"
        renderTxt [Text]
ts = forall n. Text -> Widget n
txt ([Text] -> Text
T.unlines [Text]
ts)
    in 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 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 forall {n}. [Text] -> Widget n
renderTxt 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 forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat [Text]
ls
            in if Text -> Bool
T.null Text
stripped
               then forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
               else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
stripped
        renderTxt :: [Text] -> Widget n
renderTxt [Text]
ts = forall n. Text -> Widget n
txt ([Text] -> Text
T.unlines [Text]
ts)
    in 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 Lens' s (Maybe Text)
stLens n
n (forall a. a -> Maybe a
Just Int
1) forall {a}. IsString a => Maybe a -> a
ini [Text] -> Maybe (Maybe Text)
val forall {n}. [Text] -> Widget n
renderTxt 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 =
    [ forall n. Widget n -> Widget n
center forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox [ if State -> Bool
shouldShowForm State
st then State -> Widget Name
credentialsForm State
st else forall n. Widget n
emptyWidget
                    , State -> Widget Name
currentStateDisplay State
st
                    , Maybe LoginAttempt -> Widget Name
lastAttemptDisplay (State
stforall s a. s -> Getting a s a -> a
^.Lens' State (Maybe LoginAttempt)
lastAttempt)
                    ]
    ]

-- | Whether the login form should be displayed.
shouldShowForm :: State -> Bool
shouldShowForm :: State -> Bool
shouldShowForm State
st =
    case State
stforall s a. s -> Getting a s a -> a
^.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
stforall s a. s -> Getting a s a -> a
^.Lens' State (Maybe LoginAttempt)
lastAttempt of
            Just (AttemptSucceeded {}) -> State
stforall s a. s -> Getting a s a -> a
^.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 = forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> Widget n
hCenter forall a b. (a -> b) -> a -> b
$
                   forall n. Text -> Widget n
txt Text
"Connecting to " forall n. Widget n -> Widget n -> Widget n
<+> forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
clientEmphAttr (forall n. Text -> Widget n
txt Text
host) forall n. Widget n -> Widget n -> Widget n
<+> forall n. Text -> Widget n
txt Text
"..."
    in case State
stforall s a. s -> Getting a s a -> a
^.Lens' State LoginState
currentState of
          LoginState
Idle -> case State
stforall s a. s -> Getting a s a -> a
^.Lens' State (Maybe LoginAttempt)
lastAttempt of
              Just (AttemptSucceeded ConnectionInfo
ci ConnectionData
_ Session
_ User
_ Maybe Text
_) -> forall n. Text -> Widget n
msg (ConnectionInfo
ciforall s a. s -> Getting a s a -> a
^.Lens' ConnectionInfo Text
ciHostname)
              Maybe LoginAttempt
_ -> forall n. Widget n
emptyWidget
          (Connecting Bool
_ Text
host) -> forall n. Text -> Widget n
msg Text
host

lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name
lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name
lastAttemptDisplay Maybe LoginAttempt
Nothing = forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (AttemptSucceeded {})) = forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (MFATokenRequired ConnectionInfo
_)) = forall n. Widget n
emptyWidget
lastAttemptDisplay (Just (AttemptFailed AuthenticationException
e)) =
    forall n. Widget n -> Widget n
hCenter forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
hLimit Int
uiWidth forall a b. (a -> b) -> a -> b
$
    forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall n. Widget n -> Widget n
renderError forall a b. (a -> b) -> a -> b
$ forall a. SemEq a => Text -> Widget a
renderText forall a b. (a -> b) -> a -> b
$
    Text
"Error: " 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: " 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 forall a b. (a -> b) -> a -> b
$ 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 = 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 =
    forall n. Widget n -> Widget n
hCenter forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
hLimit Int
uiWidth forall a b. (a -> b) -> a -> b
$ forall n. Int -> Widget n -> Widget n
vLimit Int
15 forall a b. (a -> b) -> a -> b
$
    forall n. Widget n -> Widget n
border forall a b. (a -> b) -> a -> b
$
    forall n. [Widget n] -> Widget n
vBox [ forall a. SemEq a => Text -> Widget a
renderText Text
"Please enter your Mattermost credentials to log in."
         , forall n. Padding -> Widget n -> Widget n
padTop (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall n s e. Eq n => Form s e n -> Widget n
renderForm (State
stforall s a. s -> Getting a s a -> a
^.Lens' State (Form ConnectionInfo LoginEvent Name)
loginForm)
         , forall n. Widget n -> Widget n
hCenter forall a b. (a -> b) -> a -> b
$ forall a. SemEq a => Text -> Widget a
renderText Text
"Press Enter to log in or Esc to exit."
         ]