fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 'live'

Browse Source 
Custom LDAP

Closes #94, #17, #109, #81, and #132

See merge request !65
This commit is contained in:
Gregor Kleen 2018-08-02 17:43:23 +02:00
commit 8b87ea3d4f
35 changed files with 885 additions and 435 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ChangeLog.md
View File

@ -1,3 +1,7 @@
* Version 01.08.2018
Verbesserter Campus-Login
* Version 31.07.2018 * Version 31.07.2018
Viele Verbesserung zur Anzeige von Korrekturen Viele Verbesserung zur Anzeige von Korrekturen

13
config/keter_testworx.yml
View File

@ -20,14 +20,19 @@ stanzas:
ssl: true ssl: true
forward-env: forward-env:
- LDAPURI - LDAPHOST
- LDAPDN - LDAPTLS
- LDAPPW - LDAPPORT
- LDAPBN - LDAPUSER
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPTIMEOUT
- DUMMY_LOGIN - DUMMY_LOGIN
- DETAILED_LOGGING - DETAILED_LOGGING
- LOG_ALL - LOG_ALL
- PWFILE - PWFILE
- CRYPTOID_KEYFILE
# Use the following to automatically copy your bundle upon creation via `yesod # 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 # keter`. Uses `scp` internally, so you can set it to a remote destination

12
config/keter_uni2work.yml
View File

@ -20,10 +20,14 @@ stanzas:
ssl: true ssl: true
forward-env: forward-env:
- LDAPURI - LDAPHOST
- LDAPDN - LDAPTLS
- LDAPPW - LDAPPORT
- LDAPBN - LDAPUSER
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPTIMEOUT
- DETAILED_LOGGING - DETAILED_LOGGING
- LOG_ALL - LOG_ALL
- PWFILE - PWFILE

12
config/settings.yml
View File

@ -35,10 +35,14 @@ database:
poolsize: "_env:PGPOOLSIZE:10" poolsize: "_env:PGPOOLSIZE:10"
ldap: ldap:
uri: "_env:LDAPURI:ldap://localhost:389" host: "_env:LDAPHOST:"
dn: "_env:LDAPDN:uniworx" tls: "_env:LDAPTLS:"
password: "_env:LDAPPW:" port: "_env:LDAPPORT:389"
basename: "_env:LDAPBN:" user: "_env:LDAPUSER:"
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5"
default-favourites: 12 default-favourites: 12
default-theme: Default default-theme: Default

5
messages/campus/de.msg Normal file
View 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

44
messages/de.msg → messages/uniworx/de.msg
View File

@ -31,6 +31,8 @@ LectureStart: Beginn Vorlesungen
Course: Kurs Course: Kurs
CourseShort: Kürzel 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. CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
CourseRegisterOk: Sie wurden angemeldet CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
@ -47,6 +49,22 @@ TermCourseListTitle tid@TermId: Kurse #{display tid}
CourseNewHeading: Neuen Kurs anlegen CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
CourseEditTitle: Kurs editieren/anlegen 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 Sheet: Blatt
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
@ -67,11 +85,20 @@ SheetHintFrom: Hinweis ab
SheetSolution: Lösung SheetSolution: Lösung
SheetSolutionFrom: Lösung ab SheetSolutionFrom: Lösung ab
SheetMarking: Hinweise für Korrektoren SheetMarking: Hinweise für Korrektoren
SheetType: Bewertung 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 SheetVisibleFrom: Sichtbar ab
SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
SheetActiveFrom: Aktiv ab SheetActiveFrom: Aktiv ab
SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
SheetActiveTo: Abgabefrist 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 SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
@ -142,7 +169,8 @@ CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern die
Users: Benutzer Users: Benutzer
HomeHeading: Aktuelle Termine HomeHeading: Aktuelle Termine
LoginHeading: Login bitte mit "@campus.lmu.de" angeben LoginHeading: Authentifizierung
LoginTitle: Authentifizierung
ProfileHeading: Benutzerprofil und Einstellungen ProfileHeading: Benutzerprofil und Einstellungen
ProfileDataHeading: Gespeicherte Benutzerdaten ProfileDataHeading: Gespeicherte Benutzerdaten
ImpressumHeading: Impressum ImpressumHeading: Impressum
@ -194,10 +222,11 @@ RatingTime: Korrigiert
RatingComment: Kommentar RatingComment: Kommentar
SubmissionUsers: Studenten SubmissionUsers: Studenten
Rating: Korrektur Rating: Korrektur
RatingPoints: Punkte RatingPoints: Punkte
RatingPercent: Erreicht
RatingFiles: Korrigierte Dateien RatingFiles: Korrigierte Dateien
PointsNotPositive: Punktzahl darf nicht negativ sein PointsNotPositive: Punktzahl darf nicht negativ sein
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
FileTitle: Dateiname FileTitle: Dateiname
FileModified: Letzte Änderung FileModified: Letzte Änderung
@ -208,10 +237,6 @@ RatingUpdated: Korrektur gespeichert
RatingDeleted: Korrektur zurückgesetzt RatingDeleted: Korrektur zurückgesetzt
RatingFilesUpdated: Korrigierte Dateien überschrieben RatingFilesUpdated: Korrigierte Dateien überschrieben
CourseMembers: Teilnehmer
CourseMembersCount num@Int64: #{display num}
CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
NoTableContent: Kein Tabelleninhalt NoTableContent: Kein Tabelleninhalt
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
@ -232,3 +257,6 @@ LastEdit: Letzte Änderung
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
LDAPLoginTitle: Campus-Login
DummyLoginTitle: Development-Login

