Better dummy login

messages/dummy/de.msg

@@ -0,0 +1 @@
+DummyIdent: Nutzer-Kennung

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

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

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
+        <datalist ##{listId}>
+          $forall value <- values
+            <option value=#{value}>
+      |]
+  }
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------

templates/widgets/dummy-login-form.hamlet

@@ -0,0 +1,2 @@
+<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
+  ^{login}