{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoFieldSelectors #-}

module WikiMusic.Servant.Utilities
  ( err204,
    loginRoute,
    authCheckIO,
    maybe200,
    maybe204,
    systemInformationRoute,
    doWithAuth,
  )
where

import Data.Password.Bcrypt
import Data.Text qualified as T
import Servant as S
import WikiMusic.Free.AuthQuery
import WikiMusic.Model.Auth
import WikiMusic.Model.Env
import WikiMusic.Model.Other
import WikiMusic.Protolude
import WikiMusic.Sqlite.AuthQuery ()

loginRoute ::
  Env ->
  LoginRequest ->
  Handler
    ( Headers
        '[ S.Header "x-wikimusic-auth" Text
         ]
        NoContent
    )
loginRoute :: Env
-> LoginRequest
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
loginRoute Env
env (LoginRequest String
inputEmail String
inputPassword) = do
  Either AuthQueryError (Maybe WikiMusicUser)
eitherWikiMusicUser <- IO (Either AuthQueryError (Maybe WikiMusicUser))
-> Handler (Either AuthQueryError (Maybe WikiMusicUser))
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @AuthQuery (Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
 -> IO (Either AuthQueryError (Maybe WikiMusicUser)))
-> Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
-> IO (Either AuthQueryError (Maybe WikiMusicUser))
forall a b. (a -> b) -> a -> b
$ Env
-> Text
-> Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
forall (f :: * -> *).
(AuthQuery :<: f) =>
Env -> Text -> Free f (Either AuthQueryError (Maybe WikiMusicUser))
fetchUserForAuthCheck Env
env (String -> Text
T.pack String
inputEmail))
  (AuthQueryError
 -> Handler
      (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent))
-> (Maybe WikiMusicUser
    -> Handler
         (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent))
-> Either AuthQueryError (Maybe WikiMusicUser)
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (Handler (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
-> AuthQueryError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a b. a -> b -> a
const (Handler
   (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
 -> AuthQueryError
 -> Handler
      (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent))
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
-> AuthQueryError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a b. (a -> b) -> a -> b
$ ServerError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401)
    (Maybe WikiMusicUser
-> String
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
`verifyUserLogin` String
inputPassword)
    Either AuthQueryError (Maybe WikiMusicUser)
eitherWikiMusicUser

verifyUserLogin ::
  Maybe WikiMusicUser ->
  String ->
  Handler
    ( Headers
        '[ S.Header "x-wikimusic-auth" Text
         ]
        NoContent
    )
verifyUserLogin :: Maybe WikiMusicUser
-> String
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
verifyUserLogin Maybe WikiMusicUser
Nothing String
_ = ServerError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
verifyUserLogin (Just WikiMusicUser
wikimusicUser) String
inputPassword = do
  WikiMusicUser
-> PasswordCheck
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
doAfterPasswordCheck WikiMusicUser
wikimusicUser PasswordCheck
passwordCheckResult
  where
    inputPass :: Password
inputPass = Text -> Password
mkPassword (String -> Text
T.pack String
inputPassword)
    passwordCheckResult :: PasswordCheck
passwordCheckResult =
      PasswordCheck
-> (Text -> PasswordCheck) -> Maybe Text -> PasswordCheck
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        PasswordCheck
PasswordCheckFail
        (Password -> PasswordHash Bcrypt -> PasswordCheck
checkPassword Password
inputPass (PasswordHash Bcrypt -> PasswordCheck)
-> (Text -> PasswordHash Bcrypt) -> Text -> PasswordCheck
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PasswordHash Bcrypt
forall a. Text -> PasswordHash a
PasswordHash)
        (WikiMusicUser
wikimusicUser WikiMusicUser
-> Optic' A_Lens NoIx WikiMusicUser (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx WikiMusicUser (Maybe Text)
#passwordHash)

doAfterPasswordCheck ::
  WikiMusicUser ->
  PasswordCheck ->
  Handler
    ( Headers
        '[ S.Header "x-wikimusic-auth" Text
         ]
        NoContent
    )
doAfterPasswordCheck :: WikiMusicUser
-> PasswordCheck
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
doAfterPasswordCheck WikiMusicUser
_ PasswordCheck
PasswordCheckFail = ServerError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
doAfterPasswordCheck WikiMusicUser
wikimusicUser' PasswordCheck
PasswordCheckSuccess = do
  let tok :: Text
tok = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (WikiMusicUser
wikimusicUser' WikiMusicUser
-> Optic' A_Lens NoIx WikiMusicUser (Maybe Text) -> Maybe Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx WikiMusicUser (Maybe Text)
#authToken)
  ServerError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError
 -> Handler
      (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent))
-> ServerError
-> Handler
     (Headers (Header "x-wikimusic-auth" Text : NoIx) NoContent)
forall a b. (a -> b) -> a -> b
$ ServerError
      { $sel:errHTTPCode:ServerError :: Int
errHTTPCode = Int
204,
        $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = String
"No Content",
        $sel:errBody:ServerError :: ByteString
errBody = ByteString
"",
        $sel:errHeaders:ServerError :: [Header]
errHeaders =
          [ (HeaderName
"x-wikimusic-auth", Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
WikiMusic.Protolude.encodeUtf8 Text
tok)
          ]
      }

systemInformationRoute ::
  Env ->
  Handler SystemInformationResponse
systemInformationRoute :: Env -> Handler SystemInformationResponse
systemInformationRoute Env
env = do
  SystemInformationResponse -> Handler SystemInformationResponse
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    SystemInformationResponse
      { $sel:reportedVersion:SystemInformationResponse :: Text
reportedVersion = Env
env Env -> Optic' A_Lens NoIx Env Text -> Text
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic A_Lens NoIx Env Env AppConfig AppConfig
#cfg Optic A_Lens NoIx Env Env AppConfig AppConfig
-> Optic A_Lens NoIx AppConfig AppConfig DevConfig DevConfig
-> Optic A_Lens NoIx Env Env DevConfig DevConfig
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens NoIx AppConfig AppConfig DevConfig DevConfig
#dev Optic A_Lens NoIx Env Env DevConfig DevConfig
-> Optic An_Iso NoIx DevConfig DevConfig Text Text
-> Optic' A_Lens NoIx Env Text
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_Iso NoIx DevConfig DevConfig Text Text
#reportedVersion,
        $sel:processStartedAt:SystemInformationResponse :: UTCTime
processStartedAt = Env
env Env -> Optic' A_Lens NoIx Env UTCTime -> UTCTime
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Env UTCTime
#processStartedAt
      }

authCheckIO ::
  Env ->
  Text ->
  IO (Maybe WikiMusicUser)
authCheckIO :: Env -> Text -> IO (Maybe WikiMusicUser)
authCheckIO Env
env Text
token = do
  Either AuthQueryError (Maybe WikiMusicUser)
eitherWikiMusicUser <- IO (Either AuthQueryError (Maybe WikiMusicUser))
-> IO (Either AuthQueryError (Maybe WikiMusicUser))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (f :: * -> *) a. Exec f => Free f a -> IO a
exec @AuthQuery (Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
 -> IO (Either AuthQueryError (Maybe WikiMusicUser)))
-> Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
-> IO (Either AuthQueryError (Maybe WikiMusicUser))
forall a b. (a -> b) -> a -> b
$ Env
-> Text
-> Free AuthQuery (Either AuthQueryError (Maybe WikiMusicUser))
forall (f :: * -> *).
(AuthQuery :<: f) =>
Env -> Text -> Free f (Either AuthQueryError (Maybe WikiMusicUser))
fetchUserFromToken Env
env Text
token)
  case Either AuthQueryError (Maybe WikiMusicUser)