4
package.yaml
View File

@ -74,8 +74,6 @@ dependencies:
- generic-deriving - generic-deriving
- blaze-html - blaze-html
- conduit-resumablesink >=0.2 - conduit-resumablesink >=0.2
- yesod-auth-ldap
- LDAP
- parsec - parsec
- uuid - uuid
- exceptions - exceptions
@ -88,6 +86,8 @@ dependencies:
- th-lift-instances - th-lift-instances
- gitrev - gitrev
- Glob - Glob
- ldap-client
- connection
# The library contains all of our application code. The executable # The library contains all of our application code. The executable
# defined below is just a thin wrapper. # defined below is just a thin wrapper.

2
routes
View File

@ -61,7 +61,7 @@
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector / SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR GET POST /delete SDelR GET POST
/subs SSubsR GET POST /subs SSubsR GET POST -- for lecturer only
/subs/new SubmissionNewR GET POST !timeANDregistered /subs/new SubmissionNewR GET POST !timeANDregistered
/subs/own SubmissionOwnR GET !free -- just redirect /subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:

164
src/Auth/LDAP.hs Normal file
View File

@ -0,0 +1,164 @@
{-# LANGUAGE RecordWildCards
, OverloadedStrings
, TemplateHaskell
, TypeFamilies
, FlexibleContexts
, FlexibleInstances
, NoImplicitPrelude
, ScopedTypeVariables
#-}
module Auth.LDAP
( campusLogin
, CampusUserException(..)
, campusUser
, CampusMessage(..)
, Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
) where
import Import.NoFoundation
import Control.Lens
import Network.Connection
import qualified Control.Monad.Catch as Exc
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
| CampusUserHostNotResolved String
| CampusUserLineTooLong
| CampusUserHostCannotConnect String [IOException]
| 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 . (`catches` errHandlers) $ 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
where
errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
, Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
]
-- 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
View 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

1
src/CryptoID.hs
View File

@ -55,6 +55,7 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
decCryptoIDs [ ''SubmissionId decCryptoIDs [ ''SubmissionId
, ''FileId , ''FileId
, ''UserId , ''UserId
, ''CourseId
] ]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

244
src/Foundation.hs
View File

