diff --git a/ChangeLog.md b/ChangeLog.md index 240b51546..a114345ce 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 01.08.2018 + + Verbesserter Campus-Login + * Version 31.07.2018 Viele Verbesserung zur Anzeige von Korrekturen diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index a1121050d..0695438b8 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -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 diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index 1681e28e9..5bbb73664 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -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 diff --git a/config/settings.yml b/config/settings.yml index d369568f1..1b0913f6f 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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 diff --git a/messages/campus/de.msg b/messages/campus/de.msg new file mode 100644 index 000000000..5fdf477b7 --- /dev/null +++ b/messages/campus/de.msg @@ -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 \ No newline at end of file diff --git a/messages/de.msg b/messages/uniworx/de.msg similarity index 87% rename from messages/de.msg rename to messages/uniworx/de.msg index ae6d17cb8..4512f8e17 100644 --- a/messages/de.msg +++ b/messages/uniworx/de.msg @@ -31,6 +31,8 @@ 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 @@ -47,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 @@ -67,11 +85,20 @@ SheetHintFrom: Hinweis ab SheetSolution: Lösung SheetSolutionFrom: Lösung ab 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 +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 @@ -142,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 @@ -194,10 +222,11 @@ RatingTime: Korrigiert RatingComment: Kommentar SubmissionUsers: Studenten Rating: Korrektur - 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 @@ -208,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 @@ -232,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 diff --git a/package.yaml b/package.yaml index f6aba2b60..74bb7bf3c 100644 --- a/package.yaml +++ b/package.yaml @@ -74,8 +74,6 @@ dependencies: - generic-deriving - blaze-html - conduit-resumablesink >=0.2 -- yesod-auth-ldap -- LDAP - parsec - uuid - exceptions @@ -88,6 +86,8 @@ dependencies: - th-lift-instances - gitrev - Glob +- ldap-client +- connection # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index f207525b7..097e6a0b8 100644 --- a/routes +++ b/routes @@ -61,7 +61,7 @@ / SShowR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - /subs SSubsR GET POST + /subs SSubsR GET POST -- for lecturer only /subs/new SubmissionNewR GET POST !timeANDregistered /subs/own SubmissionOwnR GET !free -- just redirect /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs new file mode 100644 index 000000000..ec0493e8f --- /dev/null +++ b/src/Auth/LDAP.hs @@ -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" diff --git a/src/Auth/PWFile.hs b/src/Auth/PWFile.hs new file mode 100644 index 000000000..541be7718 --- /dev/null +++ b/src/Auth/PWFile.hs @@ -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 + diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 3b5efceec..c0739843f 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 131ed25bd..6931f8eb7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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) @@ -74,6 +70,7 @@ import Control.Monad.Trans.Reader (runReader) import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Catch (handleAll) +import qualified Control.Monad.Catch as C import System.FilePath @@ -81,6 +78,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 +162,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 +199,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 +513,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,136 +1069,128 @@ 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) - authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do - let (userPlugin, userIdent) - | 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 + setTitleI MsgLoginTitle + $(widgetFile "login") + authenticate Creds{..} = runDB $ do let - userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra - userEmail' = lookup "mail" credsExtra - userDisplayName' = lookup "displayName" credsExtra + (userPlugin, userIdent) + | isDummy + , [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' - userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' + excHandlers + | 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 - let - userMaxFavourites = appDefaultMaxFavourites - userTheme = appDefaultTheme - userDateTimeFormat = appDefaultDateTimeFormat - userDateFormat = appDefaultDateFormat - userTimeFormat = appDefaultTimeFormat - newUser = User{..} - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserEmail =. userEmail + flip catches excHandlers $ case appLdapConf of + Just ldapConf -> fmap (either id id) . runExceptT $ 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 -> acceptExisting - 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. diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index d3e5d2353..d0682f855 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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|Mathematik|] label CreateInf = "Informatik" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index c2792c48d..670cb1c17 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 080e444ec..4ff4676a7 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiWayIf #-} @@ -77,6 +77,11 @@ course2Participants course = E.sub_select . E.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId 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 muid course = E.exists . E.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId @@ -263,7 +268,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,22 +301,19 @@ 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 + success <- runDB $ do old <- get cid case old of - Nothing -> addMessageI "error" $ MsgInvalidInput + Nothing -> addMessageI "error" MsgInvalidInput $> False (Just oldCourse) -> do - -- existing <- getBy $ CourseTermShort tid csh - -- if ((entityKey <$> existing) /= Just cid) - -- then addMessageI "danger" $ MsgCourseEditDupShort tid csh - -- else do - _updOkay <- replace cid ( -- TODO replaceUnique requires Eq?! + updOkay <- myReplaceUnique cid ( -- replaceUnique requires Eq Course, which we cannot have Course { courseName = cfName res , courseDescription = cfDesc res , courseLinkExternal = cfLink res @@ -326,12 +328,13 @@ courseEditHandler isGet course = do , courseDeregisterUntil = cfDeRegUntil res } ) - insert_ $ CourseEdit aid now cid --- if (isNothing updOkay) --- then do - addMessageI "success" $ MsgCourseEditOk tid csh - -- redirect $ TermCourseListR tid --- else addMessageI "danger" $ MsgCourseEditDupShort tid csh + case updOkay of + (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False + Nothing -> do + insert_ $ CourseEdit aid now cid + addMessageI "success" $ MsgCourseEditOk tid csh + return True + when success $ redirect $ CourseR tid csh CShowR (FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormMissing) -> return () @@ -342,7 +345,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 +360,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,29 +388,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) - <*> aopt (natField "Kapazität") (fsb "Kapazität") (cfCapacity <$> template) + <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) + <*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) + <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity + & 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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 786828b70..960ff2757 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -102,6 +102,7 @@ homeAnonymous = do , dbtIdent = "upcomingdeadlines" :: Text } let features = $(widgetFile "featureList") + addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" defaultLayout $ do $(widgetFile "dsgvDisclaimer") $(widgetFile "home") @@ -192,6 +193,7 @@ homeUser uid = do , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } + addMessage "danger" "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." defaultLayout $ do -- setTitle "Willkommen zum Uni2work Test!" $(widgetFile "homeUser") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8319760f2..8284164c1 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 @@ -200,6 +200,17 @@ getSheetListR tid csh = do cid <- mkCid return $ CSubmissionR tid csh sheetName cid CorrectionR 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 & defaultSorting [("submission-since", SortAsc)] @@ -225,15 +236,34 @@ getSheetListR tid csh = do , ( "rating" , 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 [] , dbtStyle = def , 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 $(widgetFile "sheetList") - + $(widgetFile "widgets/sheetTypeSummary") -- Show single sheet getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html @@ -294,11 +324,15 @@ getSShowR tid csh shn = do hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] 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 setTitleI $ MsgSheetTitle tid csh shn - sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet - sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet - hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet + sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet + sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet + hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 280f5dfa6..7600f1d8e 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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| ^{lbl} |] -- [whamlet| --
@@ -178,30 +123,6 @@ linkButton lbl cls url = [whamlet| Route UniWorX -> Widget simpleLink lbl url = [whamlet| ^{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| -