Add actual access tokens through JWT

6 files changed, 83 insertions, 44 deletions

diff --git a/src/Auth.hs b/src/Auth.hs
index 68d1b6b..eea220b 100644
--- a/src/Auth.hs
+++ b/src/Auth.hs
@@ -4,32 +4,46 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | This module provides authentication utilities for the Jamaa server.
-module Auth (AuthProtect, authHandler) where
+module Auth (authHandler, UserAuth) where
 
-import Data.Text (Text, isPrefixOf, stripPrefix, pack)
 import Servant
 import Servant.Server.Experimental.Auth (AuthServerData, AuthHandler, mkAuthHandler)
 import Network.Wai (Request, requestHeaders)
 import Database.Persist
 import Database (runDb)
 import Control.Monad.IO.Class (liftIO)
-import Data.Text.Encoding (decodeUtf8, decodeUtf8With)
+import Jose.Jws (hmacDecode)
+import Data.Aeson as A
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString as B
 
-import Data.User (User(..), Unique(UniqueName))
+import Data.User (User (..), Unique (UniqueName))
+import Model.AuthenticationHolder (AuthenticationHolder (..), server_password)
 
 ----------------------------------------------------------------------------------------------------
-type instance AuthServerData (AuthProtect "user-auth") = User
+type UserAuth = AuthProtect "user-auth"
+type instance AuthServerData UserAuth = User
 
 authHandler :: AuthHandler Request User
 authHandler =
   mkAuthHandler $ \req -> case lookup "Authorization" (requestHeaders req) of
-    Just token ->
-      case stripPrefix "Bearer dummy" (decodeUtf8 token) of
-        Just username -> do
-          maybe_user <- liftIO $ runDb $ getBy $ UniqueName username
+    Just header ->
+      case B.stripPrefix "Bearer " header of
+        Just token -> do
+          let either_auth_holder = hmacDecode server_password token
 
-          case maybe_user of
-            Just (Entity _ db_user) -> return db_user
+          case either_auth_holder of
+            Right (_, auth_holder_body) -> do
+              let maybe_auth_holder = A.decode $ BL.fromStrict $ auth_holder_body :: Maybe AuthenticationHolder
+
+              case maybe_auth_holder of
+                Just auth_holder -> do
+                  maybe_user <- liftIO $ runDb $ getBy $ UniqueName $ username $ auth_holder
+
+                  case maybe_user of
+                    Just (Entity _ db_user) -> return db_user
+                    _ -> throwError err401
+                _ -> throwError err401
             _ -> throwError err401
         _ -> throwError err401
     _ -> throwError err401
diff --git a/src/Endpoints/CapabilitiesEndpoint.hs b/src/Endpoints/CapabilitiesEndpoint.hs
index 5c1ffde..169ca21 100644
--- a/src/Endpoints/CapabilitiesEndpoint.hs
+++ b/src/Endpoints/CapabilitiesEndpoint.hs
@@ -8,8 +8,8 @@ import Servant
 import qualified Data.Map as Map
 
 import Model.Capabilities
-import Auth (AuthProtect)
-import Data.User (User (..))
+import Auth (UserAuth)
+import Data.User (User (User))
 
 ----------------------------------------------------------------------------------------------------
 type CapabilitiesAPI = GetCapabilities
@@ -19,7 +19,7 @@ capabilitiesServer = handleCapabilitiesGet
 
 --- GET /_matrix/client/v3/capabilities ------------------------------------------------------------
 type GetCapabilities = "_matrix" :> "client" :> "v3" :> "capabilities"
-                 :> AuthProtect "user-auth"
+                 :> UserAuth
                  :> Get '[JSON] CapabilitiesResponse
 
 handleCapabilitiesGet :: User -> Handler CapabilitiesResponse
diff --git a/src/Endpoints/LoginEndpoint.hs b/src/Endpoints/LoginEndpoint.hs
index cca10d4..f29a97a 100644
--- a/src/Endpoints/LoginEndpoint.hs
+++ b/src/Endpoints/LoginEndpoint.hs
@@ -6,7 +6,7 @@
 module Endpoints.LoginEndpoint (LoginAPI, loginServer) where
 
 import Servant
-import Data.Aeson
+import Data.Aeson as A
 import Database (runDb)
 import Database.Persist
 import Control.Monad.IO.Class (liftIO)
@@ -14,10 +14,15 @@ 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 Model.Login
 import Model.MatrixErrorResponse
 import Data.User
+import Model.AuthenticationHolder (AuthenticationHolder (AuthenticationHolder), server_password)
 
 ----------------------------------------------------------------------------------------------------
 type LoginAPI = GetLogin :<|> PostLogin
@@ -41,24 +46,33 @@ handleLoginPost req = do
   let
     input_password = password req
     username = user $ identifier req
+    auth_holder = AuthenticationHolder username "DUMMY" Nothing
 
-  maybe_user <- liftIO $ runDb $ getBy $ UniqueName $ username
+  let either_token = hmacEncode HS256 server_password (BL.toStrict $ A.encode $ auth_holder)
 
-  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.concat ["@", username, ":localhost"]
-              , access_token = T.concat ["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 }
+  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    = "DUMMY"
+                  }
+                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"
\ No newline at end of file
+    invalid_credentials_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username or password"
+    failed_token_generation = MatrixErrorResponse "M_UNKNOWN" "Access Token generation failed"
\ No newline at end of file
diff --git a/src/Lib.hs b/src/Lib.hs
index a0900ad..17f8b0f 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -22,7 +22,7 @@ import Auth (authHandler)
 import Cors
 import Endpoints.APILib
 import Endpoints.ServerLib
-import Data.User (User (..))
+import Data.User (User)
 
 startApp :: IO ()
 startApp = run 8080 (logStdoutDev app)
diff --git a/src/Model/Authentication.hs b/src/Model/Authentication.hs
deleted file mode 100644
index be1337a..0000000
--- a/src/Model/Authentication.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-
-module Model.Authentication (AuthenticationResponse (..)) where
-
-import GHC.Generics
-import Data.Text (Text)
-
-----------------------------------------------------------------------------------------------------
-data AuthenticationResponse = AuthenticationResponse -- delete?
-  { userId :: Text
-  }
-  deriving (Show, Eq, Generic)
diff --git a/src/Model/AuthenticationHolder.hs b/src/Model/AuthenticationHolder.hs
new file mode 100644
index 0000000..d3b53de
--- /dev/null
+++ b/src/Model/AuthenticationHolder.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Model.AuthenticationHolder (AuthenticationHolder (..), server_password) where
+
+import Data.Aeson
+import GHC.Generics
+import Data.Text (Text)
+import Data.ByteString
+
+----------------------------------------------------------------------------------------------------
+data AuthenticationHolder = AuthenticationHolder
+  { username :: Text
+  , device :: Text
+  , expire :: Maybe Int
+  }
+  deriving (Show, Eq, Generic)
+
+instance FromJSON AuthenticationHolder
+instance ToJSON AuthenticationHolder
+
+server_password :: ByteString
+server_password = "jamaa_dev"
\ No newline at end of file