AuthQuery.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module WikiMusic.PostgreSQL.AuthQuery () where

import Data.Text (pack, unpack)
import Hasql.Decoders as D
import Hasql.Encoders as E
import Hasql.Pool qualified
import Hasql.Session qualified as Session
import Hasql.Statement (Statement (..))
import Relude
import WikiMusic.Free.AuthQuery
import WikiMusic.Protolude

instance Exec AuthQuery where
  execAlgebra (FetchUserForAuthCheck env email next) = do
    next =<< fetchUserForAuthCheck' env email
  execAlgebra (FetchUserFromToken env t next) = do
    next =<< fetchUserFromToken' env t
  execAlgebra (FetchMe env identifier next) = do
    next =<< fetchMe' env identifier
  execAlgebra (FetchUserRoles env identifier next) = do
    next =<< fetchUserRoles' env identifier

fetchMe' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError (Maybe WikiMusicUser))
fetchMe' env identifier = do
  stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt)
  let u = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult
  case u of
    Left e -> pure . Left $ e
    Right Nothing -> pure . Left $ AuthError "User did not exist"
    Right (Just usr) -> do
      u' <- withRoles env usr
      pure . Right . Just $ u'
  where
    stmt = Statement query encoder decoder True
    query =
      encodeUtf8
        [trimming|
      SELECT identifier, display_name, email_address, password_hash, auth_token FROM users
      WHERE identifier = $$1 LIMIT 1                                  
      |]
    encoder = E.param . E.nonNullable $ E.uuid
    decoder =
      D.rowMaybe $
        (,,,,)
          <$> D.column (D.nonNullable D.uuid)
          <*> D.column (D.nonNullable D.text)
          <*> D.column (D.nonNullable D.text)
          <*> D.column (D.nullable D.text)
          <*> D.column (D.nullable D.text)

fetchAuthUserDecoder :: Result (Maybe (UUID, Text, Text, Maybe Text, Maybe Text))
fetchAuthUserDecoder =
  D.rowMaybe $
    (,,,,)
      <$> D.column (D.nonNullable D.uuid)
      <*> D.column (D.nonNullable D.text)
      <*> D.column (D.nonNullable D.text)
      <*> D.column (D.nullable D.text)
      <*> D.column (D.nullable D.text)

fetchUserForAuthCheck' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser))
fetchUserForAuthCheck' env email = do
  stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement email stmt)
  let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult
  case maybeUsr of
    Left e -> pure . Left $ e
    Right Nothing -> pure . Left $ AuthError "User did not exist"
    Right (Just usr) -> do
      u <- withRoles env usr
      pure . Right . Just $ u
  where
    stmt = Statement query encoder fetchAuthUserDecoder True
    query =
      encodeUtf8
        [trimming|
          SELECT identifier, display_name, email_address, password_hash, auth_token          
          FROM users
          WHERE email_address = $$1
          LIMIT 1
          |]
    encoder = E.param . E.nonNullable $ E.text

fetchUserFromToken' :: (MonadIO m) => Env -> Text -> m (Either AuthQueryError (Maybe WikiMusicUser))
fetchUserFromToken' env t = do
  stmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement t stmt)
  let maybeUsr = first fromHasqlUsageError . fmap maybeFromRow $ stmtResult
  case maybeUsr of
    Left e -> pure . Left $ e
    Right Nothing -> pure . Left $ AuthError "User did not exist"
    Right (Just usr) -> do
      u <- withRoles env usr
      pure . Right . Just $ u
  where
    stmt = Statement query encoder fetchAuthUserDecoder True
    query =
      encodeUtf8
        [trimming|
          SELECT identifier, display_name, email_address, password_hash, auth_token          
          FROM users
          WHERE auth_token = $$1
          LIMIT 1
          |]
    encoder = E.param . E.nonNullable $ E.text

fetchUserRoles' :: (MonadIO m) => Env -> UUID -> m (Either AuthQueryError [UserRole])
fetchUserRoles' env identifier = do
  rolesStmtResult <- liftIO $ Hasql.Pool.use (env ^. #pool) (Session.statement identifier stmt)
  let roles' = either (const []) (map userRole) rolesStmtResult
  pure . Right $ roles'
  where
    stmt = Statement query encoder decoder True
    query =
      encodeUtf8
        [trimming|
       SELECT role_id FROM user_roles WHERE user_identifier = $$1                       
      |]
    encoder = E.param . E.nonNullable $ E.uuid
    decoder = D.rowList . D.column . D.nonNullable $ D.text

userRole :: Text -> UserRole
userRole = read . unpack

maybeFromRow :: Maybe (UUID, Text, Text, Maybe Text, Maybe Text) -> Maybe WikiMusicUser
maybeFromRow =
  fmap
    ( \(identifierr, displayName, emailAddress, passwordHash, authToken) ->
        WikiMusicUser
          { identifier = identifierr,
            displayName = displayName,
            emailAddress = emailAddress,
            passwordHash = passwordHash,
            roles = [],
            authToken = authToken
          }
    )

fromHasqlUsageError :: Hasql.Pool.UsageError -> AuthQueryError
fromHasqlUsageError = PersistenceError . pack . show

withRoles :: (MonadIO m) => Env -> WikiMusicUser -> m WikiMusicUser
withRoles env usr = do
  roles' <- fetchUserRoles' env (usr ^. #identifier)
  pure $ usr {roles = fromRight [] roles'}