67 lines
2.2 KiB
Haskell
67 lines
2.2 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Client.Auth where
|
|
|
|
import Relude
|
|
|
|
import Server.Types
|
|
import Data.Morpheus.Client
|
|
import Yesod
|
|
import Yesod.Auth
|
|
import qualified "base64" Data.ByteString.Base64 as B64 (encodeBase64)
|
|
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
|
|
maybeAuth <- liftHandler $ authReq $ ("Basic " <> ) $ B64.encodeBase64 $ encodeUtf8 auth
|
|
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">
|
|
|]
|