Dummy: Add support for JSON submissions

yesod-auth/ChangeLog.md

@@ -4,6 +4,10 @@
 
 * Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)
 
+## 1.6.8
+
+* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)
+
 ## 1.6.7
 
 * Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)

yesod-auth/Yesod/Auth/Dummy.hs

@@ -2,24 +2,67 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | Provides a dummy authentication module that simply lets a user specify
--- his/her identifier. This is not intended for real world use, just for
+-- their identifier. This is not intended for real world use, just for
--- testing.
+-- 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.Form (FormResult(..), runInputPostResult, textField, ireq)
 import Yesod.Core
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Aeson.Types (Result(..), Parser)
+import qualified Data.Aeson.Types as A (parseEither, withObject)
+
+identParser :: Value -> Parser Text
+identParser = A.withObject "Ident" (.: "ident")
 
 authDummy :: YesodAuth m => AuthPlugin m
 authDummy =
     AuthPlugin "dummy" dispatch login
   where
     dispatch "POST" [] = do
-        ident <- runInputPost $ ireq textField "ident"
+        formResult <- runInputPostResult $ ireq textField "ident"
-        setCredsRedirect $ Creds "dummy" ident []
+        eIdent <- case formResult of
+          FormSuccess ident ->
+            return $ Right ident
+          _ -> do
+            (jsonResult :: Result Value) <- parseCheckJsonBody
+            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  err   -> invalidArgs [T.pack err]
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster = do

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.6.7
+version:         1.6.8
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin