Merge branch 'master' into 'live'

Custom LDAP Closes #94, #17, #109, #81, and #132 See merge request !65
2018-08-02 17:43:23 +02:00 · 2018-08-02 17:43:23 +02:00 · 8b87ea3d4f
commit 8b87ea3d4f
parent e5821fb135 34f94bb886
35 changed files with 885 additions and 435 deletions
--- 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
--- 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
--- 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
--- 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
--- a/messages/campus/de.msg
+++ 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
--- a/messages/uniworx/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
--- 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.
--- a/2
+++ b/2
@ -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:
--- a/src/Auth/LDAP.hs
+++ 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"
--- a/src/Auth/PWFile.hs
+++ 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
+
--- 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
--- 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.
--- 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|Ma<i>thema</i>tik|]
  label CreateInf  = "Informatik"

--- 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

--- 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
--- 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")
--- 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")

--- 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| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
 --   [whamlet|
 --     <form method=post action=@{url}>
@ -178,30 +123,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]

-buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
-buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
-  where
-    fieldEnctype = UrlEncoded
-
-    fieldView fid name attrs _val _ =
-      [whamlet|
-        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
-      |]
-
-    fieldParse []    _ = return $ Right Nothing
-    fieldParse [str] _
-      | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
-    fieldParse _ _ = return $ Left "Multiple button values"
-
-
-combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
-combinedButtonField btns = traverse b2f btns
-  where
-    b2f b = aopt (buttonField b) "" Nothing
-
-submitButton :: AForm Handler ()
-submitButton = void $ combinedButtonField [BtnSubmit]

    {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
@ -236,7 +157,7 @@ combinedButtonField btns inner csrf = do
    -}

 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
-buttonForm :: (Button a) => Form a
+buttonForm :: (Button UniWorX a) => Form a
 buttonForm csrf = do
    buttonIdent <- newFormIdent
    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
@ -444,88 +365,6 @@ fsm = bfs -- TODO: get rid of Bootstrap
 fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors

-fsl ::  Text -> FieldSettings UniWorX
-fsl lbl =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = []
-  }
-
-fslI :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
-fslI lbl =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = []
-  }
-
-fslp ::  Text -> Text -> FieldSettings UniWorX
-fslp lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
-  }
-
-fslpI :: RenderMessage UniWorX msg => msg -> Text -> FieldSettings UniWorX
-fslpI lbl placeholder =
-  FieldSettings { fsLabel    = (SomeMessage lbl)
-                , fsTooltip  = Nothing
-                , fsId       = Nothing
-                , fsName     = Nothing
-                , fsAttrs    = [("placeholder", placeholder)]
-  }
-
-addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
-addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,valu)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.append valu $ cons ' ' v):t
-      | otherwise = p:(newAttrs t)
-
-addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
-addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,T.intercalate " " valus)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.intercalate " " (v:valus)):t
-      | otherwise = p:(newAttrs t)
-
-addClass :: Text -> FieldSettings site -> FieldSettings site
-addClass = addAttr "class"
-
-addClasses :: [Text] -> FieldSettings site -> FieldSettings site
-addClasses = addAttrs "class"
-
-addName :: Text -> FieldSettings site -> FieldSettings site
-addName nm fs = fs { fsName = Just nm }
-
-addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-
-setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
-setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
-
-setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
-setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-setTooltip :: String -> FieldSettings site -> FieldSettings site
-setTooltip tt fs
-  | null tt   = fs { fsTooltip = Nothing }
-  | otherwise = fs { fsTooltip = Just $ fromString tt
-                   , fsAttrs=("data-tooltip",fromString tt):(fsAttrs fs) }
-
 optionsPersistCryptoId :: forall site backend a msg.
                          ( YesodPersist site
                          , PersistQueryRead backend
--- a/src/Model.hs
+++ b/src/Model.hs
@ -8,6 +8,9 @@
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+
 module Model
  ( module Model
  , module Model.Types
@ -31,6 +34,9 @@ import Data.CaseInsensitive (CI)
 share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
    $(persistFileWith lowerCaseSettings "models")

+-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
+deriving instance Eq (Unique Course)
+
 migrateAll :: Migration
 migrateAll = do
  migrateEnableExtension "citext"
--- a/src/Model/Types.hs
+++ b/src/Model/Types.hs
@ -76,6 +76,32 @@ instance DisplayAble SheetType where
 deriveJSON defaultOptions ''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
  = Arbitrary { maxParticipants :: Int }
  | RegisteredGroups
--- a/src/Settings.hs
+++ b/src/Settings.hs
@ -3,6 +3,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE MultiWayIf        #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
 -- In addition, you can configure a number of different aspects of Yesod
@ -14,6 +16,7 @@ import           ClassyPrelude.Yesod
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject,
                                              (.!=), (.:?))
+import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
 import           Database.Persist.Postgresql (PostgresConf)
@ -24,6 +27,10 @@ import           Yesod.Default.Util          (WidgetFileSettings,
                                              widgetFileNoReload,
                                              widgetFileReload)

+import qualified Data.Text.Encoding as Text
+
+import qualified Ldap.Client as Ldap
+
 import Model

 -- | Runtime settings to configure this application. These settings can be
@ -34,6 +41,7 @@ data AppSettings = AppSettings
    -- ^ Directory from which to serve static files.
    , appDatabaseConf           :: PostgresConf
    -- ^ Configuration settings for accessing the database.
+    , appLdapConf               :: Maybe LdapConf
    , appRoot                   :: Maybe Text
    -- ^ Base for all generated URLs. If @Nothing@, determined
    -- from the request headers.
@ -45,11 +53,6 @@ data AppSettings = AppSettings
    -- ^ Get the IP address from the header when logging. Useful when sitting
    -- behind a reverse proxy.

-    , appLDAPURI                :: String
-    , appLDAPDN                 :: String
-    , appLDAPPw                 :: String
-    , appLDAPBaseName           :: Maybe String
-
    , appDetailedRequestLogging :: Bool
    -- ^ Use detailed request logging system
    , appShouldLogAll           :: Bool
@ -83,6 +86,35 @@ data AppSettings = AppSettings

    }

