86 lines
3.2 KiB
Haskell
86 lines
3.2 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Auth.Dummy
|
|
( apDummy
|
|
, dummyLogin
|
|
, DummyMessage(..)
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
|
|
import Utils.Metrics
|
|
import Utils.Form
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
data DummyMessage = MsgDummyIdent
|
|
| MsgDummyIdentPlaceholder
|
|
| MsgDummyNoFormData
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
|
|
|
|
|
dummyForm :: ( RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
|
|
, RenderMessage (HandlerSite m) DummyMessage
|
|
, YesodPersist (HandlerSite m)
|
|
, SqlBackendCanRead (YesodPersistBackend (HandlerSite m))
|
|
, MonadHandler m
|
|
) => WForm m (FormResult (CI Text))
|
|
dummyForm = do
|
|
mr <- getMessageRender
|
|
wreq (ciField & addDatalist userList) (fslpI MsgDummyIdent (mr MsgDummyIdentPlaceholder) & addAttr "autocomplete" "username" & addName PostLoginDummy) 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)
|
|
|
|
apDummy :: Text
|
|
apDummy = "dummy"
|
|
|
|
dummyLogin :: forall site.
|
|
( YesodAuth site
|
|
, YesodPersist site
|
|
, SqlBackendCanRead (YesodPersistBackend site)
|
|
, RenderAFormSite site
|
|
, RenderMessage site DummyMessage
|
|
, RenderMessage site (ValueRequired site)
|
|
, Button site ButtonSubmit
|
|
) => AuthPlugin site
|
|
dummyLogin = AuthPlugin{..}
|
|
where
|
|
apName :: Text
|
|
apName = apDummy
|
|
|
|
apDispatch :: forall m. MonadAuthHandler site m => Text -> [Text] -> m TypedContent
|
|
apDispatch method [] | encodeUtf8 method == methodPost = liftSubHandler $ do
|
|
((loginRes, _), _) <- runFormPost $ renderWForm FormLogin 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 -> do
|
|
observeLoginOutcome apName LoginSuccessful
|
|
setCredsRedirect $ Creds apName (CI.original ident) []
|
|
apDispatch _ [] = badMethod
|
|
apDispatch _ _ = notFound
|
|
|
|
apLogin :: (Route Auth -> Route site) -> WidgetFor site ()
|
|
apLogin toMaster = do
|
|
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormLogin dummyForm
|
|
let loginForm = wrapForm login FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute . toMaster $ PluginR apName []
|
|
, formEncoding = loginEnctype
|
|
, formAttrs = [("uw-no-navigate-away-prompt","")]
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Just "login--dummy" :: Maybe Text
|
|
}
|
|
$(widgetFile "widgets/dummy-login-form/dummy-login-form")
|