Merge conflicts resolved
This commit is contained in:
SJost
commit
47d74577bc
@ -1,3 +1,7 @@
|
||||
* Version 01.08.2018
|
||||
|
||||
Verbesserter Campus-Login
|
||||
|
||||
* Version 31.07.2018
|
||||
|
||||
Viele Verbesserung zur Anzeige von Korrekturen
|
||||
|
||||
@ -20,14 +20,19 @@ stanzas:
|
||||
ssl: true
|
||||
|
||||
forward-env:
|
||||
- LDAPURI
|
||||
- LDAPDN
|
||||
- LDAPPW
|
||||
- LDAPBN
|
||||
- LDAPHOST
|
||||
- LDAPTLS
|
||||
- LDAPPORT
|
||||
- LDAPUSER
|
||||
- LDAPPASS
|
||||
- LDAPBASE
|
||||
- LDAPSCOPE
|
||||
- LDAPTIMEOUT
|
||||
- DUMMY_LOGIN
|
||||
- DETAILED_LOGGING
|
||||
- LOG_ALL
|
||||
- PWFILE
|
||||
- CRYPTOID_KEYFILE
|
||||
|
||||
# Use the following to automatically copy your bundle upon creation via `yesod
|
||||
# keter`. Uses `scp` internally, so you can set it to a remote destination
|
||||
|
||||
@ -20,10 +20,14 @@ stanzas:
|
||||
ssl: true
|
||||
|
||||
forward-env:
|
||||
- LDAPURI
|
||||
- LDAPDN
|
||||
- LDAPPW
|
||||
- LDAPBN
|
||||
- LDAPHOST
|
||||
- LDAPTLS
|
||||
- LDAPPORT
|
||||
- LDAPUSER
|
||||
- LDAPPASS
|
||||
- LDAPBASE
|
||||
- LDAPSCOPE
|
||||
- LDAPTIMEOUT
|
||||
- DETAILED_LOGGING
|
||||
- LOG_ALL
|
||||
- PWFILE
|
||||
|
||||
@ -35,10 +35,14 @@ database:
|
||||
poolsize: "_env:PGPOOLSIZE:10"
|
||||
|
||||
ldap:
|
||||
uri: "_env:LDAPURI:ldap://localhost:389"
|
||||
dn: "_env:LDAPDN:uniworx"
|
||||
password: "_env:LDAPPW:"
|
||||
basename: "_env:LDAPBN:"
|
||||
host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
port: "_env:LDAPPORT:389"
|
||||
user: "_env:LDAPUSER:"
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
|
||||
default-favourites: 12
|
||||
default-theme: Default
|
||||
|
||||
5
messages/campus/de.msg
Normal file
5
messages/campus/de.msg
Normal file
@ -0,0 +1,5 @@
|
||||
CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben.
|
||||
CampusIdent: Campus-Kennung
|
||||
CampusPassword: Passwort
|
||||
CampusSubmit: Abschicken
|
||||
CampusInvalidCredentials: Ungültige Logindaten
|
||||
@ -32,6 +32,7 @@ LectureStart: Beginn Vorlesungen
|
||||
Course: Kurs
|
||||
CourseShort: Kürzel
|
||||
CourseCapacity: Kapazität
|
||||
CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt
|
||||
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
|
||||
CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
@ -48,6 +49,22 @@ TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
CourseNewHeading: Neuen Kurs anlegen
|
||||
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
CourseMembers: Teilnehmer
|
||||
CourseMembersCount num@Int64: #{display num}
|
||||
CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
|
||||
CourseName: Name
|
||||
CourseDescription: Beschreibung
|
||||
CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
|
||||
CourseHomepage: Homepage
|
||||
CourseShorthand: Kürzel
|
||||
CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein
|
||||
CourseSemester: Semester
|
||||
CourseSchool: Institut
|
||||
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
|
||||
CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
|
||||
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
|
||||
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
|
||||
|
||||
|
||||
Sheet: Blatt
|
||||
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
@ -69,12 +86,19 @@ SheetSolution: Lösung
|
||||
SheetSolutionFrom: Lösung ab
|
||||
SheetMarking: Hinweise für Korrektoren
|
||||
SheetType: Wertung
|
||||
|
||||
SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
|
||||
SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}!
|
||||
SheetName: Name
|
||||
SheetDescription: Hinweise für Teilnehmer
|
||||
SheetGroup: Gruppenabgabe
|
||||
SheetVisibleFrom: Sichtbar ab
|
||||
SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
|
||||
SheetActiveFrom: Aktiv ab
|
||||
SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
|
||||
SheetActiveTo: Abgabefrist
|
||||
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
|
||||
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
|
||||
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
|
||||
|
||||
SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
|
||||
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
|
||||
@ -145,7 +169,8 @@ CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern die
|
||||
|
||||
Users: Benutzer
|
||||
HomeHeading: Aktuelle Termine
|
||||
LoginHeading: Login bitte mit "@campus.lmu.de" angeben
|
||||
LoginHeading: Authentifizierung
|
||||
LoginTitle: Authentifizierung
|
||||
ProfileHeading: Benutzerprofil und Einstellungen
|
||||
ProfileDataHeading: Gespeicherte Benutzerdaten
|
||||
ImpressumHeading: Impressum
|
||||
@ -201,6 +226,7 @@ RatingPoints: Punkte
|
||||
RatingPercent: Erreicht
|
||||
RatingFiles: Korrigierte Dateien
|
||||
PointsNotPositive: Punktzahl darf nicht negativ sein
|
||||
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
|
||||
|
||||
FileTitle: Dateiname
|
||||
FileModified: Letzte Änderung
|
||||
@ -211,10 +237,6 @@ RatingUpdated: Korrektur gespeichert
|
||||
RatingDeleted: Korrektur zurückgesetzt
|
||||
RatingFilesUpdated: Korrigierte Dateien überschrieben
|
||||
|
||||
CourseMembers: Teilnehmer
|
||||
CourseMembersCount num@Int64: #{display num}
|
||||
CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
|
||||
|
||||
NoTableContent: Kein Tabelleninhalt
|
||||
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
||||
|
||||
@ -235,3 +257,6 @@ LastEdit: Letzte Änderung
|
||||
|
||||
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
|
||||
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
|
||||
|
||||
LDAPLoginTitle: Campus-Login
|
||||
DummyLoginTitle: Development-Login
|
||||
@ -74,8 +74,6 @@ dependencies:
|
||||
- generic-deriving
|
||||
- blaze-html
|
||||
- conduit-resumablesink >=0.2
|
||||
- yesod-auth-ldap
|
||||
- LDAP
|
||||
- parsec
|
||||
- uuid
|
||||
- exceptions
|
||||
@ -88,6 +86,7 @@ dependencies:
|
||||
- th-lift-instances
|
||||
- gitrev
|
||||
- Glob
|
||||
- ldap-client
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
152
src/Auth/LDAP.hs
Normal file
152
src/Auth/LDAP.hs
Normal file
@ -0,0 +1,152 @@
|
||||
{-# LANGUAGE RecordWildCards
|
||||
, OverloadedStrings
|
||||
, TemplateHaskell
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, NoImplicitPrelude
|
||||
, ScopedTypeVariables
|
||||
#-}
|
||||
|
||||
module Auth.LDAP
|
||||
( campusLogin
|
||||
, campusUser
|
||||
, CampusMessage(..)
|
||||
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Control.Lens
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Yesod.Auth.Message as Msg
|
||||
|
||||
|
||||
data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text }
|
||||
|
||||
data CampusMessage = MsgCampusIdentNote
|
||||
| MsgCampusIdent
|
||||
| MsgCampusPassword
|
||||
| MsgCampusSubmit
|
||||
| MsgCampusInvalidCredentials
|
||||
|
||||
|
||||
findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
||||
where
|
||||
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope ldapScope
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
|
||||
userPrincipalName :: Ldap.Attr
|
||||
userPrincipalName = Ldap.Attr "userPrincipalName"
|
||||
|
||||
campusForm :: ( RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => AForm (HandlerT site IO) CampusLogin
|
||||
campusForm = CampusLogin
|
||||
<$> areq textField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
|
||||
<*> areq passwordField (fslI MsgCampusPassword) Nothing
|
||||
<* submitButton
|
||||
|
||||
campusLogin :: forall site.
|
||||
( YesodAuth site
|
||||
, RenderMessage site FormMessage
|
||||
, RenderMessage site CampusMessage
|
||||
, Button site SubmitButton
|
||||
, Show (ButtonCssClass site)
|
||||
) => LdapConf -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} = AuthPlugin{..}
|
||||
where
|
||||
apName = "LDAP"
|
||||
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||
apDispatch "POST" [] = do
|
||||
((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
|
||||
case loginRes of
|
||||
FormFailure errs -> do
|
||||
forM_ errs $ addMessage "error" . toHtml
|
||||
redirect LoginR
|
||||
FormMissing -> redirect LoginR
|
||||
FormSuccess CampusLogin{..} -> do
|
||||
ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
|
||||
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
findUser conf ldap campusIdent [userPrincipalName]
|
||||
case ldapResult of
|
||||
Left err
|
||||
| Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
|
||||
-> do
|
||||
$logDebugS "LDAP" "Invalid credentials"
|
||||
loginErrorMessageI LoginR Msg.InvalidLogin
|
||||
| otherwise -> do
|
||||
$logErrorS "LDAP" $ "Error during login: " <> tshow err
|
||||
loginErrorMessageI LoginR Msg.AuthError
|
||||
Right searchResults
|
||||
| [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
|
||||
, Just [principalName] <- lookup userPrincipalName userAttrs
|
||||
, Right credsIdent <- Text.decodeUtf8' principalName
|
||||
-> do
|
||||
$logDebugS "LDAP" $ tshow searchResults
|
||||
lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
|
||||
| otherwise -> do
|
||||
$logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
|
||||
loginErrorMessageI LoginR Msg.AuthError
|
||||
apDispatch _ _ = notFound
|
||||
apLogin toMaster = do
|
||||
(login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
|
||||
$(widgetFile "widgets/campus-login-form")
|
||||
|
||||
data CampusUserException = CampusUserLdapError Ldap.LdapError
|
||||
| CampusUserNoResult
|
||||
| CampusUserAmbiguous
|
||||
deriving (Show, Eq, Typeable)
|
||||
|
||||
instance Exception CampusUserException
|
||||
|
||||
campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
let userFilter = Ldap.Present userPrincipalName
|
||||
userSearchSettings = mconcat
|
||||
[ Ldap.scope Ldap.BaseObject
|
||||
, Ldap.size 2
|
||||
, Ldap.time ldapTimeout
|
||||
, Ldap.derefAliases Ldap.DerefAlways
|
||||
]
|
||||
Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
|
||||
Nothing -> do
|
||||
findUser conf ldap credsIdent []
|
||||
case results of
|
||||
[] -> throwM CampusUserNoResult
|
||||
[Ldap.SearchEntry _ attrs] -> return attrs
|
||||
_otherwise -> throwM CampusUserAmbiguous
|
||||
|
||||
-- ldapConfig :: UniWorX -> LDAPConfig
|
||||
-- ldapConfig _app@(appSettings -> settings) = LDAPConfig
|
||||
-- { usernameFilter = \u -> principalName <> "=" <> u
|
||||
-- , identifierModifier
|
||||
-- , ldapUri = appLDAPURI settings
|
||||
-- , initDN = appLDAPDN settings
|
||||
-- , initPass = appLDAPPw settings
|
||||
-- , baseDN = appLDAPBaseName settings
|
||||
-- , ldapScope = LdapScopeSubtree
|
||||
-- }
|
||||
-- where
|
||||
-- principalName :: IsString a => a
|
||||
-- principalName = "userPrincipalName"
|
||||
-- identifierModifier _ entry = case lookup principalName $ leattrs entry of
|
||||
-- Just [n] -> Text.pack n
|
||||
-- _ -> error "Could not determine user principal name"
|
||||
60
src/Auth/PWFile.hs
Normal file
60
src/Auth/PWFile.hs
Normal file
@ -0,0 +1,60 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, QuasiQuotes
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
, RecordWildCards
|
||||
, OverloadedStrings
|
||||
, FlexibleContexts
|
||||
, TypeFamilies
|
||||
#-}
|
||||
|
||||
module Auth.PWFile
|
||||
( maintenanceLogin
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Database.Persist.Sql (IsSqlBackend)
|
||||
|
||||
import qualified Data.Yaml as Yaml
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Yesod.Auth.Util.PasswordStore (verifyPassword)
|
||||
|
||||
|
||||
maintenanceLogin :: ( YesodAuth site
|
||||
, YesodPersist site
|
||||
, IsSqlBackend (YesodPersistBackend site)
|
||||
, PersistUniqueWrite (YesodPersistBackend site)
|
||||
) => FilePath -> AuthPlugin site
|
||||
maintenanceLogin fp = AuthPlugin{..}
|
||||
where
|
||||
apName = "PWFile"
|
||||
apLogin = mempty
|
||||
apDispatch "GET" [] = do
|
||||
authData <- lookupBasicAuth
|
||||
pwdata <- liftIO $ Yaml.decodeFileEither fp
|
||||
|
||||
addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
|
||||
|
||||
case pwdata of
|
||||
Left err -> $logDebugS "Auth" $ tshow err
|
||||
Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
|
||||
|
||||
case (authData, pwdata) of
|
||||
(Nothing, _) -> do
|
||||
notAuthenticated
|
||||
(Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
|
||||
| [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
|
||||
<- [ pwe | pwe@PWEntry{..} <- pwdata'
|
||||
, let User{..} = pwUser
|
||||
, userIdent == usr
|
||||
, userPlugin == apName
|
||||
]
|
||||
, verifyPassword pw pwHash
|
||||
-> lift $ do
|
||||
runDB . void $ insertUnique pwUser
|
||||
setCredsRedirect $ Creds apName userIdent []
|
||||
_ -> permissionDenied "Invalid auth"
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
@ -55,6 +55,7 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
|
||||
decCryptoIDs [ ''SubmissionId
|
||||
, ''FileId
|
||||
, ''UserId
|
||||
, ''CourseId
|
||||
]
|
||||
|
||||
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
|
||||
|
||||
@ -23,13 +23,11 @@ import Text.Jasmine (minifym)
|
||||
-- Used only when in "auth-dummy-login" setting is enabled.
|
||||
import Yesod.Auth.Message
|
||||
import Yesod.Auth.Dummy
|
||||
import Yesod.Auth.LDAP
|
||||
import Auth.LDAP
|
||||
import Auth.PWFile
|
||||
|
||||
import qualified Network.Wai as W (requestMethod, pathInfo)
|
||||
|
||||
import LDAP.Data (LDAPScope(..))
|
||||
import LDAP.Search (LDAPEntry(..))
|
||||
|
||||
import Yesod.Default.Util (addStaticContentExternal)
|
||||
import Yesod.Core.Types (Logger)
|
||||
import qualified Yesod.Core.Unsafe as Unsafe
|
||||
@ -43,8 +41,6 @@ import Data.ByteArray (convert)
|
||||
import Crypto.Hash (Digest, SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
|
||||
import Yesod.Auth.Util.PasswordStore
|
||||
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
@ -81,6 +77,7 @@ import Handler.Utils.Templates
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Control.Lens
|
||||
import Utils
|
||||
import Utils.Form
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson
|
||||
@ -164,7 +161,8 @@ data MenuTypes -- Semantische Rolle:
|
||||
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten
|
||||
|
||||
-- Messages
|
||||
mkMessage "UniWorX" "messages" "de"
|
||||
mkMessage "UniWorX" "messages/uniworx" "de"
|
||||
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
-- achieve customized and internationalized form validation messages.
|
||||
@ -200,6 +198,16 @@ instance RenderMessage UniWorX SheetFileType where
|
||||
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
|
||||
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
|
||||
|
||||
|
||||
data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
instance Button UniWorX SubmitButton where
|
||||
label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
|
||||
|
||||
cssClass BtnSubmit = BCPrimary
|
||||
|
||||
|
||||
getTimeLocale' :: [Lang] -> TimeLocale
|
||||
getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
|
||||
|
||||
@ -504,13 +512,6 @@ instance Yesod UniWorX where
|
||||
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
|
||||
redirectWith movedPermanently301 route'
|
||||
|
||||
-- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
|
||||
isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
|
||||
isWriteRequest _ = do
|
||||
wai <- waiRequest
|
||||
return $ W.requestMethod wai `notElem`
|
||||
["GET", "HEAD", "OPTIONS", "TRACE"]
|
||||
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
mmsgs <- getMessages
|
||||
@ -1067,12 +1068,13 @@ instance YesodAuth UniWorX where
|
||||
redirectToReferer _ = True
|
||||
|
||||
loginHandler = do
|
||||
tp <- getRouteToParent
|
||||
lift . authLayout $ do
|
||||
master <- getYesod
|
||||
let authPlugins' = authPlugins master
|
||||
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName authPlugins')
|
||||
forM_ authPlugins' $ flip apLogin tp
|
||||
toParent <- getRouteToParent
|
||||
lift . defaultLayout $ do
|
||||
plugins <- getsYesod authPlugins
|
||||
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
|
||||
|
||||
setTitleI MsgLoginTitle
|
||||
$(widgetFile "login")
|
||||
|
||||
authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do
|
||||
let (userPlugin, userIdent)
|
||||
@ -1085,118 +1087,88 @@ instance YesodAuth UniWorX where
|
||||
isPWFile = credsPlugin == "PWFile"
|
||||
uAuth = UniqueAuthentication userPlugin userIdent
|
||||
|
||||
$logDebugS "auth" $ tshow ((userPlugin, userIdent), creds)
|
||||
|
||||
when (isDummy || isPWFile) . (throwError =<<) . lift $
|
||||
maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
|
||||
let
|
||||
userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra
|
||||
userEmail' = lookup "mail" credsExtra
|
||||
userDisplayName' = lookup "displayName" credsExtra
|
||||
|
||||
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail'
|
||||
userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
|
||||
$logDebugS "auth" $ tshow creds
|
||||
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
let
|
||||
userMaxFavourites = appDefaultMaxFavourites
|
||||
userTheme = appDefaultTheme
|
||||
userDateTimeFormat = appDefaultDateTimeFormat
|
||||
userDateFormat = appDefaultDateFormat
|
||||
userTimeFormat = appDefaultTimeFormat
|
||||
newUser = User{..}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserEmail =. userEmail
|
||||
case appLdapConf of
|
||||
Just ldapConf -> do
|
||||
ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
|
||||
let
|
||||
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
|
||||
userEmail' = lookup (Attr "mail") ldapData
|
||||
userDisplayName' = lookup (Attr "displayName") ldapData
|
||||
|
||||
userEmail <- if
|
||||
| Just [bs] <- userEmail'
|
||||
, Right userEmail <- Text.decodeUtf8' bs
|
||||
-> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user email"
|
||||
userDisplayName <- if
|
||||
| Just [bs] <- userDisplayName'
|
||||
, Right userDisplayName <- Text.decodeUtf8' bs
|
||||
-> return userDisplayName
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not retrieve user name"
|
||||
userMatrikelnummer <- if
|
||||
| Just [bs] <- userMatrikelnummer'
|
||||
, Right userMatrikelnummer <- Text.decodeUtf8' bs
|
||||
-> return $ Just userMatrikelnummer
|
||||
| Nothing <- userMatrikelnummer'
|
||||
-> return Nothing
|
||||
| otherwise
|
||||
-> throwError $ ServerError "Could not decode user matriculation"
|
||||
|
||||
let
|
||||
userMaxFavourites = appDefaultMaxFavourites
|
||||
userTheme = appDefaultTheme
|
||||
userDateTimeFormat = appDefaultDateTimeFormat
|
||||
userDateFormat = appDefaultDateFormat
|
||||
userTimeFormat = appDefaultTimeFormat
|
||||
newUser = User{..}
|
||||
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
|
||||
, UserDisplayName =. userDisplayName
|
||||
, UserEmail =. userEmail
|
||||
]
|
||||
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
|
||||
|
||||
let
|
||||
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
|
||||
userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ]
|
||||
let
|
||||
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
|
||||
userStudyFeatures' = do
|
||||
(k, v) <- ldapData
|
||||
guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
|
||||
v' <- v
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
return str
|
||||
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
|
||||
|
||||
lift $ deleteWhere [StudyFeaturesUser ==. userId]
|
||||
lift $ deleteWhere [StudyFeaturesUser ==. userId]
|
||||
|
||||
forM_ fs $ \StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
forM_ fs $ \StudyFeatures{..} -> do
|
||||
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
|
||||
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
|
||||
|
||||
lift $ insertMany_ fs
|
||||
return $ Authenticated userId
|
||||
Nothing -> (throwError =<<) . lift $
|
||||
maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||
|
||||
lift $ insertMany_ fs
|
||||
return $ Authenticated userId
|
||||
where
|
||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||
|
||||
-- You can add other plugins like Google Email, email or OAuth here
|
||||
authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins
|
||||
-- Enable authDummy login if enabled.
|
||||
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
|
||||
++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app]
|
||||
authPlugins (appSettings -> AppSettings{..}) = catMaybes
|
||||
[ campusLogin <$> appLdapConf
|
||||
, maintenanceLogin <$> appAuthPWFile
|
||||
, authDummy <$ guard appAuthDummyLogin
|
||||
]
|
||||
|
||||
authHttpManager = getHttpManager
|
||||
|
||||
authPWFile :: FilePath -> AuthPlugin UniWorX
|
||||
authPWFile fp = AuthPlugin{..}
|
||||
where
|
||||
apName = "PWFile"
|
||||
apLogin = mempty
|
||||
apDispatch "GET" [] = do
|
||||
authData <- lookupBasicAuth
|
||||
pwdata <- liftIO $ Yaml.decodeFileEither fp
|
||||
|
||||
addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
|
||||
|
||||
case pwdata of
|
||||
Left err -> $logDebugS "Auth" $ tshow err
|
||||
Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
|
||||
|
||||
case (authData, pwdata) of
|
||||
(Nothing, _) -> do
|
||||
notAuthenticated
|
||||
(Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
|
||||
| [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
|
||||
<- [ pwe | pwe@PWEntry{..} <- pwdata'
|
||||
, let User{..} = pwUser
|
||||
, userIdent == usr
|
||||
, userPlugin == apName
|
||||
]
|
||||
, verifyPassword pw pwHash
|
||||
-> lift $ do
|
||||
runDB . void $ insertUnique pwUser
|
||||
setCredsRedirect $ Creds apName userIdent []
|
||||
_ -> permissionDenied "Invalid auth"
|
||||
apDispatch _ _ = notFound
|
||||
|
||||
|
||||
ldapConfig :: UniWorX -> LDAPConfig
|
||||
ldapConfig _app@(appSettings -> settings) = LDAPConfig
|
||||
{ usernameFilter = \u -> principalName <> "=" <> u
|
||||
, identifierModifier
|
||||
, ldapUri = appLDAPURI settings
|
||||
, initDN = appLDAPDN settings
|
||||
, initPass = appLDAPPw settings
|
||||
, baseDN = appLDAPBaseName settings
|
||||
, ldapScope = LdapScopeSubtree
|
||||
}
|
||||
where
|
||||
principalName :: IsString a => a
|
||||
principalName = "userPrincipalName"
|
||||
identifierModifier _ entry = case lookup principalName $ leattrs entry of
|
||||
Just [n] -> Text.pack n
|
||||
_ -> error "Could not determine user principal name"
|
||||
|
||||
-- | Access function to determine if a user is logged in.
|
||||
isAuthenticated :: Handler AuthResult
|
||||
isAuthenticated = do
|
||||
muid <- maybeAuthId
|
||||
return $ case muid of
|
||||
Nothing -> Unauthorized "You must login to access this page"
|
||||
Just _ -> Authorized
|
||||
|
||||
|
||||
instance YesodAuthPersist UniWorX
|
||||
|
||||
-- Useful when writing code that is re-usable outside of the Handler context.
|
||||
|
||||
@ -33,7 +33,7 @@ instance PathPiece CreateButton where -- for displaying the button only, not
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
instance Button CreateButton where
|
||||
instance Button UniWorX CreateButton where
|
||||
label CreateMath = [whamlet|Ma<i>thema</i>tik|]
|
||||
label CreateInf = "Informatik"
|
||||
|
||||
|
||||
@ -406,7 +406,7 @@ postCorrectionR tid csh shn cid = do
|
||||
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
|
||||
|
||||
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
|
||||
<$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip "Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist") (Just $ submissionRatingPoints)
|
||||
<$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
|
||||
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
|
||||
<* submitButton
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
@ -263,7 +263,7 @@ courseDeleteHandler = undefined
|
||||
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
|
||||
courseEditHandler isGet course = do
|
||||
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
|
||||
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
|
||||
((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
|
||||
case result of
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Nothing
|
||||
@ -296,10 +296,11 @@ courseEditHandler isGet course = do
|
||||
addMessageI "danger" $ MsgCourseNewDupShort tid csh
|
||||
|
||||
(FormSuccess res@(
|
||||
CourseForm { cfCourseId = Just cid
|
||||
CourseForm { cfCourseId = Just cID
|
||||
, cfShort = csh
|
||||
, cfTerm = tid
|
||||
})) -> do -- edit existing course
|
||||
cid <- decrypt cID
|
||||
now <- liftIO getCurrentTime
|
||||
-- addMessage "debug" [shamlet| #{show res}|]
|
||||
runDB $ do
|
||||
@ -342,7 +343,7 @@ courseEditHandler isGet course = do
|
||||
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
||||
{ cfCourseId :: Maybe CryptoUUIDCourse
|
||||
, cfName :: CourseName
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
@ -357,24 +358,24 @@ data CourseForm = CourseForm
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
}
|
||||
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm cEntity = CourseForm
|
||||
{ cfCourseId = Just $ entityKey cEntity
|
||||
, cfName = courseName course
|
||||
, cfDesc = courseDescription course
|
||||
, cfLink = courseLinkExternal course
|
||||
, cfShort = courseShorthand course
|
||||
, cfTerm = courseTerm course
|
||||
, cfSchool = courseSchool course
|
||||
, cfCapacity = courseCapacity course
|
||||
, cfSecret = courseRegisterSecret course
|
||||
, cfMatFree = courseMaterialFree course
|
||||
, cfRegFrom = courseRegisterFrom course
|
||||
, cfRegTo = courseRegisterTo course
|
||||
, cfDeRegUntil = courseDeregisterUntil course
|
||||
}
|
||||
where
|
||||
course = entityVal cEntity
|
||||
courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
|
||||
courseToForm (Entity cid Course{..}) = do
|
||||
cfCourseId <- Just <$> encrypt cid
|
||||
return $ CourseForm
|
||||
{ cfCourseId
|
||||
, cfName = courseName
|
||||
, cfDesc = courseDescription
|
||||
, cfLink = courseLinkExternal
|
||||
, cfShort = courseShorthand
|
||||
, cfTerm = courseTerm
|
||||
, cfSchool = courseSchool
|
||||
, cfCapacity = courseCapacity
|
||||
, cfSecret = courseRegisterSecret
|
||||
, cfMatFree = courseMaterialFree
|
||||
, cfRegFrom = courseRegisterFrom
|
||||
, cfRegTo = courseRegisterTo
|
||||
, cfDeRegUntil = courseDeregisterUntil
|
||||
}
|
||||
|
||||
newCourseForm :: Maybe CourseForm -> Form CourseForm
|
||||
newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
@ -385,30 +386,32 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
-- UUID.encrypt cidKey cid
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
|
||||
<$> aopt hiddenField "KursId" (cfCourseId <$> template)
|
||||
<*> areq (ciField textField) (fsb "Name") (cfName <$> template)
|
||||
<*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template)
|
||||
<*> aopt urlField (fsb "Homepage") (cfLink <$> template)
|
||||
<*> areq (ciField textField) (fsb "Kürzel"
|
||||
<$> aopt hiddenField "courseId" (cfCourseId <$> template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgCourseDescription
|
||||
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
|
||||
<*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template)
|
||||
<*> areq (ciField textField) (fslI MsgCourseShorthand
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip "Muss innerhalb des Semesters eindeutig sein")
|
||||
& setTooltip MsgCourseShorthandUnique)
|
||||
(cfShort <$> template)
|
||||
<*> areq termActiveField (fsb "Semester") (cfTerm <$> template)
|
||||
<*> areq schoolField (fsb "Institut") (cfSchool <$> template)
|
||||
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
|
||||
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template)
|
||||
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
|
||||
& setTooltip "Für unbeschränkte Kapazität KEINEN Wert angeben.") (cfCapacity <$> template)
|
||||
& setTooltip MsgCourseCapacityTip
|
||||
) (cfCapacity <$> template)
|
||||
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
|
||||
& setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort")
|
||||
& setTooltip MsgCourseSecretTip)
|
||||
(cfSecret <$> template)
|
||||
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum, sonst KEINE Anmeldung"
|
||||
& setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!")
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
|
||||
& setTooltip MsgCourseRegisterFromTip)
|
||||
(cfRegFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum, sonst unbegr. Anmeldung"
|
||||
& setTooltip "Die Anmeldung darf ohne Begrenzung sein")
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
|
||||
& setTooltip MsgCourseRegisterToTip)
|
||||
(cfRegTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum, sonst unbegr. Abmeldung"
|
||||
& setTooltip "Die Abmeldung darf ohne Begrenzung sein")
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
|
||||
& setTooltip MsgCourseDeregisterUntilTip)
|
||||
(cfDeRegUntil <$> template)
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
|
||||
@ -104,29 +104,29 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (ciField textField) (fsb "Name") (sfName <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
||||
<$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip "Ohne Datum ist das Blatt komplett unsichtbar, z.B. weil es noch nicht fertig ist.")
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
<*> areq utcTimeField (fslI MsgSheetActiveFrom
|
||||
& setTooltip "Abgabe und Dateien zur Aufgabenstellung sind erst ab diesem Datum zugänglich")
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen")
|
||||
& setTooltip MsgSheetHintFromTip)
|
||||
(sfHintFrom <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen")
|
||||
& setTooltip MsgSheetSolutionFromTip)
|
||||
(sfSolutionFrom <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
|
||||
& setTooltip "Hinweise zur Korrektur, sichtbar nur für Korrektoren") (sfMarkingF <$> template)
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
|
||||
@ -11,7 +11,12 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Handler.Utils.Form where
|
||||
module Handler.Utils.Form
|
||||
( module Handler.Utils.Form
|
||||
, module Utils.Form
|
||||
) where
|
||||
|
||||
import Utils.Form
|
||||
|
||||
import Handler.Utils.Form.Types
|
||||
import Handler.Utils.Templates
|
||||
@ -34,8 +39,6 @@ import qualified Data.Text as T
|
||||
import Yesod.Form.Functions (parseHelper)
|
||||
import Yesod.Form.Bootstrap3
|
||||
|
||||
import qualified Text.Blaze.Internal as Blaze (null)
|
||||
|
||||
import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
||||
|
||||
import Handler.Utils.Zip
|
||||
@ -56,54 +59,10 @@ import Data.Scientific (Scientific)
|
||||
import Data.Ratio
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
------------------------------------------------
|
||||
|
||||
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
|
||||
identForm :: FormIdentifier -> Form a -> Form a
|
||||
identForm fid = identifyForm (T.pack $ show fid)
|
||||
|
||||
{- Hinweise zur Erinnerung:
|
||||
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
|
||||
- nur einmal pro makeForm reicht
|
||||
-}
|
||||
|
||||
-------------------
|
||||
-- Form Renderer --
|
||||
-------------------
|
||||
|
||||
-- | Use this type to pass information to the form template
|
||||
data FormLayout = FormStandard
|
||||
|
||||
renderAForm :: Monad m => FormLayout -> FormRender m a
|
||||
renderAForm formLayout aform fragment = do
|
||||
(res, (($ []) -> views)) <- aFormToForm aform
|
||||
let widget = $(widgetFile "widgets/form")
|
||||
return (res, widget)
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
----------------------------
|
||||
|
||||
data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
|
||||
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
|
||||
|
||||
class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
|
||||
label :: a -> Widget
|
||||
label = toWidget . toPathPiece
|
||||
|
||||
cssClass :: a -> ButtonCssClass
|
||||
cssClass _ = BCDefault
|
||||
|
||||
|
||||
|
||||
data BtnDelete = BtnDelete | BtnAbort
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
@ -111,27 +70,13 @@ instance PathPiece BtnDelete where -- for displaying the button only, not rea
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
instance Button BtnDelete where
|
||||
instance Button UniWorX BtnDelete where
|
||||
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
|
||||
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
|
||||
|
||||
cssClass BtnDelete = BCDanger
|
||||
cssClass BtnAbort = BCDefault
|
||||
|
||||
|
||||
data SubmitButton = BtnSubmit
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
instance PathPiece SubmitButton where
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
instance Button SubmitButton where
|
||||
label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
|
||||
|
||||
cssClass BtnSubmit = BCPrimary
|
||||
|
||||
|
||||
data RegisterButton = BtnRegister | BtnDeregister
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
@ -139,7 +84,7 @@ instance PathPiece RegisterButton where
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
instance Button RegisterButton where
|
||||
instance Button UniWorX RegisterButton where
|
||||
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
|
||||
label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
|
||||
|
||||
@ -153,7 +98,7 @@ instance PathPiece AdminHijackUserButton where
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
instance Button AdminHijackUserButton where
|
||||
instance Button UniWorX AdminHijackUserButton where
|
||||
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
|
||||
|
||||
cssClass BtnHijack = BCDefault
|
||||
@ -166,7 +111,7 @@ instance Button AdminHijackUserButton where
|
||||
-- instance PathPiece LinkButton where
|
||||
-- LinkButton route = ???
|
||||
|
||||
linkButton :: Widget -> ButtonCssClass -> Route UniWorX -> Widget
|
||||
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget
|
||||
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
|
||||
-- [whamlet|
|
||||
-- <form method=post action=@{url}>
|
||||
@ -178,30 +123,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
|
||||
|
||||
buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
|
||||
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
||||
where
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
fieldView fid name attrs _val _ =
|
||||
[whamlet|
|
||||
<button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
|
||||
|]
|
||||
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse [str] _
|
||||
| str == toPathPiece btn = return $ Right $ Just btn
|
||||
| otherwise = return $ Left "Wrong button value"
|
||||
fieldParse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
|
||||
combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
|
||||
combinedButtonField btns = traverse b2f btns
|
||||
where
|
||||
b2f b = aopt (buttonField b) "" Nothing
|
||||
|
||||
submitButton :: AForm Handler ()
|
||||
submitButton = void $ combinedButtonField [BtnSubmit]
|
||||
|
||||
{-
|
||||
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
|
||||
@ -236,7 +157,7 @@ combinedButtonField btns inner csrf = do
|
||||
-}
|
||||
|
||||
-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
|
||||
buttonForm :: (Button a) => Form a
|
||||
buttonForm :: (Button UniWorX a) => Form a
|
||||
buttonForm csrf = do
|
||||
buttonIdent <- newFormIdent
|
||||
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
|
||||
@ -444,88 +365,6 @@ fsm = bfs -- TODO: get rid of Bootstrap
|
||||
fsb :: Text -> FieldSettings site -- DEPRECATED
|
||||
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
|
||||
|
||||
fsl :: Text -> FieldSettings UniWorX
|
||||
fsl lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslI :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
|
||||
fslI lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslp :: Text -> Text -> FieldSettings UniWorX
|
||||
fslp lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
|
||||
fslpI lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,valu)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.append valu $ cons ' ' v):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
|
||||
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
|
||||
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,T.intercalate " " valus)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.intercalate " " (v:valus)):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
|
||||
addClass :: Text -> FieldSettings site -> FieldSettings site
|
||||
addClass = addAttr "class"
|
||||
|
||||
addClasses :: [Text] -> FieldSettings site -> FieldSettings site
|
||||
addClasses = addAttrs "class"
|
||||
|
||||
addName :: Text -> FieldSettings site -> FieldSettings site
|
||||
addName nm fs = fs { fsName = Just nm }
|
||||
|
||||
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
|
||||
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
|
||||
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
|
||||
|
||||
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
|
||||
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
setTooltip :: String -> FieldSettings site -> FieldSettings site
|
||||
setTooltip tt fs
|
||||
| null tt = fs { fsTooltip = Nothing }
|
||||
| otherwise = fs { fsTooltip = Just $ fromString tt
|
||||
, fsAttrs=("data-tooltip",fromString tt):(fsAttrs fs) }
|
||||
|
||||
optionsPersistCryptoId :: forall site backend a msg.
|
||||
( YesodPersist site
|
||||
, PersistQueryRead backend
|
||||
|
||||
@ -3,6 +3,8 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- | Settings are centralized, as much as possible, into this file. This
|
||||
-- includes database connection settings, static file locations, etc.
|
||||
-- In addition, you can configure a number of different aspects of Yesod
|
||||
@ -14,6 +16,7 @@ import ClassyPrelude.Yesod
|
||||
import qualified Control.Exception as Exception
|
||||
import Data.Aeson (Result (..), fromJSON, withObject,
|
||||
(.!=), (.:?))
|
||||
import Data.Aeson.TH
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Data.Yaml (decodeEither')
|
||||
import Database.Persist.Postgresql (PostgresConf)
|
||||
@ -24,6 +27,10 @@ import Yesod.Default.Util (WidgetFileSettings,
|
||||
widgetFileNoReload,
|
||||
widgetFileReload)
|
||||
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Model
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
@ -34,6 +41,7 @@ data AppSettings = AppSettings
|
||||
-- ^ Directory from which to serve static files.
|
||||
, appDatabaseConf :: PostgresConf
|
||||
-- ^ Configuration settings for accessing the database.
|
||||
, appLdapConf :: Maybe LdapConf
|
||||
, appRoot :: Maybe Text
|
||||
-- ^ Base for all generated URLs. If @Nothing@, determined
|
||||
-- from the request headers.
|
||||
@ -45,11 +53,6 @@ data AppSettings = AppSettings
|
||||
-- ^ Get the IP address from the header when logging. Useful when sitting
|
||||
-- behind a reverse proxy.
|
||||
|
||||
, appLDAPURI :: String
|
||||
, appLDAPDN :: String
|
||||
, appLDAPPw :: String
|
||||
, appLDAPBaseName :: Maybe String
|
||||
|
||||
, appDetailedRequestLogging :: Bool
|
||||
-- ^ Use detailed request logging system
|
||||
, appShouldLogAll :: Bool
|
||||
@ -83,6 +86,35 @@ data AppSettings = AppSettings
|
||||
|
||||
}
|
||||
|
||||
data LdapConf = LdapConf
|
||||
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
|
||||
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
|
||||
, ldapBase :: Ldap.Dn
|
||||
, ldapScope :: Ldap.Scope
|
||||
, ldapTimeout :: Int32
|
||||
}
|
||||
|
||||
deriveFromJSON defaultOptions ''Ldap.Scope
|
||||
|
||||
instance FromJSON LdapConf where
|
||||
parseJSON = withObject "LdapConf" $ \o -> do
|
||||
ldapTls <- o .:? "tls"
|
||||
tlsSettings <- case ldapTls :: Maybe String of
|
||||
Just spec
|
||||
| spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
|
||||
| spec == "default" -> return $ Just Ldap.defaultTlsSettings
|
||||
| null spec -> return Nothing
|
||||
Nothing -> return Nothing
|
||||
_otherwise -> fail "Could not parse LDAP TLSSettings"
|
||||
ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
|
||||
ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
|
||||
ldapDn <- Ldap.Dn <$> o .: "user"
|
||||
ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
|
||||
ldapBase <- Ldap.Dn <$> o .: "baseDN"
|
||||
ldapScope <- o .: "scope"
|
||||
ldapTimeout <- o .: "timeout"
|
||||
return LdapConf{..}
|
||||
|
||||
instance FromJSON AppSettings where
|
||||
parseJSON = withObject "AppSettings" $ \o -> do
|
||||
let defaultDev =
|
||||
@ -93,14 +125,15 @@ instance FromJSON AppSettings where
|
||||
#endif
|
||||
appStaticDir <- o .: "static-dir"
|
||||
appDatabaseConf <- o .: "database"
|
||||
let nonEmptyHost LdapConf{..} = case ldapHost of
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
|
||||
appRoot <- o .:? "approot"
|
||||
appHost <- fromString <$> o .: "host"
|
||||
appPort <- o .: "port"
|
||||
appIpFromHeader <- o .: "ip-from-header"
|
||||
|
||||
( appLDAPURI, appLDAPDN, appLDAPPw, appLDAPBaseName )
|
||||
<- (=<< o .: "ldap") . withObject "LDAP" $ \obj -> (,,,) <$> obj .: "uri" <*> obj .: "dn" <*> obj .: "password" <*> obj .:? "basename"
|
||||
|
||||
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
|
||||
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
|
||||
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
|
||||
|
||||
190
src/Utils/Form.hs
Normal file
190
src/Utils/Form.hs
Normal file
@ -0,0 +1,190 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, TemplateHaskell
|
||||
, ViewPatterns
|
||||
, OverloadedStrings
|
||||
, QuasiQuotes
|
||||
, TemplateHaskell
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, NamedFieldPuns
|
||||
, ScopedTypeVariables
|
||||
#-}
|
||||
|
||||
module Utils.Form where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Settings
|
||||
|
||||
import qualified Text.Blaze.Internal as Blaze (null)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Char as Char
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
-------------------
|
||||
-- Form Renderer --
|
||||
-------------------
|
||||
|
||||
-- | Use this type to pass information to the form template
|
||||
data FormLayout = FormStandard
|
||||
|
||||
renderAForm :: Monad m => FormLayout -> FormRender m a
|
||||
renderAForm formLayout aform fragment = do
|
||||
(res, (($ []) -> views)) <- aFormToForm aform
|
||||
let widget = $(widgetFile "widgets/form")
|
||||
return (res, widget)
|
||||
|
||||
--------------------
|
||||
-- Field Settings --
|
||||
--------------------
|
||||
|
||||
fsl :: Text -> FieldSettings site
|
||||
fsl lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslI :: RenderMessage site msg => msg -> FieldSettings site
|
||||
fslI lbl =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = []
|
||||
}
|
||||
|
||||
fslp :: Text -> Text -> FieldSettings site
|
||||
fslp lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
|
||||
fslpI lbl placeholder =
|
||||
FieldSettings { fsLabel = (SomeMessage lbl)
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs = [("placeholder", placeholder)]
|
||||
}
|
||||
|
||||
addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,valu)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.append valu $ cons ' ' v):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
|
||||
addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
|
||||
addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
|
||||
where
|
||||
newAttrs :: [(Text,Text)] -> [(Text,Text)]
|
||||
newAttrs [] = [(attr,T.intercalate " " valus)]
|
||||
newAttrs (p@(a,v):t)
|
||||
| attr==a = (a,T.intercalate " " (v:valus)):t
|
||||
| otherwise = p:(newAttrs t)
|
||||
|
||||
addClass :: Text -> FieldSettings site -> FieldSettings site
|
||||
addClass = addAttr "class"
|
||||
|
||||
addClasses :: [Text] -> FieldSettings site -> FieldSettings site
|
||||
addClasses = addAttrs "class"
|
||||
|
||||
addName :: Text -> FieldSettings site -> FieldSettings site
|
||||
addName nm fs = fs { fsName = Just nm }
|
||||
|
||||
addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
|
||||
addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
|
||||
setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
|
||||
setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
|
||||
|
||||
setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
|
||||
setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
|
||||
|
||||
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
|
||||
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
------------------------------------------------
|
||||
|
||||
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
instance PathPiece FormIdentifier where
|
||||
fromPathPiece = readFromPathPiece
|
||||
toPathPiece = showToPathPiece
|
||||
|
||||
|
||||
identForm :: (Monad m, PathPiece ident)
|
||||
=> ident -- ^ Form identification
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
identForm = identifyForm . toPathPiece
|
||||
|
||||
{- Hinweise zur Erinnerung:
|
||||
- identForm primär, wenn es mehr als ein Formular pro Handler gibt
|
||||
- nur einmal pro makeForm reicht
|
||||
-}
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
----------------------------
|
||||
|
||||
data family ButtonCssClass site :: *
|
||||
|
||||
bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
|
||||
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
|
||||
|
||||
class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
|
||||
label :: a -> WidgetT site IO ()
|
||||
label = toWidget . toPathPiece
|
||||
|
||||
cssClass :: a -> ButtonCssClass site
|
||||
|
||||
data SubmitButton = BtnSubmit
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
instance PathPiece SubmitButton where
|
||||
toPathPiece = showToPathPiece
|
||||
fromPathPiece = readFromPathPiece
|
||||
|
||||
buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
|
||||
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
||||
where
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
fieldView fid name attrs _val _ = let
|
||||
cssClass' :: ButtonCssClass site
|
||||
cssClass' = cssClass btn
|
||||
in [whamlet|
|
||||
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
|
||||
|]
|
||||
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse [str] _
|
||||
| str == toPathPiece btn = return $ Right $ Just btn
|
||||
| otherwise = return $ Left "Wrong button value"
|
||||
fieldParse _ _ = return $ Left "Multiple button values"
|
||||
|
||||
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
|
||||
combinedButtonField btns = traverse b2f btns
|
||||
where
|
||||
b2f b = aopt (buttonField b) "" Nothing
|
||||
|
||||
submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
|
||||
submitButton = void $ combinedButtonField [BtnSubmit]
|
||||
16
stack.yaml
16
stack.yaml
@ -13,27 +13,17 @@ packages:
|
||||
git: https://github.com/pngwjpgh/zip-stream.git
|
||||
commit: 9272bbed000928d500febad1cdc98d1da29d399e
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/yesod-auth-ldap.git
|
||||
commit: 69e08ef687ab96df3352ff4267562135453c6f02
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/mlitchard/authenticate-ldap.git
|
||||
commit: cc2770024766a8fa29d3086688df60aaf65fb954
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/pngwjpgh/encoding.git
|
||||
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
|
||||
extra-dep: true
|
||||
- location:
|
||||
git: https://github.com/pngwjpgh/system-locale.git
|
||||
commit: d803ce3607ac6813ac1a065acb423220f57dab3c
|
||||
extra-dep: true
|
||||
|
||||
extra-deps:
|
||||
- colonnade-1.2.0
|
||||
- yesod-colonnade-1.2.0
|
||||
|
||||
- ldap-client-0.2.0
|
||||
|
||||
- conduit-resumablesink-0.2
|
||||
|
||||
- uuid-crypto-1.4.0.0
|
||||
@ -42,6 +32,6 @@ extra-deps:
|
||||
- cryptoids-types-0.0.0
|
||||
- cryptoids-class-0.0.0
|
||||
|
||||
- LDAP-0.6.11
|
||||
- system-locale-0.3.0.0
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
9
templates/login.hamlet
Normal file
9
templates/login.hamlet
Normal file
@ -0,0 +1,9 @@
|
||||
$forall AuthPlugin{..} <- plugins
|
||||
$if apName == "LDAP"
|
||||
<section>
|
||||
<h2>_{MsgLDAPLoginTitle}
|
||||
^{apLogin toParent}
|
||||
$elseif apName == "dummy"
|
||||
<section>
|
||||
<h2>_{MsgDummyLoginTitle}
|
||||
^{apLogin toParent}
|
||||
2
templates/widgets/campus-login-form.hamlet
Normal file
2
templates/widgets/campus-login-form.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype}>
|
||||
^{login}
|
||||
11
templates/widgets/campus-login.hamlet
Normal file
11
templates/widgets/campus-login.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
^{csrf}
|
||||
<table>
|
||||
<tr>
|
||||
<th>_{MsgCampusIdent}
|
||||
<td>^{fvInput identView}
|
||||
<tr>
|
||||
<th>_{MsgCampusPassword}
|
||||
<td>^{fvInput passwordView}
|
||||
<tr>
|
||||
<td colspan="2" style="text-align: right">
|
||||
<button type="submit">_{MsgCampusSubmit}
|
||||
@ -8,3 +8,7 @@ $case formLayout
|
||||
<label .form-group__label for=#{fvId view}>#{fvLabel view}
|
||||
<div .form-group__input>
|
||||
^{fvInput view}
|
||||
$maybe tooltip <- fvTooltip view
|
||||
<div .js-tooltip>
|
||||
<div .tooltip__handle>?
|
||||
<div .tooltip__content>^{tooltip}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user