+data LdapConf = LdapConf
+  { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
+  , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
+  , ldapBase :: Ldap.Dn
+  , ldapScope :: Ldap.Scope
+  , ldapTimeout :: Int32
+  }
+
+deriveFromJSON defaultOptions ''Ldap.Scope
+
+instance FromJSON LdapConf where
+    parseJSON = withObject "LdapConf" $ \o -> do
+        ldapTls <- o .:? "tls"
+        tlsSettings <- case ldapTls :: Maybe String of
+          Just spec
+            | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
+            | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
+            | null spec          -> return Nothing
+          Nothing                -> return Nothing
+          _otherwise             -> fail "Could not parse LDAP TLSSettings"
+        ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
+        ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+        ldapDn <- Ldap.Dn <$> o .: "user"
+        ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
+        ldapBase <- Ldap.Dn <$> o .: "baseDN"
+        ldapScope <- o .: "scope"
+        ldapTimeout <- o .: "timeout"
+        return LdapConf{..}
+
 instance FromJSON AppSettings where
    parseJSON = withObject "AppSettings" $ \o -> do
        let defaultDev =
@ -93,14 +125,15 @@ instance FromJSON AppSettings where
 #endif
        appStaticDir              <- o .: "static-dir"
        appDatabaseConf           <- o .: "database"
+        let nonEmptyHost LdapConf{..} = case ldapHost of
+              Ldap.Tls host _ -> not $ null host
+              Ldap.Plain host -> not $ null host
+        appLdapConf               <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap"
        appRoot                   <- o .:? "approot"
        appHost                   <- fromString <$> o .: "host"
        appPort                   <- o .: "port"
        appIpFromHeader           <- o .: "ip-from-header"

-        ( appLDAPURI, appLDAPDN, appLDAPPw, appLDAPBaseName )
-          <- (=<< o .: "ldap") . withObject "LDAP" $ \obj -> (,,,) <$> obj .: "uri" <*> obj .: "dn" <*> obj .: "password" <*> obj .:? "basename"
-
        appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
        appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
        appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -14,6 +14,7 @@ module Utils

 import ClassyPrelude.Yesod

+-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
 import Data.List (foldl)
 import Data.Foldable as Fold
 import qualified Data.Char as Char
@ -150,6 +151,14 @@ instance DisplayAble a => DisplayAble (CI a) where
 instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
  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 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 (Just x) f = f x
 whenIsJust Nothing  _ = return ()
--- a/src/Utils/DB.hs
+++ b/src/Utils/DB.hs
@ -30,7 +30,7 @@ existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity re
 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
       ,Eq (Unique record)
       ,PersistRecordBackend record backend
