datarekisteri/Client/Auth.hs

67 lines
2.2 KiB
Haskell
Raw Normal View History

2023-01-20 09:20:06 +02:00
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
2023-08-15 10:06:54 +03:00
{-# LANGUAGE PackageImports #-}
2023-01-20 09:20:06 +02:00
{-# LANGUAGE NoImplicitPrelude #-}
module Client.Auth where
import Relude
import Server.Types
import Data.Morpheus.Client
import Yesod
import Yesod.Auth
2023-08-15 10:06:54 +03:00
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
2023-01-20 09:20:06 +02:00
import qualified Yesod.Auth.Message as Msg
pluginName = "externalBasic"
loginR = PluginR pluginName ["login"]
type Authorization = Text
type CredsIdent = Text
postLoginR :: YesodAuth master =>
(Authorization -> HandlerFor master (Maybe CredsIdent)) -> AuthHandler master TypedContent
postLoginR authReq = do
res <- runInputPostResult $ (\x y -> x <> ":" <> y)
<$> ireq textField "email" <*> ireq textField "password"
case res of
FormSuccess auth -> do
2023-08-15 10:06:54 +03:00
maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ B64.encodeBase64 $ encodeUtf8 auth
2023-01-20 09:20:06 +02:00
case maybeAuth of
Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided -- invalid creds
Just txt -> do
setCredsRedirect Creds {credsPlugin = pluginName, credsIdent = txt, credsExtra = []}
_ -> loginErrorMessageI LoginR Msg.NoIdentifierProvided
authExternalBasic :: forall site. YesodAuth site =>
(Authorization -> HandlerFor site (Maybe CredsIdent)) -> AuthPlugin site
authExternalBasic authReq = AuthPlugin pluginName dispatch loginForm
where dispatch :: YesodAuth site => Text -> [Text] -> AuthHandler site TypedContent
dispatch "POST" ["login"] = postLoginR authReq >>= sendResponse
dispatch _ _ = notFound
loginForm :: YesodAuth site => (Route Auth -> Route site) -> WidgetFor site ()
loginForm toParent = do
emailId <- newIdent
passwordId <- newIdent
[whamlet|
<h1>Kirjaudu
<form action=@{toParent loginR} method=post>
<label for="#{emailId}">
Sähköposti
<input id="#{emailId}" name="email" type="text" autofocus>
<label for="#{passwordId}">
Salasana
<input id="#{passwordId}" name="password" type="password">
<input type="submit" value="Kirjaudu">
|]