blob: f7edc3d62541a74fbdca1f882a17c279e1517c0d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
module Endpoints.LoginEndpoint (LoginAPI, loginServer) where
import Servant
import Data.Aeson as A
import Database (runDb)
import Database.Persist
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Crypto.BCrypt (validatePassword)
import qualified Data.ByteString.Base16 as Base16
import Jose.Jws (hmacEncode)
import Jose.Jwa (JwsAlg(HS256))
import Jose.Jwt (Jwt (Jwt))
import Data.ByteString.Lazy as BL
import Data.ByteString as B
import Crypto.Random (getRandomBytes)
import Data.ByteString.Base64.URL as BURL
import qualified Data.ByteString.UTF8 as UTF8
import Control.Monad.IO.Class (MonadIO(..), liftIO)
import Model.Login
import Model.MatrixErrorResponse
import Data.User
import Model.AuthenticationHolder (AuthenticationHolder (AuthenticationHolder), server_password)
----------------------------------------------------------------------------------------------------
type LoginAPI = GetLogin :<|> PostLogin
loginServer :: Server LoginAPI
loginServer = handleLoginGet :<|> handleLoginPost
--- GET /_matrix/client/v3/login -------------------------------------------------------------------
type GetLogin = "_matrix" :> "client" :> "v3" :> "login"
:> Get '[JSON] LoginFlowsResponse
handleLoginGet :: Handler LoginFlowsResponse
handleLoginGet = return $ LoginFlowsResponse [LoginFlow "m.login.password"]
--- POST /_matrix/client/v3/login ------------------------------------------------------------------
type PostLogin = "_matrix" :> "client" :> "v3" :> "login" :> ReqBody '[JSON] LoginRequest
:> Post '[JSON] LoginResponse
handleLoginPost :: LoginRequest -> Handler LoginResponse
handleLoginPost LoginRequest { device_id = maybe_device_id, password = input_password, identifier } = do
safe_device_id <- getDeviceId maybe_device_id
let
username = user identifier
auth_holder = AuthenticationHolder username safe_device_id Nothing
either_token = hmacEncode HS256 server_password (BL.toStrict $ A.encode $ auth_holder)
case either_token of
Right (Jwt token) -> do
maybe_db_user <- liftIO $ runDb $ getBy $ UniqueName $ username
case maybe_db_user of
Just (Entity _ db_user) -> do
let either_hashed_password = Base16.decode $ T.encodeUtf8 $ userPassword db_user
case either_hashed_password of
Right hashedPasswordBytes ->
if validatePassword hashedPasswordBytes (T.encodeUtf8 input_password)
then return $ LoginResponse
{ user_id = T.concat ["@", username, ":localhost"]
, access_token = T.decodeUtf8 token
, home_server = "localhost"
, device_id = safe_device_id
}
else throwError $ err403 { errBody = A.encode invalid_credentials_error }
_ -> throwError $ err500 { errBody = A.encode password_decoding_error }
_ -> throwError $ err403 { errBody = A.encode invalid_username_error }
_ -> throwError $ err403 { errBody = A.encode failed_token_generation }
where
invalid_username_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username"
password_decoding_error = MatrixErrorResponse "M_UNKNOWN" "Password hash decoding failed"
invalid_credentials_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username or password"
failed_token_generation = MatrixErrorResponse "M_UNKNOWN" "Access Token generation failed"
getDeviceId :: MonadIO m => Maybe T.Text -> m T.Text
getDeviceId mDeviceId = case mDeviceId of
Just did -> pure did
Nothing -> liftIO generateDeviceId
generateDeviceId :: IO T.Text
generateDeviceId = do
bytes <- getRandomBytes 12
let encoded = BURL.encode bytes
pure $ T.pack $ UTF8.toString $ B.take 16 encoded
|