@ -23,13 +23,11 @@ import Text.Jasmine (minifym)
-- Used only when in "auth-dummy-login" setting is enabled. -- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Message import Yesod.Auth.Message
import Yesod.Auth.Dummy import Yesod.Auth.Dummy
import Yesod.Auth.LDAP import Auth.LDAP
import Auth.PWFile
import qualified Network.Wai as W (requestMethod, pathInfo) import qualified Network.Wai as W (requestMethod, pathInfo)
import LDAP.Data (LDAPScope(..))
import LDAP.Search (LDAPEntry(..))
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Core.Unsafe as Unsafe
@ -43,8 +41,6 @@ import Data.ByteArray (convert)
import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash (Digest, SHAKE256)
import Crypto.Hash.Conduit (sinkHash) import Crypto.Hash.Conduit (sinkHash)
import Yesod.Auth.Util.PasswordStore
import qualified Data.ByteString.Base64.URL as Base64 (encode) import qualified Data.ByteString.Base64.URL as Base64 (encode)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -74,6 +70,7 @@ import Control.Monad.Trans.Reader (runReader)
import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch (handleAll) import Control.Monad.Catch (handleAll)
import qualified Control.Monad.Catch as C
import System.FilePath import System.FilePath
@ -81,6 +78,7 @@ import Handler.Utils.Templates
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Control.Lens import Control.Lens
import Utils import Utils
import Utils.Form
import Utils.Lens import Utils.Lens
import Data.Aeson import Data.Aeson
@ -164,7 +162,8 @@ data MenuTypes -- Semantische Rolle:
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten
-- Messages -- 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 -- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages. -- achieve customized and internationalized form validation messages.
@ -200,6 +199,16 @@ instance RenderMessage UniWorX SheetFileType where
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) 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' :: [Lang] -> TimeLocale
getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
@ -504,13 +513,6 @@ instance Yesod UniWorX where
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
redirectWith movedPermanently301 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 defaultLayout widget = do
master <- getYesod master <- getYesod
mmsgs <- getMessages mmsgs <- getMessages
@ -1067,136 +1069,128 @@ instance YesodAuth UniWorX where
redirectToReferer _ = True redirectToReferer _ = True
loginHandler = do loginHandler = do
tp <- getRouteToParent toParent <- getRouteToParent
lift . authLayout $ do lift . defaultLayout $ do
master <- getYesod plugins <- getsYesod authPlugins
let authPlugins' = authPlugins master $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
$logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName authPlugins')
forM_ authPlugins' $ flip apLogin tp
authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do setTitleI MsgLoginTitle
let (userPlugin, userIdent) $(widgetFile "login")
| isDummy
, [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
= (dummyPlugin, dummyIdent)
| otherwise
= (credsPlugin, credsIdent)
isDummy = credsPlugin == "dummy"
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
authenticate Creds{..} = runDB $ do
let let
userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra (userPlugin, userIdent)
userEmail' = lookup "mail" credsExtra | isDummy
userDisplayName' = lookup "displayName" credsExtra , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
= (dummyPlugin, dummyIdent)
| otherwise
= (credsPlugin, credsIdent)
isDummy = credsPlugin == "dummy"
isPWFile = credsPlugin == "PWFile"
uAuth = UniqueAuthentication userPlugin userIdent
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail' excHandlers
userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' | isDummy || isPWFile
= [ C.Handler $ \err -> do
addMessage "error" (toHtml $ tshow (err :: CampusUserException))
$logErrorS "LDAP" $ tshow err
acceptExisting
]
| otherwise
= [ C.Handler $ \case
CampusUserNoResult -> do
$logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
return . UserError $ IdentifierNotFound credsIdent
CampusUserAmbiguous -> do
$logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
return . UserError $ IdentifierNotFound credsIdent
err -> do
$logErrorS "LDAP" $ tshow err
return $ ServerError "LDAP lookup failed"
]
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
$logDebugS "auth" $ tshow Creds{..}
AppSettings{..} <- getsYesod appSettings AppSettings{..} <- getsYesod appSettings
let flip catches excHandlers $ case appLdapConf of
userMaxFavourites = appDefaultMaxFavourites Just ldapConf -> fmap (either id id) . runExceptT $ do
userTheme = appDefaultTheme ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
userDateTimeFormat = appDefaultDateTimeFormat $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
userDateFormat = appDefaultDateFormat
userTimeFormat = appDefaultTimeFormat let
newUser = User{..} userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer userEmail' = lookup (Attr "mail") ldapData
, UserDisplayName =. userDisplayName userDisplayName' = lookup (Attr "displayName") ldapData
, UserEmail =. userEmail
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 let
userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] 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 forM_ fs $ \StudyFeatures{..} -> do
lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
lift $ insertMany_ fs
return $ Authenticated userId
Nothing -> acceptExisting
lift $ insertMany_ fs
return $ Authenticated userId
where where
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
-- You can add other plugins like Google Email, email or OAuth here authPlugins (appSettings -> AppSettings{..}) = catMaybes
authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins [ campusLogin <$> appLdapConf
-- Enable authDummy login if enabled. , maintenanceLogin <$> appAuthPWFile
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] , authDummy <$ guard appAuthDummyLogin
++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app] ]
authHttpManager = getHttpManager 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 instance YesodAuthPersist UniWorX
-- Useful when writing code that is re-usable outside of the Handler context. -- Useful when writing code that is re-usable outside of the Handler context.

2
src/Handler/Admin.hs
View File

@ -33,7 +33,7 @@ instance PathPiece CreateButton where -- for displaying the button only, not
toPathPiece = showToPathPiece toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece fromPathPiece = readFromPathPiece
instance Button CreateButton where instance Button UniWorX CreateButton where
label CreateMath = [whamlet|Ma<i>thema</i>tik|] label CreateMath = [whamlet|Ma<i>thema</i>tik|]
label CreateInf = "Informatik" label CreateInf = "Informatik"

2
src/Handler/Corrections.hs
View File

@ -406,7 +406,7 @@ postCorrectionR tid csh shn cid = do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) ((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)) <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
<* submitButton <* submitButton

