From a0886694f73fc382d78da79ab8bfb27475757bab Mon Sep 17 00:00:00 2001
From: adambrangenberg <adabran06@gmail.com>
Date: Wed, 24 Dec 2025 03:40:10 +0100
Subject: Implemented basic auth, refactor

---
 src/Endpoints/LoginEndpoint.hs | 64 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 64 insertions(+)
 create mode 100644 src/Endpoints/LoginEndpoint.hs

(limited to 'src/Endpoints/LoginEndpoint.hs')

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
-- 
cgit v1.2.3