75 lines
2.8 KiB
Haskell
75 lines
2.8 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
|
|
| MsgDummyIdentPlaceholder
|
|
| MsgDummyNoFormData
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
|
|
dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) DummyMessage
|
|
, YesodPersist (HandlerSite m)
|
|
, SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
|
|
, Button (HandlerSite m) ButtonSubmit
|
|
, MonadHandler m
|
|
) => AForm m (CI Text)
|
|
dummyForm = wFormToAForm $ do
|
|
mr <- getMessageRender
|
|
aFormToWForm $ areq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & noAutocomplete) Nothing
|
|
where
|
|
userList = fmap mkOptionList . runDB $ withReaderT projectBackend (map toOption <$> selectList [] [Asc UserIdent] :: ReaderT SqlBackend _ [Option UserIdent])
|
|
toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
|
|
|
|
dummyLogin :: forall site.
|
|
( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, RenderMessage site AFormMessage
|
|
, RenderMessage site DummyMessage
|
|
, Button site ButtonSubmit
|
|
) => AuthPlugin site
|
|
dummyLogin = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = "dummy"
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch "POST" [] = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderAForm FormStandard dummyForm
|
|
tp <- getRouteToParent
|
|
case loginRes of
|
|
FormFailure errs -> do
|
|
forM_ errs $ addMessage Error . toHtml
|
|
redirect $ tp LoginR
|
|
FormMissing -> do
|
|
addMessageI Warning MsgDummyNoFormData
|
|
redirect $ tp LoginR
|
|
FormSuccess ident ->
|
|
setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
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 = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--dummy" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/dummy-login-form/dummy-login-form")
|