108
src/Handler/Course.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE MultiWayIf #-}
@ -77,6 +77,11 @@ course2Participants course = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
course2School :: CourseTableExpr -> E.SqlExpr _ -- this is a bad hack, change to proper innerjoin
course2School course = E.subList_select . E.from $ \school -> do
E.where_ $ course E.^. CourseSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid course = E.exists . E.from $ \courseParticipant -> do course2Registered muid course = E.exists . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
@ -263,7 +268,7 @@ courseDeleteHandler = undefined
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do courseEditHandler isGet course = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! 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 case result of
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Nothing CourseForm { cfCourseId = Nothing
@ -296,22 +301,19 @@ courseEditHandler isGet course = do
addMessageI "danger" $ MsgCourseNewDupShort tid csh addMessageI "danger" $ MsgCourseNewDupShort tid csh
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Just cid CourseForm { cfCourseId = Just cID
, cfShort = csh , cfShort = csh
, cfTerm = tid , cfTerm = tid
})) -> do -- edit existing course })) -> do -- edit existing course
cid <- decrypt cID
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|] -- addMessage "debug" [shamlet| #{show res}|]
runDB $ do success <- runDB $ do
old <- get cid old <- get cid
case old of case old of
Nothing -> addMessageI "error" $ MsgInvalidInput Nothing -> addMessageI "error" MsgInvalidInput $> False
(Just oldCourse) -> do (Just oldCourse) -> do
-- existing <- getBy $ CourseTermShort tid csh updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have
-- if ((entityKey <$> existing) /= Just cid)
-- then addMessageI "danger" $ MsgCourseEditDupShort tid csh
-- else do
_updOkay <- replace cid ( -- TODO replaceUnique requires Eq?!
Course { courseName = cfName res Course { courseName = cfName res
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
@ -326,12 +328,13 @@ courseEditHandler isGet course = do
, courseDeregisterUntil = cfDeRegUntil res , courseDeregisterUntil = cfDeRegUntil res
} }
) )
insert_ $ CourseEdit aid now cid case updOkay of
-- if (isNothing updOkay) (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False
-- then do Nothing -> do
addMessageI "success" $ MsgCourseEditOk tid csh insert_ $ CourseEdit aid now cid
-- redirect $ TermCourseListR tid addMessageI "success" $ MsgCourseEditOk tid csh
-- else addMessageI "danger" $ MsgCourseEditDupShort tid csh return True
when success $ redirect $ CourseR tid csh CShowR
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) -> return () (FormMissing) -> return ()
@ -342,7 +345,7 @@ courseEditHandler isGet course = do
data CourseForm = CourseForm data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse { cfCourseId :: Maybe CryptoUUIDCourse
, cfName :: CourseName , cfName :: CourseName
, cfDesc :: Maybe Html , cfDesc :: Maybe Html
, cfLink :: Maybe Text , cfLink :: Maybe Text
@ -357,24 +360,24 @@ data CourseForm = CourseForm
, cfDeRegUntil :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime
} }
courseToForm :: Entity Course -> CourseForm courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
courseToForm cEntity = CourseForm courseToForm (Entity cid Course{..}) = do
{ cfCourseId = Just $ entityKey cEntity cfCourseId <- Just <$> encrypt cid
, cfName = courseName course return $ CourseForm
, cfDesc = courseDescription course { cfCourseId
, cfLink = courseLinkExternal course , cfName = courseName
, cfShort = courseShorthand course , cfDesc = courseDescription
, cfTerm = courseTerm course , cfLink = courseLinkExternal
, cfSchool = courseSchool course , cfShort = courseShorthand
, cfCapacity = courseCapacity course , cfTerm = courseTerm
, cfSecret = courseRegisterSecret course , cfSchool = courseSchool
, cfMatFree = courseMaterialFree course , cfCapacity = courseCapacity
, cfRegFrom = courseRegisterFrom course , cfSecret = courseRegisterSecret
, cfRegTo = courseRegisterTo course , cfMatFree = courseMaterialFree
, cfDeRegUntil = courseDeregisterUntil course , cfRegFrom = courseRegisterFrom
} , cfRegTo = courseRegisterTo
where , cfDeRegUntil = courseDeregisterUntil
course = entityVal cEntity }
newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm :: Maybe CourseForm -> Form CourseForm
newCourseForm template = identForm FIDcourse $ \html -> do newCourseForm template = identForm FIDcourse $ \html -> do
@ -385,29 +388,32 @@ newCourseForm template = identForm FIDcourse $ \html -> do
-- UUID.encrypt cidKey cid -- UUID.encrypt cidKey cid
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
<$> aopt hiddenField "KursId" (cfCourseId <$> template) <$> aopt hiddenField "courseId" (cfCourseId <$> template)
<*> areq (ciField textField) (fsb "Name") (cfName <$> template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
<*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) <*> aopt htmlField (fslI MsgCourseDescription
<*> aopt urlField (fsb "Homepage") (cfLink <$> template) & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
<*> areq (ciField textField) (fsb "Kürzel" <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template)
<*> areq (ciField textField) (fslI MsgCourseShorthand
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip "Muss innerhalb des Semesters eindeutig sein") & setTooltip MsgCourseShorthandUnique)
(cfShort <$> template) (cfShort <$> template)
<*> areq termActiveField (fsb "Semester") (cfTerm <$> template) <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq schoolField (fsb "Institut") (cfSchool <$> template) <*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip
) (cfCapacity <$> template)
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
& setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort") & setTooltip MsgCourseSecretTip)
(cfSecret <$> template) (cfSecret <$> template)
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) <*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum, sonst KEINE Anmeldung" <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
& setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!") & setTooltip MsgCourseRegisterFromTip)
(cfRegFrom <$> template) (cfRegFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum, sonst unbegr. Anmeldung" <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
& setTooltip "Die Anmeldung darf ohne Begrenzung sein") & setTooltip MsgCourseRegisterToTip)
(cfRegTo <$> template) (cfRegTo <$> template)
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum, sonst unbegr. Abmeldung" <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
& setTooltip "Die Abmeldung darf ohne Begrenzung sein") & setTooltip MsgCourseDeregisterUntilTip)
(cfDeRegUntil <$> template) (cfDeRegUntil <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of

2
src/Handler/Home.hs
View File

@ -102,6 +102,7 @@ homeAnonymous = do
, dbtIdent = "upcomingdeadlines" :: Text , dbtIdent = "upcomingdeadlines" :: Text
} }
let features = $(widgetFile "featureList") let features = $(widgetFile "featureList")
addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout $ do defaultLayout $ do
$(widgetFile "dsgvDisclaimer") $(widgetFile "dsgvDisclaimer")
$(widgetFile "home") $(widgetFile "home")
@ -192,6 +193,7 @@ homeUser uid = do
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtIdent = "upcomingdeadlines" :: Text , dbtIdent = "upcomingdeadlines" :: Text
} }
addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
defaultLayout $ do defaultLayout $ do
-- setTitle "Willkommen zum Uni2work Test!" -- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser") $(widgetFile "homeUser")

