78 lines
2.4 KiB
Haskell
78 lines
2.4 KiB
Haskell
{-# 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 = A.withObject "Ident" (.: "ident")
|
|
|
|
authDummy :: YesodAuth m => AuthPlugin m
|
|
authDummy =
|
|
AuthPlugin "dummy" dispatch login
|
|
where
|
|
dispatch :: Text -> [Text] -> AuthHandler m TypedContent
|
|
dispatch "POST" [] = do
|
|
(jsonResult :: Result Value) <- parseCheckJsonBody
|
|
eIdent <- case jsonResult of
|
|
Success val -> return $ A.parseEither identParser val
|
|
Error err -> return $ Left err
|
|
case eIdent of
|
|
Right ident ->
|
|
setCredsRedirect $ Creds "dummy" ident []
|
|
Left _ -> do
|
|
ident <- runInputPost $ ireq textField "ident"
|
|
setCredsRedirect $ Creds "dummy" ident []
|
|
dispatch _ _ = notFound
|
|
url = PluginR "dummy" []
|
|
login authToMaster = do
|
|
request <- 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">
|
|
|]
|