64 lines
2.1 KiB
Haskell
64 lines
2.1 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, RecordWildCards
|
|
, TemplateHaskell
|
|
, FlexibleContexts
|
|
, TypeFamilies
|
|
, OverloadedStrings
|
|
#-}
|
|
|
|
module Auth.Dummy
|
|
( dummyLogin
|
|
, DummyMessage(..)
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
|
|
import Utils.Form
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
data DummyMessage = MsgDummyIdent
|
|
|
|
|
|
dummyForm :: ( RenderMessage site FormMessage
|
|
, RenderMessage site DummyMessage
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, Button site SubmitButton
|
|
, Show (ButtonCssClass site)
|
|
) => AForm (HandlerT site IO) (CI Text)
|
|
dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
|
|
<* submitButton
|
|
where
|
|
userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
|
|
toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
|
|
|
|
dummyLogin :: ( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, RenderMessage site FormMessage
|
|
, RenderMessage site DummyMessage
|
|
, Button site SubmitButton
|
|
, Show (ButtonCssClass site)
|
|
) => AuthPlugin site
|
|
dummyLogin = AuthPlugin{..}
|
|
where
|
|
apName = "dummy"
|
|
-- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
|
apDispatch "POST" [] = do
|
|
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
lift . forM_ errs $ addMessage Error . toHtml
|
|
redirect LoginR
|
|
FormMissing -> redirect LoginR
|
|
FormSuccess ident ->
|
|
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
|
apDispatch _ _ = notFound
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
|
$(widgetFile "widgets/dummy-login-form")
|