64
src/Handler/Sheet.hs
View File

@ -104,29 +104,29 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
mr <- getMsgRenderer mr <- getMsgRenderer
ctime <- liftIO $ getCurrentTime ctime <- liftIO $ getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq (ciField textField) (fsb "Name") (sfName <$> template) <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom <*> 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)) ((sfVisibleFrom <$> template) <|> pure (Just ctime))
<*> areq utcTimeField (fslI MsgSheetActiveFrom <*> areq utcTimeField (fslI MsgSheetActiveFrom
& setTooltip "Abgabe und Dateien zur Aufgabenstellung sind erst ab diesem Datum zugänglich") & setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template) (sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> 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" <*> 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) (sfHintFrom <$> template)
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren" <*> 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) (sfSolutionFrom <$> template)
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip "Hinweise zur Korrektur, sichtbar nur für Korrektoren") (sfMarkingF <$> template) & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess sheetResult FormSuccess sheetResult
@ -200,6 +200,17 @@ getSheetListR tid csh = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") in anchorCellM mkRoute $(widgetFile "widgets/rating")
, sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent)
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
case sType of
NotGraded -> mempty
_ | maxPoints sType > 0 ->
let percent = sPoints / maxPoints sType
in textCell $ textPercent $ realToFrac percent
_other -> mempty
_other -> mempty
] ]
psValidator = def psValidator = def
& defaultSorting [("submission-since", SortAsc)] & defaultSorting [("submission-since", SortAsc)]
@ -225,15 +236,34 @@ getSheetListR tid csh = do
, ( "rating" , ( "rating"
, SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
) )
-- GitLab Issue $143: HOW TO SORT?
-- , ( "percent"
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
-- case sheetType of -- no Haskell inside Esqueleto, right?
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
-- )
] ]
, dbtFilter = Map.fromList , dbtFilter = Map.fromList
[] []
, dbtStyle = def , dbtStyle = def
, dbtIdent = "sheets" :: Text , dbtIdent = "sheets" :: Text
} }
cTime <- Just <$> liftIO getCurrentTime -- TODO: HACK - remove me and the 2 next TODOs, see issue #142
rawStats <- runDB $ do -- compute the values of the table once again, since dbTable does not provide a list of raw values for summation/statistics
E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. (E.not_ $ E.isNothing $ sheet E.^. SheetVisibleFrom) -- TODO see above #142
E.&&. sheet E.^. SheetVisibleFrom E.<=. E.val cTime -- TODO see above #142
return $ (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
let sheetTypeSummary = foldl' sumSheetTypes emptySheetTypeSummary
$ map (\(st,mp) -> (E.unValue st, join $ E.unValue mp)) rawStats
defaultLayout $ do defaultLayout $ do
$(widgetFile "sheetList") $(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")
-- Show single sheet -- Show single sheet
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html
@ -294,11 +324,15 @@ getSShowR tid csh shn = do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
return (hasHints, hasSolution) return (hasHints, hasSolution)
cTime <- Just <$> liftIO getCurrentTime
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow") $(widgetFile "sheetShow")

183
src/Handler/Utils/Form.hs
View File

@ -11,7 +11,12 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-} {-# 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.Form.Types
import Handler.Utils.Templates import Handler.Utils.Templates
@ -34,8 +39,6 @@ import qualified Data.Text as T
import Yesod.Form.Functions (parseHelper) import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3 import Yesod.Form.Bootstrap3
import qualified Text.Blaze.Internal as Blaze (null)
import Web.PathPieces (showToPathPiece, readFromPathPiece) import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Handler.Utils.Zip import Handler.Utils.Zip
@ -56,54 +59,10 @@ import Data.Scientific (Scientific)
import Data.Ratio import Data.Ratio
import Text.Read (readMaybe) 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 ) -- -- 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 data BtnDelete = BtnDelete | BtnAbort
deriving (Enum, Eq, Ord, Bounded, Read, Show) deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -111,27 +70,13 @@ instance PathPiece BtnDelete where -- for displaying the button only, not rea
toPathPiece = showToPathPiece toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece fromPathPiece = readFromPathPiece
instance Button BtnDelete where instance Button UniWorX BtnDelete where
label BtnDelete = [whamlet|_{MsgBtnDelete}|] label BtnDelete = [whamlet|_{MsgBtnDelete}|]
label BtnAbort = [whamlet|_{MsgBtnAbort}|] label BtnAbort = [whamlet|_{MsgBtnAbort}|]
cssClass BtnDelete = BCDanger cssClass BtnDelete = BCDanger
cssClass BtnAbort = BCDefault 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 data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show) deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -139,7 +84,7 @@ instance PathPiece RegisterButton where
toPathPiece = showToPathPiece toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece fromPathPiece = readFromPathPiece
instance Button RegisterButton where instance Button UniWorX RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|] label BtnRegister = [whamlet|_{MsgBtnRegister}|]
label BtnDeregister = [whamlet|_{MsgBtnDeregister}|] label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
@ -153,7 +98,7 @@ instance PathPiece AdminHijackUserButton where
toPathPiece = showToPathPiece toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece fromPathPiece = readFromPathPiece
instance Button AdminHijackUserButton where instance Button UniWorX AdminHijackUserButton where
label BtnHijack = [whamlet|_{MsgBtnHijack}|] label BtnHijack = [whamlet|_{MsgBtnHijack}|]
cssClass BtnHijack = BCDefault cssClass BtnHijack = BCDefault
@ -166,7 +111,7 @@ instance Button AdminHijackUserButton where
-- instance PathPiece LinkButton where -- instance PathPiece LinkButton where
-- LinkButton route = ??? -- 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} |] linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
-- [whamlet| -- [whamlet|
-- <form method=post action=@{url}> -- <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 :: Widget -> Route UniWorX -> Widget
simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |] 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) 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 => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button a) => Form a buttonForm :: (Button UniWorX a) => Form a
buttonForm csrf = do buttonForm csrf = do
buttonIdent <- newFormIdent buttonIdent <- newFormIdent
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing 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 :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors 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. optionsPersistCryptoId :: forall site backend a msg.
( YesodPersist site ( YesodPersist site
, PersistQueryRead backend , PersistQueryRead backend

6
src/Model.hs
View File

@ -8,6 +8,9 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
module Model module Model
( module Model ( module Model
, module Model.Types , module Model.Types
@ -31,6 +34,9 @@ import Data.CaseInsensitive (CI)
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"] share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
$(persistFileWith lowerCaseSettings "models") $(persistFileWith lowerCaseSettings "models")
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course)
migrateAll :: Migration migrateAll :: Migration
migrateAll = do migrateAll = do
migrateEnableExtension "citext" migrateEnableExtension "citext"

26
src/Model/Types.hs
View File

@ -76,6 +76,32 @@ instance DisplayAble SheetType where
deriveJSON defaultOptions ''SheetType deriveJSON defaultOptions ''SheetType
derivePersistFieldJSON "SheetType" derivePersistFieldJSON "SheetType"
data SheetTypeSummary = SheetTypeSummary
{ sumBonusPoints :: Points
, sumNormalPoints :: Points
, numPassSheets :: Int
, numNotGraded :: Int
, achievedBonus :: Maybe Points
, achievedNormal :: Maybe Points
, achievedPasses :: Maybe Int
}
emptySheetTypeSummary :: SheetTypeSummary
emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing
-- TODO: refactor with lenses!
sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary
sumSheetTypes sts@(SheetTypeSummary {..}) (Bonus {..}, achieved)
= sts{ sumBonusPoints =sumBonusPoints +maxPoints, achievedBonus = maybeAdd achievedBonus achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Normal {..}, achieved)
= sts{ sumNormalPoints=sumNormalPoints+maxPoints, achievedNormal = maybeAdd achievedNormal achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Pass {..}, achieved)
= sts{ numPassSheets=numPassSheets+1, achievedPasses = maybeAdd achievedPasses (bool 0 1 <$> (passingPoints <=) <$> achieved) }
sumSheetTypes sts@(SheetTypeSummary {..}) (NotGraded, _achieved)
= sts{ numNotGraded=numNotGraded+1 }
data SheetGroup data SheetGroup
= Arbitrary { maxParticipants :: Int } = Arbitrary { maxParticipants :: Int }
| RegisteredGroups | RegisteredGroups

49
src/Settings.hs
View File

@ -3,6 +3,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Settings are centralized, as much as possible, into this file. This -- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc. -- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod -- 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 qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject, import Data.Aeson (Result (..), fromJSON, withObject,
(.!=), (.:?)) (.!=), (.:?))
import Data.Aeson.TH
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither') import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf) import Database.Persist.Postgresql (PostgresConf)
@ -24,6 +27,10 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload, widgetFileNoReload,
widgetFileReload) widgetFileReload)
import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
import Model import Model
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
@ -34,6 +41,7 @@ data AppSettings = AppSettings
-- ^ Directory from which to serve static files. -- ^ Directory from which to serve static files.
, appDatabaseConf :: PostgresConf , appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database. -- ^ Configuration settings for accessing the database.
, appLdapConf :: Maybe LdapConf
, appRoot :: Maybe Text , appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined -- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers. -- from the request headers.
@ -45,11 +53,6 @@ data AppSettings = AppSettings
-- ^ Get the IP address from the header when logging. Useful when sitting -- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy. -- behind a reverse proxy.
, appLDAPURI :: String
, appLDAPDN :: String
, appLDAPPw :: String
, appLDAPBaseName :: Maybe String
, appDetailedRequestLogging :: Bool , appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system -- ^ Use detailed request logging system
, appShouldLogAll :: Bool , 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 instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev = let defaultDev =
@ -93,14 +125,15 @@ instance FromJSON AppSettings where
#endif #endif
appStaticDir <- o .: "static-dir" appStaticDir <- o .: "static-dir"
appDatabaseConf <- o .: "database" 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" appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host" appHost <- fromString <$> o .: "host"
appPort <- o .: "port" appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header" 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 appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appReloadTemplates <- o .:? "reload-templates" .!= defaultDev

