8 files changed, 179 insertions, 42 deletions
diff --git a/src/Endpoints/APILib.hs b/src/Endpoints/APILib.hs
index 9c89492..1db3f47 100644
--- a/src/Endpoints/APILib.hs
+++ b/src/Endpoints/APILib.hs
@@ -4,8 +4,14 @@
 module Endpoints.APILib (API) where
 
 import Servant
-import Endpoints.WellKnownClientEndpoint
-import Endpoints.WellKnownSupportEndpoint
+
+import Endpoints.WellKnownEndpoint
 import Endpoints.VersionsEndpoint
+import Endpoints.LoginEndpoint
+import Endpoints.ProfileEndpoint
 
-type API = WellKnownClientAPI :<|> WellKnownSupportAPI :<|> VersionsAPI
+----------------------------------------------------------------------------------------------------
+type API =    WellKnownAPI
+         :<|> VersionsAPI
+         :<|> LoginAPI
+         :<|> ProfileAPI
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
diff --git a/src/Endpoints/ProfileEndpoint.hs b/src/Endpoints/ProfileEndpoint.hs
new file mode 100644
index 0000000..8aaaa52
--- /dev/null
+++ b/src/Endpoints/ProfileEndpoint.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Endpoints.ProfileEndpoint (ProfileAPI, profileServer) where
+
+import Servant
+import Data.Aeson
+import Data.Text (Text, pack)
+import qualified Data.Text as T
+import Database.Persist
+import Database (runDb)
+import Control.Monad.IO.Class (liftIO)
+
+import Data.User (User(..), Unique(UniqueName))
+import Model.Profile
+import Model.MatrixErrorResponse
+
+----------------------------------------------------------------------------------------------------
+type ProfileAPI = GetProfile
+
+profileServer :: Server ProfileAPI
+profileServer = handleProfileGet
+
+--- GET /_matrix/client/v3/profile/{userId} --------------------------------------------------------
+type GetProfile = "_matrix" :> "client" :> "v3" :> "profile" :> Capture "userId" Text
+                :> Get '[JSON] ProfileResponse
+
+handleProfileGet :: Text -> Handler ProfileResponse
+handleProfileGet user_id = do
+  let username = T.takeWhile (/= ':') $ T.drop 1 user_id
+  maybe_user <- liftIO $ runDb $ getBy $ UniqueName username
+
+  case maybe_user of
+    Just (Entity _ db_user) ->
+      return $ ProfileResponse
+        { display_name = (userDisplayName db_user) <> (Just $ userIdent $ db_user)
+        , avatar_url   = userAvatarUrl db_user
+        , tz           = Nothing
+        }
+    Nothing ->
+      throwError err404 { errBody = encode user_not_found_error }
+  where
+    user_not_found_error = (MatrixErrorResponse (pack "M_NOT_FOUND") (pack "Profile not found"))
+\ No newline at end of file
diff --git a/src/Endpoints/ServerLib.hs b/src/Endpoints/ServerLib.hs
index cae6928..7bcf72a 100644
--- a/src/Endpoints/ServerLib.hs
+++ b/src/Endpoints/ServerLib.hs
@@ -2,11 +2,17 @@
 
 module Endpoints.ServerLib (server) where
 
-import Endpoints.WellKnownClientEndpoint
-import Endpoints.WellKnownSupportEndpoint
+import Servant
+
+import Endpoints.WellKnownEndpoint
 import Endpoints.APILib
 import Endpoints.VersionsEndpoint
-import Servant
+import Endpoints.LoginEndpoint
+import Endpoints.ProfileEndpoint
 
+----------------------------------------------------------------------------------------------------
 server :: Server API
-server = handleWellKnownClient :<|> handleWellKnownSupport :<|> handleVersions
+server =    wellKnownServer
+       :<|> versionsServer
+       :<|> loginServer
+       :<|> profileServer
diff --git a/src/Endpoints/VersionsEndpoint.hs b/src/Endpoints/VersionsEndpoint.hs
index 79fd3ea..e5739cf 100644
--- a/src/Endpoints/VersionsEndpoint.hs
+++ b/src/Endpoints/VersionsEndpoint.hs
@@ -1,12 +1,22 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
 
-module Endpoints.VersionsEndpoint (VersionsAPI, handleVersions) where
+module Endpoints.VersionsEndpoint (VersionsAPI, versionsServer) where
 
 import Servant
