diff --git a/messages/dummy/de.msg b/messages/dummy/de.msg new file mode 100644 index 000000000..f3ca7cae1 --- /dev/null +++ b/messages/dummy/de.msg @@ -0,0 +1 @@ +DummyIdent: Nutzer-Kennung \ No newline at end of file diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs new file mode 100644 index 000000000..2a5cc5b59 --- /dev/null +++ b/src/Auth/Dummy.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoImplicitPrelude + , ExplicitForAll + , RecordWildCards + , TemplateHaskell + , FlexibleContexts + , TypeFamilies + , OverloadedStrings + #-} + +module Auth.Dummy + ( dummyLogin + , DummyMessage(..) + ) where + +import Import.NoFoundation + +import Utils.Form + + +data DummyMessage = MsgDummyIdent + + +dummyForm :: ( RenderMessage site FormMessage + , RenderMessage site DummyMessage + , YesodPersist site + , YesodPersistBackend site ~ SqlBackend + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AForm (HandlerT site IO) Text +dummyForm = areq userField (fslpI MsgDummyIdent "plugin:ident") Nothing + <* submitButton + where + userField = textField `addDatalist` liftHandlerT (runDB userList) + userList = map (\(Entity _ User{..}) -> userPlugin <> ":" <> userIdent) <$> selectList [] [Asc UserPlugin, Asc UserIdent] + +dummyLogin :: forall site. + ( YesodAuth site + , YesodPersist site + , YesodPersistBackend site ~ SqlBackend + , 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" ident [] + apDispatch _ _ = notFound + apLogin toMaster = do + (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm + $(widgetFile "widgets/dummy-login-form") diff --git a/src/Foundation.hs b/src/Foundation.hs index 7f25aa50b..5c90f9637 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -25,6 +25,7 @@ import Yesod.Auth.Message import Yesod.Auth.Dummy import Auth.LDAP import Auth.PWFile +import Auth.Dummy import qualified Network.Wai as W (requestMethod, pathInfo) @@ -166,6 +167,7 @@ data MenuTypes -- Semantische Rolle: -- Messages mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" +mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -1257,7 +1259,7 @@ instance YesodAuth UniWorX where authPlugins (appSettings -> AppSettings{..}) = catMaybes [ campusLogin <$> appLdapConf , maintenanceLogin <$> appAuthPWFile - , authDummy <$ guard appAuthDummyLogin + , dummyLogin <$ guard appAuthDummyLogin ] authHttpManager = getHttpManager diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 208d42caf..34cf9f0b2 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -118,6 +118,20 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass) setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg } +addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a +addDatalist field mValues = field + { fieldView = \fId fName fAttrs fRes fReq -> do + listId <- newIdent + values <- map toPathPiece . otoList <$> mValues + fieldView field fId fName (("list", listId) : fAttrs) fRes fReq + [whamlet| + $newline never + + $forall value <- values +