{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE DataKinds #-}

-- | Authentication-related stuff
module MatrixBot.Auth where

import GHC.Generics

import Data.Proxy
import Data.Text (pack)
import Data.Aeson (ToJSON (..), FromJSON (..))

import Control.Exception.Safe (MonadThrow)
import Control.Lens (Lens', view)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Reader
import qualified Control.Monad.Logger as ML

import Servant.API (AuthProtect)
import Servant.Client.Core (addHeader)
import Servant.Client.Core.Auth

import MatrixBot.AesonUtils (myGenericToJSON, myGenericParseJSON)
import MatrixBot.Log
import qualified MatrixBot.MatrixApi as Api
import qualified MatrixBot.MatrixApi.Client as Api
import qualified MatrixBot.MatrixApi.Types.MEventTypes as Api
import qualified MatrixBot.SharedTypes as T


-- * Functions

authenticate
  ∷ (MonadIO m, MonadFail m, MonadUnliftIO m, MonadThrow m, ML.MonadLogger m)
  ⇒ T.Mxid
  → T.Password
  → m Credentials
authenticate :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadUnliftIO m, MonadThrow m,
 MonadLogger m) =>
Mxid -> Password -> m Credentials
authenticate Mxid
mxid Password
password = do
  Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
    Text
"Creating request handler for "
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Mxid -> String) -> Mxid -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (Mxid -> Text) -> Mxid -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeServer -> Text
T.unHomeServer (HomeServer -> Text) -> (Mxid -> HomeServer) -> Mxid -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mxid -> HomeServer
T.mxidHomeServer) Mxid
mxid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"

  MatrixApiClient
req ← RequestOptions -> HomeServer -> m MatrixApiClient
forall (m :: * -> *).
(MonadIO m, MonadThrow m, MonadLogger m) =>
RequestOptions -> HomeServer -> m MatrixApiClient
Api.mkMatrixApiClient RequestOptions
Api.defaultRequestOptions (HomeServer -> m MatrixApiClient)
-> (Mxid -> HomeServer) -> Mxid -> m MatrixApiClient
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mxid -> HomeServer
T.mxidHomeServer (Mxid -> m MatrixApiClient) -> Mxid -> m MatrixApiClient
forall a b. (a -> b) -> a -> b
$ Mxid
mxid

  Text -> m ()
forall (m :: * -> *). (MonadLogger m, HasCallStack) => Text -> m ()
logDebug (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Authenticating as " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
pack (String -> Text) -> (Mxid -> String) -> Mxid -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show (Text -> String) -> (Mxid -> Text) -> Mxid -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mxid -> Text
T.printMxid) Mxid
mxid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"

  LoginResponse
response ←
    MatrixApiClient
-> forall api (m :: * -> *) a.
   (MonadIO m, MonadFail m, Show a, MonadThrow m, MonadLogger m,
    HasClient (Free ClientF) api, HasClient ClientM api) =>
   Proxy api
   -> (forall (clientM :: * -> *).
       HasClient clientM api =>
       Client clientM api -> clientM a)
   -> m a
Api.runMatrixApiClientDoNotShowReqBody' MatrixApiClient
req (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Api.LoginApi) ((forall {clientM :: * -> *}.
  HasClient clientM LoginApi =>
  Client clientM LoginApi -> clientM LoginResponse)
 -> m LoginResponse)
-> (forall {clientM :: * -> *}.
    HasClient clientM LoginApi =>
    Client clientM LoginApi -> clientM LoginResponse)
-> m LoginResponse
forall a b. (a -> b) -> a -> b
$ \Client clientM LoginApi
f → Client clientM LoginApi
LoginRequest -> clientM LoginResponse
f Api.LoginRequest
      { loginRequestType :: MEventTypeOneOf '[ 'MLoginPasswordType]
Api.loginRequestType = MEventTypeOneOf '[ 'MLoginPasswordType]
forall (types :: [MEventType]).
(OneOf 'MLoginPasswordType types ~ 'True) =>
MEventTypeOneOf types
Api.MLoginPasswordTypeOneOf
      , loginRequestUser :: Username
Api.loginRequestUser = Mxid -> Username
T.mxidUsername Mxid
mxid
      , loginRequestPassword :: Password
Api.loginRequestPassword = Password
password
      }

  Credentials -> m Credentials
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Credentials
    { credentialsUsername :: Username
credentialsUsername = Mxid -> Username
T.mxidUsername (Mxid -> Username)
-> (LoginResponse -> Mxid) -> LoginResponse -> Username
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoginResponse -> Mxid
Api.loginResponseUserId (LoginResponse -> Username) -> LoginResponse -> Username
forall a b. (a -> b) -> a -> b
$ LoginResponse
response
    , credentialsHomeServer :: HomeServer
credentialsHomeServer = LoginResponse -> HomeServer
Api.loginResponseHomeServer LoginResponse
response
    , credentialsAccessToken :: AccessToken
credentialsAccessToken = LoginResponse -> AccessToken
Api.loginResponseAccessToken LoginResponse
response
    }


