{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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 Yesod.Auth
import Yesod.Form (runInputPost, textField, ireq)
import Yesod.Core
import Data.Text (Text)
import Data.Aeson.Types (Result(..), Parser)
import qualified Data.Aeson.Types as A (parseEither, withObject)

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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"ident")

authDummy :: YesodAuth m => AuthPlugin m
authDummy :: 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] -> AuthHandler m TypedContent
forall a (m :: * -> *) a.
(IsString a, MonadHandler m, YesodAuth (HandlerSite m), Eq a) =>
a -> [a] -> m TypedContent
dispatch (Route Auth -> Route m) -> WidgetFor m ()
forall (m :: * -> *).
MonadWidget m =>
(Route Auth -> Route (HandlerSite m)) -> m ()
login
  where
    dispatch :: a -> [a] -> m TypedContent
dispatch a
"POST" [] = do
        (Result Value
jsonResult :: Result Value) <- m (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 -> Either String Text -> m (Either String Text)
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 (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 Either String Text
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 (HandlerSite m)
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"dummy" Text
ident []
            Left  String
_     -> do
                Text
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"
                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 (HandlerSite m)
forall master. Text -> Text -> [(Text, Text)] -> Creds master
Creds Text
"dummy" Text
ident []
    dispatch a
_ [a]
_ = 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
        YesodRequest
request <- m YesodRequest
forall (m :: * -> *). MonadHandler m => m YesodRequest
getRequest
        ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> MarkupM ())
-> m ()
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">
|]