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 89% rename from messages/de.msg rename to messages/uniworx/de.msg index 25ceda435..4512f8e17 100644 --- a/messages/de.msg +++ b/messages/uniworx/de.msg @@ -32,6 +32,7 @@ LectureStart: Beginn Vorlesungen Course: Kurs CourseShort: Kürzel CourseCapacity: Kapazität +CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet @@ -48,6 +49,22 @@ TermCourseListTitle tid@TermId: Kurse #{display tid} CourseNewHeading: Neuen Kurs anlegen CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren CourseEditTitle: Kurs editieren/anlegen +CourseMembers: Teilnehmer +CourseMembersCount num@Int64: #{display num} +CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} +CourseName: Name +CourseDescription: Beschreibung +CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet +CourseHomepage: Homepage +CourseShorthand: Kürzel +CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein +CourseSemester: Semester +CourseSchool: Institut +CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt +CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich +CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein +CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein + Sheet: Blatt SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter @@ -69,12 +86,19 @@ SheetSolution: Lösung SheetSolutionFrom: Lösung ab SheetMarking: Hinweise für Korrektoren SheetType: Wertung - SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar! SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}! +SheetName: Name +SheetDescription: Hinweise für Teilnehmer +SheetGroup: Gruppenabgabe SheetVisibleFrom: Sichtbar ab +SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist SheetActiveFrom: Aktiv ab +SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich SheetActiveTo: Abgabefrist +SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen +SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen +SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen @@ -145,7 +169,8 @@ CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern die Users: Benutzer HomeHeading: Aktuelle Termine -LoginHeading: Login bitte mit "@campus.lmu.de" angeben +LoginHeading: Authentifizierung +LoginTitle: Authentifizierung ProfileHeading: Benutzerprofil und Einstellungen ProfileDataHeading: Gespeicherte Benutzerdaten ImpressumHeading: Impressum @@ -201,6 +226,7 @@ RatingPoints: Punkte RatingPercent: Erreicht RatingFiles: Korrigierte Dateien PointsNotPositive: Punktzahl darf nicht negativ sein +RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist FileTitle: Dateiname FileModified: Letzte Änderung @@ -211,10 +237,6 @@ RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben -CourseMembers: Teilnehmer -CourseMembersCount num@Int64: #{display num} -CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max} - NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter @@ -235,3 +257,6 @@ LastEdit: Letzte Änderung SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert: SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}. + +LDAPLoginTitle: Campus-Login +DummyLoginTitle: Development-Login diff --git a/package.yaml b/package.yaml index f6aba2b60..47b09239e 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,7 @@ dependencies: - th-lift-instances - gitrev - Glob +- ldap-client # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs new file mode 100644 index 000000000..77269ffa9 --- /dev/null +++ b/src/Auth/LDAP.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE RecordWildCards + , OverloadedStrings + , TemplateHaskell + , TypeFamilies + , FlexibleContexts + , FlexibleInstances + , NoImplicitPrelude + , ScopedTypeVariables + #-} + +module Auth.LDAP + ( campusLogin + , campusUser + , CampusMessage(..) + , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue + ) where + +import Import.NoFoundation +import Control.Lens + +import Utils.Form + +import qualified Ldap.Client as Ldap + +import qualified Data.Text.Encoding as Text + +import qualified Yesod.Auth.Message as Msg + + +data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text } + +data CampusMessage = MsgCampusIdentNote + | MsgCampusIdent + | MsgCampusPassword + | MsgCampusSubmit + | MsgCampusInvalidCredentials + + +findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry] +findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter + where + userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent + userSearchSettings = mconcat + [ Ldap.scope ldapScope + , Ldap.size 2 + , Ldap.time ldapTimeout + , Ldap.derefAliases Ldap.DerefAlways + ] + +userPrincipalName :: Ldap.Attr +userPrincipalName = Ldap.Attr "userPrincipalName" + +campusForm :: ( RenderMessage site FormMessage + , RenderMessage site CampusMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => AForm (HandlerT site IO) CampusLogin +campusForm = CampusLogin + <$> areq textField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing + <*> areq passwordField (fslI MsgCampusPassword) Nothing + <* submitButton + +campusLogin :: forall site. + ( YesodAuth site + , RenderMessage site FormMessage + , RenderMessage site CampusMessage + , Button site SubmitButton + , Show (ButtonCssClass site) + ) => LdapConf -> AuthPlugin site +campusLogin conf@LdapConf{..} = AuthPlugin{..} + where + apName = "LDAP" + apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent + apDispatch "POST" [] = do + ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm + case loginRes of + FormFailure errs -> do + forM_ errs $ addMessage "error" . toHtml + redirect LoginR + FormMissing -> redirect LoginR + FormSuccess CampusLogin{..} -> do + ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do + Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) + Ldap.bind ldap ldapDn ldapPassword + findUser conf ldap campusIdent [userPrincipalName] + case ldapResult of + Left err + | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err + -> do + $logDebugS "LDAP" "Invalid credentials" + loginErrorMessageI LoginR Msg.InvalidLogin + | otherwise -> do + $logErrorS "LDAP" $ "Error during login: " <> tshow err + loginErrorMessageI LoginR Msg.AuthError + Right searchResults + | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults + , Just [principalName] <- lookup userPrincipalName userAttrs + , Right credsIdent <- Text.decodeUtf8' principalName + -> do + $logDebugS "LDAP" $ tshow searchResults + lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)] + | otherwise -> do + $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults + loginErrorMessageI LoginR Msg.AuthError + apDispatch _ _ = notFound + apLogin toMaster = do + (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm + $(widgetFile "widgets/campus-login-form") + +data CampusUserException = CampusUserLdapError Ldap.LdapError + | CampusUserNoResult + | CampusUserAmbiguous + deriving (Show, Eq, Typeable) + +instance Exception CampusUserException + +campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList []) +campusUser conf@LdapConf{..} Creds{..} = liftIO $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do + Ldap.bind ldap ldapDn ldapPassword + results <- case lookup "DN" credsExtra of + Just userDN -> do + let userFilter = Ldap.Present userPrincipalName + userSearchSettings = mconcat + [ Ldap.scope Ldap.BaseObject + , Ldap.size 2 + , Ldap.time ldapTimeout + , Ldap.derefAliases Ldap.DerefAlways + ] + Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter [] + Nothing -> do + findUser conf ldap credsIdent [] + case results of + [] -> throwM CampusUserNoResult + [Ldap.SearchEntry _ attrs] -> return attrs + _otherwise -> throwM CampusUserAmbiguous + +-- ldapConfig :: UniWorX -> LDAPConfig +-- ldapConfig _app@(appSettings -> settings) = LDAPConfig +-- { usernameFilter = \u -> principalName <> "=" <> u +-- , identifierModifier +-- , ldapUri = appLDAPURI settings +-- , initDN = appLDAPDN settings +-- , initPass = appLDAPPw settings +-- , baseDN = appLDAPBaseName settings +-- , ldapScope = LdapScopeSubtree +-- } +-- where +-- principalName :: IsString a => a +-- principalName = "userPrincipalName" +-- identifierModifier _ entry = case lookup principalName $ leattrs entry of +-- Just [n] -> Text.pack n +-- _ -> error "Could not determine user principal name" 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..b32f2b59b 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) @@ -81,6 +77,7 @@ import Handler.Utils.Templates import Handler.Utils.StudyFeatures import Control.Lens import Utils +import Utils.Form import Utils.Lens import Data.Aeson @@ -164,7 +161,8 @@ data MenuTypes -- Semantische Rolle: | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten -- Messages -mkMessage "UniWorX" "messages" "de" +mkMessage "UniWorX" "messages/uniworx" "de" +mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. @@ -200,6 +198,16 @@ instance RenderMessage UniWorX SheetFileType where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) + +data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink + deriving (Enum, Eq, Ord, Bounded, Read, Show) + +instance Button UniWorX SubmitButton where + label BtnSubmit = [whamlet|_{MsgBtnSubmit}|] + + cssClass BtnSubmit = BCPrimary + + getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) @@ -504,13 +512,6 @@ instance Yesod UniWorX where $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|] redirectWith movedPermanently301 route' - -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17 - isWriteRequest (AuthR (PluginR "LDAP" _)) = return False - isWriteRequest _ = do - wai <- waiRequest - return $ W.requestMethod wai `notElem` - ["GET", "HEAD", "OPTIONS", "TRACE"] - defaultLayout widget = do master <- getYesod mmsgs <- getMessages @@ -1067,12 +1068,13 @@ instance YesodAuth UniWorX where redirectToReferer _ = True loginHandler = do - tp <- getRouteToParent - lift . authLayout $ do - master <- getYesod - let authPlugins' = authPlugins master - $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName authPlugins') - forM_ authPlugins' $ flip apLogin tp + toParent <- getRouteToParent + lift . defaultLayout $ do + plugins <- getsYesod authPlugins + $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) + + setTitleI MsgLoginTitle + $(widgetFile "login") authenticate creds@(Creds{..}) = runDB . fmap (either id id) . runExceptT $ do let (userPlugin, userIdent) @@ -1085,118 +1087,88 @@ instance YesodAuth UniWorX where isPWFile = credsPlugin == "PWFile" uAuth = UniqueAuthentication userPlugin userIdent - $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) - - when (isDummy || isPWFile) . (throwError =<<) . lift $ - maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - - let - userMatrikelnummer = lookup "LMU-Stud-Matrikelnummer" credsExtra - userEmail' = lookup "mail" credsExtra - userDisplayName' = lookup "displayName" credsExtra - - userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail' - userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' + $logDebugS "auth" $ tshow creds AppSettings{..} <- getsYesod appSettings - let - userMaxFavourites = appDefaultMaxFavourites - userTheme = appDefaultTheme - userDateTimeFormat = appDefaultDateTimeFormat - userDateFormat = appDefaultDateFormat - userTimeFormat = appDefaultTimeFormat - newUser = User{..} - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - , UserDisplayName =. userDisplayName - , UserEmail =. userEmail + case appLdapConf of + Just ldapConf -> do + ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra + $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData + + let + userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData + userEmail' = lookup (Attr "mail") ldapData + userDisplayName' = lookup (Attr "displayName") ldapData + + userEmail <- if + | Just [bs] <- userEmail' + , Right userEmail <- Text.decodeUtf8' bs + -> return $ CI.mk userEmail + | otherwise + -> throwError $ ServerError "Could not retrieve user email" + userDisplayName <- if + | Just [bs] <- userDisplayName' + , Right userDisplayName <- Text.decodeUtf8' bs + -> return userDisplayName + | otherwise + -> throwError $ ServerError "Could not retrieve user name" + userMatrikelnummer <- if + | Just [bs] <- userMatrikelnummer' + , Right userMatrikelnummer <- Text.decodeUtf8' bs + -> return $ Just userMatrikelnummer + | Nothing <- userMatrikelnummer' + -> return Nothing + | otherwise + -> throwError $ ServerError "Could not decode user matriculation" + + let + userMaxFavourites = appDefaultMaxFavourites + userTheme = appDefaultTheme + userDateTimeFormat = appDefaultDateTimeFormat + userDateFormat = appDefaultDateFormat + userTimeFormat = appDefaultTimeFormat + newUser = User{..} + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + , UserDisplayName =. userDisplayName + , UserEmail =. userEmail ] - userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate + userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate - let - userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' - userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] + let + userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures' + userStudyFeatures' = do + (k, v) <- ldapData + guard $ k == Attr "dfnEduPersonFeaturesOfStudy" + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str - fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures + fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - lift $ deleteWhere [StudyFeaturesUser ==. userId] + lift $ deleteWhere [StudyFeaturesUser ==. userId] - forM_ fs $ \StudyFeatures{..} -> do - lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing - lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + forM_ fs $ \StudyFeatures{..} -> do + lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing + lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing + + lift $ insertMany_ fs + return $ Authenticated userId + Nothing -> (throwError =<<) . lift $ + maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - lift $ insertMany_ fs - return $ Authenticated userId where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - -- You can add other plugins like Google Email, email or OAuth here - authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins - -- Enable authDummy login if enabled. - where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] - ++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app] + authPlugins (appSettings -> AppSettings{..}) = catMaybes + [ campusLogin <$> appLdapConf + , maintenanceLogin <$> appAuthPWFile + , authDummy <$ guard appAuthDummyLogin + ] + authHttpManager = getHttpManager -authPWFile :: FilePath -> AuthPlugin UniWorX -authPWFile fp = AuthPlugin{..} - where - apName = "PWFile" - apLogin = mempty - apDispatch "GET" [] = do - authData <- lookupBasicAuth - pwdata <- liftIO $ Yaml.decodeFileEither fp - - addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|] - - case pwdata of - Left err -> $logDebugS "Auth" $ tshow err - Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries" - - case (authData, pwdata) of - (Nothing, _) -> do - notAuthenticated - (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata') - | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ] - <- [ pwe | pwe@PWEntry{..} <- pwdata' - , let User{..} = pwUser - , userIdent == usr - , userPlugin == apName - ] - , verifyPassword pw pwHash - -> lift $ do - runDB . void $ insertUnique pwUser - setCredsRedirect $ Creds apName userIdent [] - _ -> permissionDenied "Invalid auth" - apDispatch _ _ = notFound - - -ldapConfig :: UniWorX -> LDAPConfig -ldapConfig _app@(appSettings -> settings) = LDAPConfig - { usernameFilter = \u -> principalName <> "=" <> u - , identifierModifier - , ldapUri = appLDAPURI settings - , initDN = appLDAPDN settings - , initPass = appLDAPPw settings - , baseDN = appLDAPBaseName settings - , ldapScope = LdapScopeSubtree - } - where - principalName :: IsString a => a - principalName = "userPrincipalName" - identifierModifier _ entry = case lookup principalName $ leattrs entry of - Just [n] -> Text.pack n - _ -> error "Could not determine user principal name" - --- | Access function to determine if a user is logged in. -isAuthenticated :: Handler AuthResult -isAuthenticated = do - muid <- maybeAuthId - return $ case muid of - Nothing -> Unauthorized "You must login to access this page" - Just _ -> Authorized - - instance YesodAuthPersist UniWorX -- Useful when writing code that is re-usable outside of the Handler context. 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 c023765f5..10caec1b0 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 #-} @@ -263,7 +263,7 @@ courseDeleteHandler = undefined courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler isGet course = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! - ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course + ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm case result of (FormSuccess res@( CourseForm { cfCourseId = Nothing @@ -296,10 +296,11 @@ courseEditHandler isGet course = do addMessageI "danger" $ MsgCourseNewDupShort tid csh (FormSuccess res@( - CourseForm { cfCourseId = Just cid + CourseForm { cfCourseId = Just cID , cfShort = csh , cfTerm = tid })) -> do -- edit existing course + cid <- decrypt cID now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] runDB $ do @@ -342,7 +343,7 @@ courseEditHandler isGet course = do data CourseForm = CourseForm - { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse + { cfCourseId :: Maybe CryptoUUIDCourse , cfName :: CourseName , cfDesc :: Maybe Html , cfLink :: Maybe Text @@ -357,24 +358,24 @@ data CourseForm = CourseForm , cfDeRegUntil :: Maybe UTCTime } -courseToForm :: Entity Course -> CourseForm -courseToForm cEntity = CourseForm - { cfCourseId = Just $ entityKey cEntity - , cfName = courseName course - , cfDesc = courseDescription course - , cfLink = courseLinkExternal course - , cfShort = courseShorthand course - , cfTerm = courseTerm course - , cfSchool = courseSchool course - , cfCapacity = courseCapacity course - , cfSecret = courseRegisterSecret course - , cfMatFree = courseMaterialFree course - , cfRegFrom = courseRegisterFrom course - , cfRegTo = courseRegisterTo course - , cfDeRegUntil = courseDeregisterUntil course - } - where - course = entityVal cEntity +courseToForm :: MonadCrypto m => Entity Course -> m CourseForm +courseToForm (Entity cid Course{..}) = do + cfCourseId <- Just <$> encrypt cid + return $ CourseForm + { cfCourseId + , cfName = courseName + , cfDesc = courseDescription + , cfLink = courseLinkExternal + , cfShort = courseShorthand + , cfTerm = courseTerm + , cfSchool = courseSchool + , cfCapacity = courseCapacity + , cfSecret = courseRegisterSecret + , cfMatFree = courseMaterialFree + , cfRegFrom = courseRegisterFrom + , cfRegTo = courseRegisterTo + , cfDeRegUntil = courseDeregisterUntil + } newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm template = identForm FIDcourse $ \html -> do @@ -385,30 +386,32 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- UUID.encrypt cidKey cid (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? - <$> aopt hiddenField "KursId" (cfCourseId <$> template) - <*> areq (ciField textField) (fsb "Name") (cfName <$> template) - <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) - <*> aopt urlField (fsb "Homepage") (cfLink <$> template) - <*> areq (ciField textField) (fsb "Kürzel" + <$> aopt hiddenField "courseId" (cfCourseId <$> template) + <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) + <*> aopt htmlField (fslI MsgCourseDescription + & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) + <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template) + <*> areq (ciField textField) (fslI MsgCourseShorthand -- & addAttr "disabled" "disabled" - & setTooltip "Muss innerhalb des Semesters eindeutig sein") + & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termActiveField (fsb "Semester") (cfTerm <$> template) - <*> areq schoolField (fsb "Institut") (cfSchool <$> template) + <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) + <*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity - & setTooltip "Für unbeschränkte Kapazität KEINEN Wert angeben.") (cfCapacity <$> template) + & setTooltip MsgCourseCapacityTip + ) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" - & setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort") + & setTooltip MsgCourseSecretTip) (cfSecret <$> template) <*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum, sonst KEINE Anmeldung" - & setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!") + <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" + & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum, sonst unbegr. Anmeldung" - & setTooltip "Die Anmeldung darf ohne Begrenzung sein") + <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" + & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template) - <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum, sonst unbegr. Abmeldung" - & setTooltip "Die Abmeldung darf ohne Begrenzung sein") + <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum" + & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template) <* submitButton return $ case result of diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index e8e6e5ffb..584c0b4b9 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 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| -