--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@ -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]
--- a/stack.yaml
+++ b/stack.yaml
@ -13,27 +13,17 @@ packages:
      git: https://github.com/pngwjpgh/zip-stream.git
      commit: 9272bbed000928d500febad1cdc98d1da29d399e
    extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/yesod-auth-ldap.git
-      commit: 69e08ef687ab96df3352ff4267562135453c6f02
-    extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/authenticate-ldap.git
-      commit: cc2770024766a8fa29d3086688df60aaf65fb954
-    extra-dep: true
  - location:
      git: https://github.com/pngwjpgh/encoding.git
      commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
    extra-dep: true
-  - location:
-      git: https://github.com/pngwjpgh/system-locale.git
-      commit: d803ce3607ac6813ac1a065acb423220f57dab3c
-    extra-dep: true

 extra-deps:
  - colonnade-1.2.0
  - yesod-colonnade-1.2.0

+  - ldap-client-0.2.0
+
  - conduit-resumablesink-0.2

  - uuid-crypto-1.4.0.0
@ -42,6 +32,6 @@ extra-deps:
  - cryptoids-types-0.0.0
  - cryptoids-class-0.0.0

-  - LDAP-0.6.11
+  - system-locale-0.3.0.0

 resolver: lts-10.5
--- a/templates/course.hamlet
+++ b/templates/course.hamlet
@ -15,9 +15,9 @@
      <dd .deflist__dd>
        <div>
          <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
-    $if NTop (Just 0) < NTop (courseCapacity course)
-      <dt .deflist__dt>Teilnehmer
-      <dd .deflist__dd>
+$#    $if NTop (Just 0) < NTop (courseCapacity course)
+    <dt .deflist__dt>Teilnehmer
+    <dd .deflist__dd>
        <div>
          #{participants}
          $maybe capacity <- courseCapacity course
@ -36,6 +36,15 @@
          <form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
            $# regWidget is defined through templates/widgets/registerForm
            ^{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 .tab-group>
--- a/templates/home.hamlet
+++ b/templates/home.hamlet
@ -1,12 +1,5 @@
 <div .container>

-  <div .alerts>
-    <div .alert .alert-danger>
-      <div .alert__content>
-        Vorabversion!
-        Die Implementierung von
-        Uni2work ist noch nicht abgeschlossen.
-
  <h1>
    Kurse mit offener Registrierung
  <div .container>
--- a/templates/homeUser.hamlet
+++ b/templates/homeUser.hamlet
@ -2,13 +2,6 @@
  <h3>
    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>
  <h1>
    Anstehende Übungsblätter
--- a/templates/login.hamlet
+++ b/templates/login.hamlet
@ -0,0 +1,9 @@
+$forall AuthPlugin{..} <- plugins
+  $if apName == "LDAP"
+    <section>
+      <h2>_{MsgLDAPLoginTitle}
+      ^{apLogin toParent}
+  $elseif apName == "dummy"
+    <section>
+      <h2>_{MsgDummyLoginTitle}
+      ^{apLogin toParent}
--- a/templates/sheetShow.hamlet
+++ b/templates/sheetShow.hamlet
@ -12,7 +12,7 @@
      #{marking}

  <p>
-    Freigeschaltet ab
+    Download und Abgabe freigeschaltet ab
    #{sheetFrom}

  <p>
--- a/templates/versionHistory.hamlet
+++ b/templates/versionHistory.hamlet
@ -2,13 +2,6 @@
  <h3>
    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>
    ^{features}

--- a/templates/widgets/campus-login-form.hamlet
+++ b/templates/widgets/campus-login-form.hamlet
@ -0,0 +1,2 @@
+<form method=POST action=@{toMaster $ PluginR "LDAP" []} enctype=#{loginEnctype}>
+  ^{login}
--- a/templates/widgets/campus-login.hamlet
+++ b/templates/widgets/campus-login.hamlet
@ -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}
--- a/templates/widgets/form.hamlet
+++ b/templates/widgets/form.hamlet
@ -8,3 +8,7 @@ $case formLayout
          <label .form-group__label for=#{fvId view}>#{fvLabel view}
        <div .form-group__input>
          ^{fvInput view}
+          $maybe tooltip <- fvTooltip view
+            <div .js-tooltip>
+              <div .tooltip__handle>?
+              <div .tooltip__content>^{tooltip}
--- a/templates/widgets/sheetTypeSummary.hamlet
+++ b/templates/widgets/sheetTypeSummary.hamlet
@ -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
+