65 lines
2.3 KiB
Haskell
65 lines
2.3 KiB
Haskell
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
|
|
| MsgDummyNoFormData
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
dummyForm :: ( RenderMessage site FormMessage
|
|
, RenderMessage site DummyMessage
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, Button site ButtonSubmit
|
|
) => AForm (HandlerT site IO) (CI Text)
|
|
dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
|
|
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 ButtonSubmit
|
|
) => 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 -> do
|
|
lift $ addMessageI Warning MsgDummyNoFormData
|
|
redirect LoginR
|
|
FormSuccess ident ->
|
|
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
|
apDispatch _ _ = notFound
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR "dummy" []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--dummy" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/dummy-login-form/dummy-login-form")
|