{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Client.Auth where import Relude import Server.Types import Data.Morpheus.Client import Yesod import Yesod.Auth import qualified Data.ByteString.Base64 as B64 (encode) 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 " <> ) $ decodeUtf8 $ B64.encode $ 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|

Kirjaudu