eitherWikiMusicUser of
    Left AuthQueryError
_ -> do
      Maybe WikiMusicUser -> IO (Maybe WikiMusicUser)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WikiMusicUser
forall a. Maybe a
Nothing
    Right Maybe WikiMusicUser
maybeWikiMusicUser -> do
      case Maybe WikiMusicUser
maybeWikiMusicUser of
        Maybe WikiMusicUser
Nothing -> Maybe WikiMusicUser -> IO (Maybe WikiMusicUser)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe WikiMusicUser
forall a. Maybe a
Nothing
        Just WikiMusicUser
u -> do
          Maybe WikiMusicUser -> IO (Maybe WikiMusicUser)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe WikiMusicUser -> IO (Maybe WikiMusicUser))
-> Maybe WikiMusicUser -> IO (Maybe WikiMusicUser)
forall a b. (a -> b) -> a -> b
$ WikiMusicUser -> Maybe WikiMusicUser
forall a. a -> Maybe a
Just WikiMusicUser
u

err204 :: ServerError
err204 :: ServerError
err204 =
  ServerError
    { $sel:errHTTPCode:ServerError :: Int
errHTTPCode = Int
204,
      $sel:errReasonPhrase:ServerError :: String
errReasonPhrase = String
"No Content",
      $sel:errBody:ServerError :: ByteString
errBody = ByteString
"",
      $sel:errHeaders:ServerError :: [Header]
errHeaders = []
    }

maybe204 :: (Show s) => Either s b -> Handler b
maybe204 :: forall s b. Show s => Either s b -> Handler b
maybe204 (Left s
err) =
  ServerError -> Handler b
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> Handler b) -> ServerError -> Handler b
forall a b. (a -> b) -> a -> b
$ ServerError
err500
      { errBody = fromString . WikiMusic.Protolude.show $ err
      }
maybe204 Either s b
_ = ServerError -> Handler b
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err204

maybe200 :: (Show s) => Either s b -> Handler b
maybe200 :: forall s b. Show s => Either s b -> Handler b
maybe200 (Left s
err) =
  ServerError -> Handler b
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (ServerError -> Handler b) -> ServerError -> Handler b
forall a b. (a -> b) -> a -> b
$ ServerError
err500
      { errBody = fromString . WikiMusic.Protolude.show $ err
      }
maybe200 (Right b
x) = b -> Handler b
forall a. a -> Handler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x

doWithAuth :: Env -> Maybe Text -> (WikiMusicUser -> Handler a) -> Handler a
doWithAuth :: forall a.
Env -> Maybe Text -> (WikiMusicUser -> Handler a) -> Handler a
doWithAuth Env
env Maybe Text
authToken WikiMusicUser -> Handler a
eff = do
  case Maybe Text
authToken of
    Maybe Text
Nothing -> ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
    Just Text
"" -> ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
    Just Text
t -> do
      Maybe WikiMusicUser
authUser <- IO (Maybe WikiMusicUser) -> Handler (Maybe WikiMusicUser)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe WikiMusicUser) -> Handler (Maybe WikiMusicUser))
-> IO (Maybe WikiMusicUser) -> Handler (Maybe WikiMusicUser)
forall a b. (a -> b) -> a -> b
$ Env -> Text -> IO (Maybe WikiMusicUser)
authCheckIO Env
env Text
t
      case Maybe WikiMusicUser
authUser of
        Maybe WikiMusicUser
Nothing -> ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
err401
        Just WikiMusicUser
auth -> WikiMusicUser -> Handler a
eff WikiMusicUser
auth