    {-# LANGUAGE FlexibleContexts    #-}
    {-# LANGUAGE OverloadedStrings   #-}
    {-# LANGUAGE QuasiQuotes         #-}
    {-# LANGUAGE RankNTypes          #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE TypeFamilies        #-}
    -- | Provides a dummy authentication module that simply lets a user specify
    -- their identifier. This is not intended for real world use, just for
    -- testing. This plugin supports form submissions via JSON (since 1.6.8).
    --
    -- = Using the JSON Login Endpoint
    --
    -- We are assuming that you have declared `authRoute` as follows
    --
    -- @
    --       Just $ AuthR LoginR
    -- @
    --
    -- If you are using a different one, then you have to adjust the
    -- endpoint accordingly.
    --
    -- @
    --       Endpoint: \/auth\/page\/dummy
    --       Method: POST
    --       JSON Data: {
    --                      "ident": "my identifier"
    --                  }
    -- @
    --
    -- Remember to add the following headers:
    --
    --     - Accept: application\/json
    --     - Content-Type: application\/json

    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 = String -> (Object -> Parser Text) -> Value -> Parser Text
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
    A.withObject String
    "Ident" (Object -> Key -> Parser Text
    forall a. FromJSON a => Object -> Key -> Parser a
    .: Key
    "ident")

    authDummy :: YesodAuth m => AuthPlugin m
    authDummy :: forall m. YesodAuth m => AuthPlugin m
    authDummy =
        Text
    -> (Text -> [Text] -> AuthHandler m TypedContent)
    -> ((Route Auth -> Route m) -> WidgetFor m ())
    -> AuthPlugin m
    forall master.
    Text
    -> (Text -> [Text] -> AuthHandler master TypedContent)
    -> ((Route Auth -> Route master) -> WidgetFor master ())
    -> AuthPlugin master
    AuthPlugin Text
    "dummy" Text -> [Text] -> m TypedContent
    Text -> [Text] -> AuthHandler m TypedContent
    forall m. Text -> [Text] -> AuthHandler m TypedContent
    dispatch (Route Auth -> Route m) -> WidgetFor m ()
    (Route Auth -> Route (HandlerSite (WidgetFor m))) -> WidgetFor m ()
    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
            (jsonResult :: Result Value) <- m (Result Value)
    forall (m :: * -> *) a.
    (MonadHandler m, FromJSON a) =>
    m (Result a)
    parseCheckJsonBody
            eIdent <- case jsonResult of
                Success Value
    val -> Either String Text -> m (Either String Text)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either String Text -> m (Either String Text))
    -> Either String Text -> m (Either String Text)
    forall a b. (a -> b) -> a -> b
    $ (Value -> Parser Text) -> Value -> Either String Text
    forall a b. (a -> Parser b) -> a -> Either String b
    A.parseEither Value -> Parser Text
    identParser Value
    val
                Error   String
    err -> Either String Text -> m (Either String Text)
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either String Text -> m (Either String Text))
    -> Either String Text -> m (Either String Text)
    forall a b. (a -> b) -> a -> b
    $ String -> Either String Text
    forall a b. a -> Either a b
    Left String
    err
            case eIdent of
                Right Text
    ident ->
                    Creds (HandlerSite m) -> m TypedContent
    forall (m :: * -> *).
    (MonadHandler m, YesodAuth (HandlerSite m)) =>
    Creds (HandlerSite m) -> m TypedContent
    setCredsRedirect (Creds (HandlerSite m) -> m TypedContent)
    -> Creds (HandlerSite m) -> m TypedContent
    forall a b. (a -> b) -> a -> b
    $ Text -> Text -> [(Text, Text)] -> Creds m
    forall master. Text -> Text -> [(Text, Text)] -> Creds master
    Creds Text
    "dummy" Text
    ident []
                Left  String
    _     -> do
                    ident <- FormInput m Text -> m Text
    forall (m :: * -> *) a. MonadHandler m => FormInput m a -> m a
    runInputPost (FormInput m Text -> m Text) -> FormInput m Text -> m Text
    forall a b. (a -> b) -> a -> b
    $ Field m Text -> Text -> FormInput m Text
    forall (m :: * -> *) a.
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m a -> Text -> FormInput m a
    ireq Field m Text
    forall (m :: * -> *).
    (Monad m, RenderMessage (HandlerSite m) FormMessage) =>
    Field m Text
    textField Text
    "ident"
                    setCredsRedirect $ Creds "dummy" ident []
        dispatch Text
    _ [Text]
    _ = m TypedContent
    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
            request <- m YesodRequest
    forall (m :: * -> *). MonadHandler m => m YesodRequest
    getRequest
            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">
    |]