getAuthenticatedMatrixRequest
  ∷ (MonadReader r m, HasCredentials r)
  ⇒ m (AuthenticatedRequest (AuthProtect "access-token"))
getAuthenticatedMatrixRequest :: forall r (m :: * -> *).
(MonadReader r m, HasCredentials r) =>
m (AuthenticatedRequest (AuthProtect "access-token"))
getAuthenticatedMatrixRequest = do
  AccessToken
token ← (r -> AccessToken) -> m AccessToken
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((r -> AccessToken) -> m AccessToken)
-> (r -> AccessToken) -> m AccessToken
forall a b. (a -> b) -> a -> b
$ Credentials -> AccessToken
credentialsAccessToken (Credentials -> AccessToken)
-> (r -> Credentials) -> r -> AccessToken
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Credentials r Credentials -> r -> Credentials
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Credentials r Credentials
forall r. HasCredentials r => Lens' r Credentials
Lens' r Credentials
credentials
  AuthenticatedRequest (AuthProtect "access-token")
-> m (AuthenticatedRequest (AuthProtect "access-token"))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthenticatedRequest (AuthProtect "access-token")
 -> m (AuthenticatedRequest (AuthProtect "access-token")))
-> ((AccessToken -> Request -> Request)
    -> AuthenticatedRequest (AuthProtect "access-token"))
-> (AccessToken -> Request -> Request)
-> m (AuthenticatedRequest (AuthProtect "access-token"))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthClientData (AuthProtect "access-token")
-> (AuthClientData (AuthProtect "access-token")
    -> Request -> Request)
-> AuthenticatedRequest (AuthProtect "access-token")
forall a.
AuthClientData a
-> (AuthClientData a -> Request -> Request)
-> AuthenticatedRequest a
mkAuthenticatedRequest AccessToken
AuthClientData (AuthProtect "access-token")
token ((AccessToken -> Request -> Request)
 -> m (AuthenticatedRequest (AuthProtect "access-token")))
-> (AccessToken -> Request -> Request)
-> m (AuthenticatedRequest (AuthProtect "access-token"))
forall a b. (a -> b) -> a -> b
$ HeaderName -> Text -> Request -> Request
forall a. ToHttpApiData a => HeaderName -> a -> Request -> Request
addHeader HeaderName
"Authorization" (Text -> Request -> Request)
-> (AccessToken -> Text) -> AccessToken -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Bearer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (AccessToken -> Text) -> AccessToken -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccessToken -> Text
T.unAccessToken


-- * Data types

-- | Set of credentials used for authentication
data Credentials = Credentials
  { Credentials -> Username
credentialsUsername ∷ T.Username
  , Credentials -> HomeServer
credentialsHomeServer ∷ T.HomeServer
  , Credentials -> AccessToken
credentialsAccessToken ∷ T.AccessToken
  }
  deriving stock ((forall x. Credentials -> Rep Credentials x)
-> (forall x. Rep Credentials x -> Credentials)
-> Generic Credentials
forall x. Rep Credentials x -> Credentials
forall x. Credentials -> Rep Credentials x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Credentials -> Rep Credentials x
from :: forall x. Credentials -> Rep Credentials x
$cto :: forall x. Rep Credentials x -> Credentials
to :: forall x. Rep Credentials x -> Credentials
Generic, Credentials -> Credentials -> Bool
(Credentials -> Credentials -> Bool)
-> (Credentials -> Credentials -> Bool) -> Eq Credentials
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Credentials -> Credentials -> Bool
== :: Credentials -> Credentials -> Bool
$c/= :: Credentials -> Credentials -> Bool
/= :: Credentials -> Credentials -> Bool
Eq, Int -> Credentials -> ShowS
[Credentials] -> ShowS
Credentials -> String
(Int -> Credentials -> ShowS)
-> (Credentials -> String)
-> ([Credentials] -> ShowS)
-> Show Credentials
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Credentials -> ShowS
showsPrec :: Int -> Credentials -> ShowS
$cshow :: Credentials -> String
show :: Credentials -> String
$cshowList :: [Credentials] -> ShowS
showList :: [Credentials] -> ShowS
Show)

instance ToJSON Credentials where toJSON :: Credentials -> Value
toJSON = Credentials -> Value
forall a.
(Generic a, Typeable a, GToJSON' Value Zero (Rep a)) =>
a -> Value
myGenericToJSON
instance FromJSON Credentials where parseJSON :: Value -> Parser Credentials
parseJSON = Value -> Parser Credentials
forall a.
(Generic a, Typeable a, GFromJSON Zero (Rep a)) =>
Value -> Parser a
myGenericParseJSON


class HasCredentials r where
  credentials ∷ Lens' r Credentials

instance HasCredentials Credentials where
  credentials :: Lens' Credentials Credentials
credentials = (Credentials -> f Credentials) -> Credentials -> f Credentials
forall a. a -> a
id