{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}

module Endpoints.LoginEndpoint (LoginAPI, loginServer) where

import Servant
import Data.Aeson as A
import Database (runDb)
import Database.Persist
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 Data.ByteString as B
import Crypto.Random (getRandomBytes)
import Data.ByteString.Base64.URL as BURL
import qualified Data.ByteString.UTF8 as UTF8
import Control.Monad.IO.Class (MonadIO(..), liftIO)

import Model.Login
import Model.MatrixErrorResponse
import Data.User
import Data.Device
import Model.AuthenticationHolder (AuthenticationHolder (AuthenticationHolder), server_password)

----------------------------------------------------------------------------------------------------
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 -- 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
  resolved_device_id <- resolveDeviceId maybe_device_id

  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 }
  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"
    failed_token_generation = MatrixErrorResponse "M_UNKNOWN" "Access Token generation failed"

    resolveDeviceId :: MonadIO m => Maybe T.Text -> m T.Text
    resolveDeviceId device_id = case device_id of
      Just did -> pure did
      Nothing  -> liftIO $ generateDeviceId

    generateDeviceId :: IO T.Text
    generateDeviceId = do
      bytes <- getRandomBytes 12
      let encoded = BURL.encode bytes
      let generated_id = T.pack $ UTF8.toString $ B.take 16 encoded
      _ <- liftIO $ runDb $ insert $ Device generated_id maybe_device_name
      pure generated_id