18
src/Utils.hs
View File

@ -14,6 +14,7 @@ module Utils
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.List (foldl) import Data.List (foldl)
import Data.Foldable as Fold import Data.Foldable as Fold
import qualified Data.Char as Char import qualified Data.Char as Char
@ -150,6 +151,14 @@ instance DisplayAble a => DisplayAble (CI a) where
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
display = pack . show display = pack . show
textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> (pack $ show rx) <> "%"
where
round' :: Double -> Int -- avoids annoying warning
round' = round
rx :: Double
rx = fromIntegral (round' $ 1000.0*x) / 10.0
lz = if rx < 10.0 then "0" else ""
------------ ------------
@ -215,6 +224,15 @@ toMaybe :: Bool -> a -> Maybe a
toMaybe True = Just toMaybe True = Just
toMaybe False = const Nothing toMaybe False = const Nothing
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y = y
maybeAdd x Nothing = x
maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
maybeEmpty (Just x) f = f x
maybeEmpty Nothing _ = mempty
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return () whenIsJust Nothing _ = return ()

2
src/Utils/DB.hs
View File

@ -30,7 +30,7 @@ existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity re
existsBy = fmap isJust . getBy existsBy = fmap isJust . getBy
myReplaceUnique myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
:: (MonadIO m :: (MonadIO m
,Eq (Unique record) ,Eq (Unique record)
,PersistRecordBackend record backend ,PersistRecordBackend record backend

190
src/Utils/Form.hs Normal file
View 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
View File

@ -13,27 +13,17 @@ packages:
git: https://github.com/pngwjpgh/zip-stream.git git: https://github.com/pngwjpgh/zip-stream.git
commit: 9272bbed000928d500febad1cdc98d1da29d399e commit: 9272bbed000928d500febad1cdc98d1da29d399e
extra-dep: true 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: - location:
git: https://github.com/pngwjpgh/encoding.git git: https://github.com/pngwjpgh/encoding.git
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
extra-dep: true extra-dep: true
- location:
git: https://github.com/pngwjpgh/system-locale.git
commit: d803ce3607ac6813ac1a065acb423220f57dab3c
extra-dep: true
extra-deps: extra-deps:
- colonnade-1.2.0 - colonnade-1.2.0
- yesod-colonnade-1.2.0 - yesod-colonnade-1.2.0
- ldap-client-0.2.0
- conduit-resumablesink-0.2 - conduit-resumablesink-0.2
- uuid-crypto-1.4.0.0 - uuid-crypto-1.4.0.0
@ -42,6 +32,6 @@ extra-deps:
- cryptoids-types-0.0.0 - cryptoids-types-0.0.0
- cryptoids-class-0.0.0 - cryptoids-class-0.0.0
- LDAP-0.6.11 - system-locale-0.3.0.0
resolver: lts-10.5 resolver: lts-10.5

15
templates/course.hamlet
View File

@ -15,9 +15,9 @@
<dd .deflist__dd> <dd .deflist__dd>
<div> <div>
<a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link} <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
$if NTop (Just 0) < NTop (courseCapacity course) $# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt>Teilnehmer <dt .deflist__dt>Teilnehmer
<dd .deflist__dd> <dd .deflist__dd>
<div> <div>
#{participants} #{participants}
$maybe capacity <- courseCapacity course $maybe capacity <- courseCapacity course
@ -36,6 +36,15 @@
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}> <form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm $# regWidget is defined through templates/widgets/registerForm
^{regWidget} ^{regWidget}
<dt .deflist__dt>
Material
<dd .deflist__dd>
<div>
$if courseMaterialFree course
Das Kursmaterial ist ohne Anmeldung frei zugänglich.
$else
Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
(z.B. Übungsblätter).
$# <div .container> $# <div .container>
$# <div .tab-group> $# <div .tab-group>

7
templates/home.hamlet
View File

@ -1,12 +1,5 @@
<div .container> <div .container>
<div .alerts>
<div .alert .alert-danger>
<div .alert__content>
Vorabversion!
Die Implementierung von
Uni2work ist noch nicht abgeschlossen.
<h1> <h1>
Kurse mit offener Registrierung Kurse mit offener Registrierung
<div .container> <div .container>

7
templates/homeUser.hamlet
View File

@ -2,13 +2,6 @@
<h3> <h3>
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a> Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
<div .alerts>
<div .alert .alert-danger>
<div .alert__content>
Vorabversion!
Die Implementierung von
Uni2work ist noch nicht abgeschlossen.
<div .container> <div .container>
<h1> <h1>
Anstehende Übungsblätter Anstehende Übungsblätter

9
templates/login.hamlet Normal file
View 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/sheetShow.hamlet
View File

@ -12,7 +12,7 @@
#{marking} #{marking}
<p> <p>
Freigeschaltet ab Download und Abgabe freigeschaltet ab
#{sheetFrom} #{sheetFrom}
<p> <p>

7
templates/versionHistory.hamlet
View File

@ -2,13 +2,6 @@
<h3> <h3>
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a> Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
<div .alerts>
<div .alert .alert-danger>
<div .alert__content>
Vorabversion!
Die Implementierung von
Uni2work ist noch nicht abgeschlossen.
<section> <section>
^{features} ^{features}

2
templates/widgets/campus-login-form.hamlet Normal file
View File

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

11
templates/widgets/campus-login.hamlet Normal file
View 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}

