{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Yesod.Auth.Dummy
( authDummy
) where
import Data.Aeson.Types (Parser, Result (..))
import qualified Data.Aeson.Types as A (parseEither, withObject)
import Data.Text (Text)
import Yesod.Auth
import Yesod.Core
import Yesod.Form (ireq, runInputPost, textField)
identParser :: Value -> Parser Text
identParser :: Value -> Parser Text
identParser = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Ident" (forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"ident")
authDummy :: YesodAuth m => AuthPlugin m
authDummy :: forall m. YesodAuth m => AuthPlugin m
authDummy =
forall master.
Text
-> (Text -> [Text] -> AuthHandler master TypedContent)
-> ((Route Auth -> Route master) -> WidgetFor master ())
-> AuthPlugin master
AuthPlugin Text
"dummy" forall m. Text -> [Text] -> AuthHandler m TypedContent
dispatch forall {m :: * -> *}.
MonadWidget m =>
(Route Auth -> Route (HandlerSite m)) -> m ()
login
where
dispatch :: Text -> [Text] -> AuthHandler m TypedContent
dispatch :: forall m. Text -> [Text] -> AuthHandler m TypedContent
dispatch Text
"POST" [] = do
(Result Value
jsonResult :: Result Value) <- forall (m :: * -> *) a.
(MonadHandler m, FromJSON a) =>
m (Result a)
parseCheckJsonBody
Either String Text
eIdent <- case Result Value
jsonResult of
Success Value
val -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> Either String b
A.parseEither Value -> Parser Text
identParser Value
val
Error String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
err
case Either String Text
eIdent of
Right Text
ident ->
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect forall a b. (a -> b) -> a -> b
$ forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"dummy" Text
ident []
Left String
_ -> do
Text
ident <- forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
runInputPost forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m a -> Text -> FormInput m a
ireq forall (m :: * -> *).
(Monad m, RenderMessage (HandlerSite m) FormMessage) =>
Field m Text
textField Text
"ident"
forall (m :: * -> *).
(MonadHandler m, YesodAuth (HandlerSite m)) =>
Creds (HandlerSite m) -> m TypedContent
setCredsRedirect forall a b. (a -> b) -> a -> b
$ forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"dummy" Text
ident []
dispatch Text
_ [Text]
_ = forall (m :: * -> *) a. MonadHandler m => m a
notFound
url :: Route Auth
url = Text -> [Text] -> Route Auth
PluginR Text
"dummy" []
login :: (Route Auth -> Route (HandlerSite m)) -> m ()
login Route Auth -> Route (HandlerSite m)
authToMaster = do
YesodRequest
request <- forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget [hamlet|
$newline never
<form method="post" action="@{authToMaster url}">
$maybe t <- reqToken request
<input type=hidden name=#{defaultCsrfParamName} value=#{t}>
Your new identifier is: #
<input type="text" name="ident">
<input type="submit" value="Dummy Login">
|]