-import Data.VersionsData
+import Data.Text (pack)
 
-type VersionsAPI = "_matrix" :> "client" :> "versions" :> Get '[JSON] Versions
+import Model.Versions
 
-handleVersions :: Handler Versions
-handleVersions = return (makeVersions ["1.12"])
+----------------------------------------------------------------------------------------------------
+type VersionsAPI = GetVersions
+
+versionsServer :: Server VersionsAPI
+versionsServer = handleVersionsGet
+-- http://localhost:8080
+--- GET /_matrix/client/versions -------------------------------------------------------------------
+type GetVersions = "_matrix" :> "client" :> "versions"
+                 :> Get '[JSON] VersionsResponse
+
+handleVersionsGet :: Handler VersionsResponse
+handleVersionsGet = return $ VersionsResponse [pack "v1.12"]
diff --git a/src/Endpoints/WellKnownClientEndpoint.hs b/src/Endpoints/WellKnownClientEndpoint.hs
deleted file mode 100644
index d091b1d..0000000
--- a/src/Endpoints/WellKnownClientEndpoint.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Endpoints.WellKnownClientEndpoint (WellKnownClientAPI, handleWellKnownClient) where
-
-import Servant
-import Data.WellKnownClientData
-
-type WellKnownClientAPI = ".well-known" :> "matrix" :> "client" :> Get '[JSON] WellKnownClient
-
-handleWellKnownClient :: Handler WellKnownClient
-handleWellKnownClient = return (makeWellKnownClient "http://localhost:8080" "http://localhost:8080")
diff --git a/src/Endpoints/WellKnownEndpoint.hs b/src/Endpoints/WellKnownEndpoint.hs
new file mode 100644
index 0000000..c63c5e5
--- /dev/null
+++ b/src/Endpoints/WellKnownEndpoint.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Endpoints.WellKnownEndpoint (WellKnownAPI, wellKnownServer) where
+
+import Servant
+import Data.Text (pack)
+
+import Model.WellKnown
+
+----------------------------------------------------------------------------------------------------
+
+type WellKnownAPI = GetWellKnownClient :<|> GetWellKnownSupport
+
+wellKnownServer :: Server WellKnownAPI
+wellKnownServer = handleWellKnownClientGet :<|> handleWellKnownSupportGet
+--- GET /.well-known/matrix/client -----------------------------------------------------------------
+
+type GetWellKnownClient = ".well-known" :> "matrix" :> "client"
+                        :> Get '[JSON] WellKnownClientResponse
+
+handleWellKnownClientGet :: Handler WellKnownClientResponse
+handleWellKnownClientGet = return $ WellKnownClientResponse
+  { homeserver = BaseUrlHolder (pack "http://localhost:8080")
+  , identity_server = BaseUrlHolder (pack "https://vector.im")
+  }
+
+--- GET /.well-known/matrix/support ----------------------------------------------------------------
+type GetWellKnownSupport = ".well-known" :> "matrix" :> "support"
+                         :> Get '[JSON] WellKnownSupportResponse
+
+handleWellKnownSupportGet :: Handler WellKnownSupportResponse
+handleWellKnownSupportGet = return $ WellKnownSupportResponse
+  { contacts = [Contact (pack "email") (pack "mxid") (pack "m.role.admin")]
+  , support_page = pack "http://localhost:8080/support.html"
+  }
+
diff --git a/src/Endpoints/WellKnownSupportEndpoint.hs b/src/Endpoints/WellKnownSupportEndpoint.hs
deleted file mode 100644
index b6104ae..0000000
--- a/src/Endpoints/WellKnownSupportEndpoint.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-
-module Endpoints.WellKnownSupportEndpoint (WellKnownSupportAPI, handleWellKnownSupport) where
-
-import Servant
-import Data.WellKnownSupportData
-import Data.ContactData
-
-type WellKnownSupportAPI = ".well-known" :> "matrix" :> "support" :> Get '[JSON] WellKnownSupport
-
-handleWellKnownSupport :: Handler WellKnownSupport
-handleWellKnownSupport =
-  return (
-    makeWellKnownSupport
-      [makeContact "email" "mxid" "m.role.admin"]
-      "http://localhost:8080/support.html"
-  )