4
templates/widgets/form.hamlet
View File

@ -8,3 +8,7 @@ $case formLayout
<label .form-group__label for=#{fvId view}>#{fvLabel view} <label .form-group__label for=#{fvId view}>#{fvLabel view}
<div .form-group__input> <div .form-group__input>
^{fvInput view} ^{fvInput view}
$maybe tooltip <- fvTooltip view
<div .js-tooltip>
<div .tooltip__handle>?
<div .tooltip__content>^{tooltip}

23
templates/widgets/sheetTypeSummary.hamlet Normal file
View File

@ -0,0 +1,23 @@
<div>
$if 0 < sumNormalPoints sheetTypeSummary
Gesamtpunktzahl #{display (sumNormalPoints sheetTypeSummary)}
$maybe nPts <- (maybeAdd (achievedNormal sheetTypeSummary) (achievedBonus sheetTypeSummary))
\ davon #{display nPts} erreicht
$maybe bPts <- achievedBonus sheetTypeSummary
\ (inklusive #{display bPts} #
$if 0 < sumBonusPoints sheetTypeSummary
von #{display $ sumBonusPoints sheetTypeSummary} erreichbaren #
Bonuspunkten)
\ #{textPercent $ realToFrac $ nPts / (sumNormalPoints sheetTypeSummary)}
<div>
$if 0 < numPassSheets sheetTypeSummary
Blätter zum Bestehen: #{display (numPassSheets sheetTypeSummary)}
$maybe passed <- achievedPasses sheetTypeSummary
\ davon #{display (achievedPasses sheetTypeSummary)} bestanden.
<div>
$if 0 < numNotGraded sheetTypeSummary
Unbewertet: #{display (numNotGraded sheetTypeSummary)} Blätter