Merge conflicts resolved

ChangeLog.md

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

config/keter_testworx.yml

@@ -20,14 +20,19 @@ stanzas:
     ssl: true
 
     forward-env:
-      - LDAPURI
+      - LDAPHOST
-      - LDAPDN
+      - LDAPTLS
-      - LDAPPW
+      - LDAPPORT
-      - LDAPBN
+      - 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

config/keter_uni2work.yml

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

config/settings.yml

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

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

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

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.

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"

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
+

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

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
+      toParent <- getRouteToParent
-      lift . authLayout $ do
+      lift . defaultLayout $ do
-        master <- getYesod
+        plugins <- getsYesod authPlugins
-        let authPlugins' = authPlugins master
+        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins)
-        $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName authPlugins')
+
-        forM_ authPlugins' $ flip apLogin tp
+        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)
+      $logDebugS "auth" $ tshow 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'
 
       AppSettings{..} <- getsYesod appSettings
 
-      let
+      case appLdapConf of
-        userMaxFavourites = appDefaultMaxFavourites
+        Just ldapConf -> do
-        userTheme = appDefaultTheme
+          ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
-        userDateTimeFormat = appDefaultDateTimeFormat
+          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-        userDateFormat = appDefaultDateFormat
+
-        userTimeFormat = appDefaultTimeFormat
+          let
-        newUser = User{..}
+            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
-        userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+            userEmail' = lookup (Attr "mail") ldapData
-                     , UserDisplayName =. userDisplayName
+            userDisplayName' = lookup (Attr "displayName") ldapData
-                     , UserEmail =. userEmail
+
+          userEmail <- if
+            | Just [bs] <- userEmail'
+            , Right userEmail <- Text.decodeUtf8' bs
+              -> return $ CI.mk userEmail
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user email"
+          userDisplayName <- if
+            | Just [bs] <- userDisplayName'
+            , Right userDisplayName <- Text.decodeUtf8' bs
+              -> return userDisplayName
+            | otherwise
+              -> throwError $ ServerError "Could not retrieve user name"
+          userMatrikelnummer <- if
+            | Just [bs] <- userMatrikelnummer'
+            , Right userMatrikelnummer <- Text.decodeUtf8' bs
+              -> return $ Just userMatrikelnummer
+            | Nothing <- userMatrikelnummer'
+              -> return Nothing
+            | otherwise
+              -> throwError $ ServerError "Could not decode user matriculation"
+
+          let
+            userMaxFavourites = appDefaultMaxFavourites
+            userTheme = appDefaultTheme
+            userDateTimeFormat = appDefaultDateTimeFormat
+            userDateFormat = appDefaultDateFormat
+            userTimeFormat = appDefaultTimeFormat
+            newUser = User{..}
+            userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
+                         , UserDisplayName =. userDisplayName
+                         , UserEmail =. userEmail
                      ]
 
-      userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
+          userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
 
-      let
+          let
-        userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
+            userStudyFeatures = concat <$> mapM (parseStudyFeatures userId) userStudyFeatures'
-        userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ]
+            userStudyFeatures' = do
+              (k, v) <- ldapData
+              guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
+              v' <- v
+              Right str <- return $ Text.decodeUtf8' v'
+              return str
 
-      fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
+          fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
 
-      lift $ deleteWhere [StudyFeaturesUser ==. userId]
+          lift $ deleteWhere [StudyFeaturesUser ==. userId]
 
