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")