diff options
| author | adambrangenberg <adabran06@gmail.com> | 2025-12-24 03:40:10 +0100 |
|---|---|---|
| committer | adambrangenberg <adabran06@gmail.com> | 2025-12-24 03:40:10 +0100 |
| commit | a0886694f73fc382d78da79ab8bfb27475757bab (patch) | |
| tree | 652ba9b603a1acaf4dfca188f7bb2c29c6bccfd0 /src/Endpoints/LoginEndpoint.hs | |
| parent | 2b48a574e8b9fed03a5c1969af4bb1e338f1be26 (diff) | |
Implemented basic auth, refactor
Diffstat (limited to 'src/Endpoints/LoginEndpoint.hs')
| -rw-r--r-- | src/Endpoints/LoginEndpoint.hs | 64 |
1 files changed, 64 insertions, 0 deletions
diff --git a/src/Endpoints/LoginEndpoint.hs b/src/Endpoints/LoginEndpoint.hs new file mode 100644 index 0000000..ad4a514 --- /dev/null +++ b/src/Endpoints/LoginEndpoint.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +module Endpoints.LoginEndpoint (LoginAPI, loginServer) where + +import Servant +import Data.Aeson +import Database (runDb) +import Database.Persist +import Control.Monad.IO.Class (liftIO) +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 Model.Login +import Model.MatrixErrorResponse +import Data.User + +---------------------------------------------------------------------------------------------------- +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 req = do + let + input_password = password req + username = T.unpack $ user $ identifier req + + maybe_user <- liftIO $ runDb $ getBy $ UniqueName $ T.pack username + + case maybe_user of + Just (Entity _ db_user) -> do + case Base16.decode $ T.encodeUtf8 $ userPassword db_user of + Right hashedPasswordBytes -> + if validatePassword hashedPasswordBytes (T.encodeUtf8 input_password) + then return $ LoginResponse + { user_id = T.pack ("@" ++ username ++ ":localhost") + , access_token = T.pack ("dummy" ++ username) + , home_server = "localhost" + , device_id = "DUMMY" + } + else throwError $ err403 { errBody = encode invalid_credentials_error } + Left _ -> throwError $ err500 { errBody = encode password_decoding_error } + _ -> throwError $ err403 { errBody = encode invalid_username_error } + 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"
\ No newline at end of file |