Refactorauth

1 files changed, 43 insertions, 33 deletions

diff --git a/src/Endpoints/LoginEndpoint.hs b/src/Endpoints/LoginEndpoint.hs
index 4b20b1e..41dacfd 100644
--- a/src/Endpoints/LoginEndpoint.hs
+++ b/src/Endpoints/LoginEndpoint.hs
@@ -47,41 +47,39 @@ handleLoginGet = return $ LoginFlowsResponse [LoginFlow "m.login.password"]
 type PostLogin = "_matrix" :> "client" :> "v3" :> "login" :> ReqBody '[JSON] LoginRequest
                :> Post '[JSON] LoginResponse
 
-handleLoginPost :: LoginRequest -> Handler LoginResponse -- TODO: Let DB create device_id/primarykey?
-handleLoginPost LoginRequest {
-    device_id = maybe_device_id,
-    password = input_password,
-    initial_device_display_name = maybe_device_name,
-    identifier
-} = do
+handleLoginPost :: LoginRequest -> Handler LoginResponse
+handleLoginPost LoginRequest
+  { device_id = maybe_device_id
+  , password = input_password
+  , initial_device_display_name = _
+  , identifier
+  } = do
   resolved_device_id <- resolveDeviceId maybe_device_id
+  let username = user identifier
 
-  let
-    username = user identifier
-    auth_holder = AuthenticationHolder username resolved_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    = resolved_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 }
+  Jwt token <- eitherToHandler failed_token_generation $
+    hmacEncode HS256 server_password $
+      BL.toStrict $
+        A.encode $
+          AuthenticationHolder username resolved_device_id Nothing
+
+  Entity _ db_user <- maybeToHandler invalid_username_error =<<
+    liftIO (runDb $ getBy $ UniqueName username)
+
+  hashedPasswordBytes <- eitherToHandler password_decoding_error $
+    Base16.decode $
+      T.encodeUtf8 $
+        userPassword db_user
+
+  unless (validatePassword hashedPasswordBytes (T.encodeUtf8 input_password)) $
+    throw403 invalid_credentials_error
+
+  pure LoginResponse
+    { user_id      = T.concat ["@", username, ":localhost"]
+    , access_token = T.decodeUtf8 token
+    , home_server  = "localhost"
+    , device_id    = resolved_device_id
+    }
   where
     invalid_username_error = MatrixErrorResponse "M_FORBIDDEN" "Invalid username"
     password_decoding_error = MatrixErrorResponse "M_UNKNOWN" "Password hash decoding failed"
@@ -100,3 +98,15 @@ handleLoginPost LoginRequest {
       let generated_id = T.pack $ UTF8.toString $ B.take 16 encoded
       _ <- liftIO $ runDb $ insert $ Device generated_id maybe_device_name
       pure generated_id
+
+maybeToHandler :: ServerErrorBody -> Maybe a -> Handler a
+maybeToHandler err =
+  maybe (throwError $ err403 { errBody = A.encode err }) pure
+
+eitherToHandler :: ServerErrorBody -> Either b a -> Handler a
+eitherToHandler err =
+  either (const $ throwError $ err500 { errBody = A.encode err }) pure
+
+throw403 :: ServerErrorBody -> Handler a
+throw403 err =
+  throwError $ err403 { errBody = A.encode err }