{-# 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
"…"

  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

  logDebug $ "Authenticating as " <> (pack . show . T.printMxid) mxid <> "…"

  response ←
    Api.runMatrixApiClientDoNotShowReqBody' req (Proxy @Api.LoginApi) $ \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
      }

  pure Credentials
    { credentialsUsername = T.mxidUsername . Api.loginResponseUserId $ response
    , credentialsHomeServer = Api.loginResponseHomeServer response
    , credentialsAccessToken = Api.loginResponseAccessToken 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
  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
  pure . mkAuthenticatedRequest token $ addHeader "Authorization" . ("Bearer " <>) . 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