-      forM_ fs $ \StudyFeatures{..} -> do
+          forM_ fs $ \StudyFeatures{..} -> do
-        lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+            lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-        lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+            lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+
+          lift $ insertMany_ fs
+          return $ Authenticated userId
+        Nothing -> (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 (appSettings -> AppSettings{..}) = catMaybes
-    authPlugins app = [genericAuthLDAP $ ldapConfig app] ++ extraAuthPlugins
+      [ campusLogin <$> appLdapConf
-        -- Enable authDummy login if enabled.
+      , maintenanceLogin <$> appAuthPWFile
-        where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
+      , authDummy <$ guard appAuthDummyLogin
-                              ++ [authPWFile fp | fp <- maybeToList . appAuthPWFile $ appSettings app]
+      ]
+
     authHttpManager = getHttpManager
 
-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.

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"
 

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
 

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 :: MonadCrypto m => Entity Course -> m CourseForm
-courseToForm cEntity = CourseForm
+courseToForm (Entity cid Course{..}) = do
-        { cfCourseId   = Just $ entityKey cEntity
+  cfCourseId <- Just <$> encrypt cid
-        , cfName       = courseName               course
+  return $ CourseForm
-        , cfDesc       = courseDescription        course
+    { cfCourseId
-        , cfLink       = courseLinkExternal       course
+    , cfName       = courseName
-        , cfShort      = courseShorthand          course
+    , cfDesc       = courseDescription
-        , cfTerm       = courseTerm               course
+    , cfLink       = courseLinkExternal
-        , cfSchool     = courseSchool             course
+    , cfShort      = courseShorthand
-        , cfCapacity   = courseCapacity           course
+    , cfTerm       = courseTerm
-        , cfSecret     = courseRegisterSecret     course
+    , cfSchool     = courseSchool
-        , cfMatFree    = courseMaterialFree       course
+    , cfCapacity   = courseCapacity
-        , cfRegFrom    = courseRegisterFrom       course
+    , cfSecret     = courseRegisterSecret
-        , cfRegTo      = courseRegisterTo         course
+    , cfMatFree    = courseMaterialFree
-        , cfDeRegUntil = courseDeregisterUntil    course
+    , cfRegFrom    = courseRegisterFrom
-        }
+    , cfRegTo      = courseRegisterTo
-  where
+    , cfDeRegUntil = courseDeregisterUntil
-    course = entityVal cEntity
+    }
 
 newCourseForm :: Maybe CourseForm -> Form CourseForm
 newCourseForm 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)
+      <$> aopt hiddenField "courseId"             (cfCourseId <$> template)
-      <*> areq (ciField textField) (fsb "Name")           (cfName     <$> template)
+      <*> areq (ciField textField) (fslI MsgCourseName)           (cfName     <$> template)
-      <*> aopt htmlField (fsb "Beschreibung")   (cfDesc     <$> template)
+      <*> aopt htmlField (fslI MsgCourseDescription
-      <*> aopt urlField  (fsb "Homepage")       (cfLink     <$> template)
+                         & setTooltip MsgCourseDescriptionTip)   (cfDesc     <$> template)
-      <*> areq (ciField textField) (fsb "Kürzel"
+      <*> aopt urlField  (fslI MsgCourseHomepage)       (cfLink     <$> template)
+      <*> areq (ciField textField) (fslI MsgCourseShorthand
             -- & addAttr "disabled" "disabled"
-            & setTooltip "Muss innerhalb des Semesters eindeutig sein")
+            & setTooltip MsgCourseShorthandUnique)
                                                 (cfShort  <$> template)
-      <*> areq termActiveField        (fsb "Semester")       (cfTerm     <$> template)
+      <*> areq termActiveField        (fslI MsgCourseSemester)       (cfTerm     <$> template)
-      <*> areq schoolField            (fsb "Institut")       (cfSchool   <$> template)
+      <*> areq schoolField            (fslI MsgCourseSchool)       (cfSchool   <$> template)
       <*> aopt (natField "Kapazität") (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"
+      <*> aopt utcTimeField           (fslpI MsgRegisterFrom "Datum"
-            & setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!")
+            & setTooltip MsgCourseRegisterFromTip)
                                                              (cfRegFrom  <$> template)
-      <*> aopt utcTimeField           (fslpI MsgRegisterTo   "Datum, sonst unbegr. Anmeldung"
+      <*> aopt utcTimeField           (fslpI MsgRegisterTo   "Datum"
-            & setTooltip "Die Anmeldung darf ohne Begrenzung sein")
+            & setTooltip MsgCourseRegisterToTip)
                                                              (cfRegTo    <$> template)
-      <*> aopt utcTimeField           (fslpI MsgDeRegUntil   "Datum, sonst unbegr. Abmeldung"
+      <*> aopt utcTimeField           (fslpI MsgDeRegUntil   "Datum"
-            & setTooltip "Die Abmeldung darf ohne Begrenzung sein")
+            & setTooltip MsgCourseDeregisterUntilTip)
                                                              (cfDeRegUntil <$> template)
       <*  submitButton
     return $ case result of

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)
+      <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
-      <*> aopt htmlField      (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
+      <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fsb "Bewertung")                (sfType <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType)                (sfType <$> template)
-      <*> sheetGroupAFormReq  (fsb "Abgabegruppengröße") (sfGrouping <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup) (sfGrouping <$> template)
-      <*> aopt htmlField      (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking) (sfMarkingText <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
-            & 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

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

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

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]

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

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}

templates/widgets/campus-login-form.hamlet

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

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}

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}