minor gitignore

.gitignore

@@ -29,4 +29,5 @@ uniworx.nix
 src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
+.stack-work-*
 .directory

ChangeLog.md

@@ -1,3 +1,7 @@
+  * Version 06.08.2016
+  
+    Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen
+
   * Version 01.08.2018
 
     Verbesserter Campus-Login

config/settings.yml

@@ -1,29 +1,26 @@
 # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
 # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
+# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
+# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
 
 static-dir:     "_env:STATIC_DIR:static"
 host:           "_env:HOST:*4" # any IPv4 host
-port:           "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
+port:           "_env:PORT:3000"
 ip-from-header: "_env:IP_FROM_HEADER:false"
-
-# Default behavior: determine the application root from the request headers.
-# Uncomment to set an explicit approot
 approot:        "_env:APPROOT:http://localhost:3000"
 
+detailed-logging:  "_env:DETAILED_LOGGING:false"
+should-log-all:    "_env:LOG_ALL:false"
+minimum-log-level: "_env:LOGLEVEL:warn"
+auth-dummy-login:  "_env:DUMMY_LOGIN:false"
+auth-pwfile:       "_env:PWFILE:"
+allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
+
 # Optional values with the following production defaults.
-# In development, they default to the inverse.
+# In development, they default to true.
-#
-detailed-logging: "_env:DETAILED_LOGGING:false"
-should-log-all: "_env:LOG_ALL:false"
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
-auth-dummy-login: "_env:DUMMY_LOGIN:false"
-auth-pwfile: "_env:PWFILE:"
-allow-deprecated: "_env:ALLOW_DEPRECATED:false"
-
-# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
-# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -35,22 +32,21 @@ database:
   poolsize: "_env:PGPOOLSIZE:10"
 
 ldap:
-  host:     "_env:LDAPHOST:"
+  host:    "_env:LDAPHOST:"
-  tls:      "_env:LDAPTLS:"
+  tls:     "_env:LDAPTLS:"
-  port:     "_env:LDAPPORT:389"
+  port:    "_env:LDAPPORT:389"
-  user:     "_env:LDAPUSER:"
+  user:    "_env:LDAPUSER:"
-  pass:     "_env:LDAPPASS:"
+  pass:    "_env:LDAPPASS:"
-  baseDN:   "_env:LDAPBASE:"
+  baseDN:  "_env:LDAPBASE:"
-  scope:    "_env:LDAPSCOPE:WholeSubtree"
+  scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout:  "_env:LDAPTIMEOUT:5"
+  timeout: "_env:LDAPTIMEOUT:5"
 
-default-favourites: 12
+user-defaults:
-default-theme: Default
+  favourites:       12
-default-date-time-format: "%a %d %b %Y %R"
+  theme:            Default
-default-date-format: "%d.%m.%Y"
+  date-time-format: "%a %d %b %Y %R"
-default-time-format: "%R"
+  date-format:      "%d.%m.%Y"
+  time-format:      "%R"
+  download-files:   false
 
 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
-
-copyright: ©Institute for Informatics, LMU Munich
-#analytics: UA-YOURCODE

db.hs

@@ -18,6 +18,8 @@ import System.Console.GetOpt
 import System.Exit (exitWith, ExitCode(..))
 import System.IO (hPutStrLn, stderr)
 
+import qualified Data.ByteString as BS
+
 import Data.Time
 
 
@@ -46,9 +48,15 @@ main = do
       hPutStrLn stderr $ usageInfo "db.hs" argsDescr
       exitWith $ ExitFailure 2
 
+insertFile :: FilePath -> DB FileId
+insertFile fileTitle = do
+  fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle)
+  fileModified <- liftIO getCurrentTime
+  insert File{..}
+
 fillDb :: DB ()
 fillDb = do
-  AppSettings{..} <- getsYesod appSettings
+  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
   now <- liftIO getCurrentTime
   let
     summer2017 = TermIdentifier 2017 Summer
@@ -61,10 +69,11 @@ fillDb = do
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
     , userMaxFavourites = 6
-    , userTheme = Default
+    , userTheme = ThemeDefault
-    , userDateTimeFormat = appDefaultDateTimeFormat
+    , userDateTimeFormat = userDefaultDateTimeFormat
-    , userDateFormat = appDefaultDateFormat
+    , userDateFormat = userDefaultDateFormat
-    , userTimeFormat = appDefaultTimeFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
     }
   fhamann <- insert User
     { userPlugin = "LDAP"
@@ -72,11 +81,12 @@ fillDb = do
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
-    , userMaxFavourites = appDefaultMaxFavourites
+    , userMaxFavourites = userDefaultMaxFavourites
-    , userTheme = Default
+    , userTheme = ThemeDefault
-    , userDateTimeFormat = appDefaultDateTimeFormat
+    , userDateTimeFormat = userDefaultDateTimeFormat
-    , userDateFormat = appDefaultDateFormat
+    , userDateFormat = userDefaultDateFormat
-    , userTimeFormat = appDefaultTimeFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
     }
   jost <- insert User
     { userPlugin = "LDAP"
@@ -85,10 +95,11 @@ fillDb = do
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
     , userMaxFavourites = 14
-    , userTheme = MossGreen
+    , userTheme = ThemeMossGreen
-    , userDateTimeFormat = appDefaultDateTimeFormat
+    , userDateTimeFormat = userDefaultDateTimeFormat
-    , userDateFormat = appDefaultDateFormat
+    , userDateFormat = userDefaultDateFormat
-    , userTimeFormat = appDefaultTimeFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
     }
   void . insert $ User
     { userPlugin = "LDAP"
@@ -97,10 +108,11 @@ fillDb = do
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
     , userMaxFavourites = 7
-    , userTheme = AberdeenReds
+    , userTheme = ThemeAberdeenReds
-    , userDateTimeFormat = appDefaultDateTimeFormat
+    , userDateTimeFormat = userDefaultDateTimeFormat
-    , userDateFormat = appDefaultDateFormat
+    , userDateFormat = userDefaultDateFormat
-    , userTimeFormat = appDefaultTimeFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
     }
   void . insert $ Term
     { termName     = summer2017
@@ -229,10 +241,10 @@ fillDb = do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "ProMo"
-    , courseTerm = TermKey summer2017
+    , courseTerm = TermKey summer2018
     , courseSchool = ifi
     , courseCapacity = Just 50
-    , courseRegisterFrom = Nothing
+    , courseRegisterFrom = Just now
     , courseRegisterTo = Nothing
     , courseDeregisterUntil = Nothing
     , courseRegisterSecret  = Nothing
@@ -241,6 +253,28 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo
+  sh1 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Blatt 1"
+    , sheetDescription = Nothing
+    , sheetType = Normal 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    }
+  void . insert $ SheetEdit jost now sh1
+  void . insert $ SheetCorrector jost sh1 (Load (Just True) 0)
+  void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1)
+  h102 <- insertFile "H10-2.hs"
+  h103 <- insertFile "H10-3.hs"
+  pdf10 <- insertFile "ProMo_Uebung10.pdf"
+  void . insert $ SheetFile sh1 h102 SheetHint
+  void . insert $ SheetFile sh1 h103 SheetSolution
+  void . insert $ SheetFile sh1 pdf10 SheetExercise
   -- datenbanksysteme
   dbs <- insert Course
     { courseName = "Datenbanksysteme"

ghci.sh

@@ -5,4 +5,15 @@ export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
 
-exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only
+move-back() {
+    mv -v .stack-work .stack-work-ghci
+    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+}
+
+if [[ -d .stack-work-ghci ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    mv -v .stack-work-ghci .stack-work
+    trap move-back EXIT
+fi
+
+stack ghci --flag uniworx:dev --flag uniworx:library-only

messages/uniworx/de.msg

@@ -248,6 +248,8 @@ UserListTitle: Komprehensive Benutzerliste
 DateTimeFormat: Datums- und Uhrzeitformat
 DateFormat: Datumsformat
 TimeFormat: Uhrzeitformat
+DownloadFiles: Dateien automatisch herunterladen
+DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
 
 InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
 AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren

models

@@ -9,6 +9,7 @@ User json
     dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
     dateFormat     DateTimeFormat "default='%d.%m.%Y'"
     timeFormat     DateTimeFormat "default='%R'"
+    downloadFiles  Bool default=false
     UniqueAuthentication plugin ident
     UniqueEmail email
     deriving Show

package.yaml

@@ -88,6 +88,8 @@ dependencies:
 - Glob
 - ldap-client
 - connection
+- universe
+- universe-base
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Foundation.hs

@@ -352,15 +352,6 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
           _                      -> return ()
 
         return Authorized
-        
-        let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
-        case subRoute of
-          SFileR SheetExercise _ -> guard started
-          SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
-          SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
-          SubmissionR _ _        -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
-          _ -> guard started
-        return Authorized
 
       CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
         Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
@@ -515,6 +506,7 @@ instance Yesod UniWorX where
 
     defaultLayout widget = do
         master <- getYesod
+        let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
         mmsgs  <- getMessages
 
         mcurrentRoute <- getCurrentRoute
@@ -534,10 +526,10 @@ instance Yesod UniWorX where
         isAuth <- isJust <$> maybeAuthId
 
         -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
-        (favourites',show -> currentTheme) <- do
+        (favourites', currentTheme) <- do
             muid <- maybeAuthPair
             case muid of
-                Nothing         -> return ([],Default)
+                Nothing         -> return ([],userDefaultTheme)
                 (Just (uid,user)) -> do
                     favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
                         E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
@@ -644,10 +636,7 @@ instance Yesod UniWorX where
 
     -- What messages should be logged. The following includes all messages when
     -- in development, and warnings and errors in production.
-    shouldLog app _source level =
+    shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
-        appShouldLogAll (appSettings app)
-            || level == LevelWarn
-            || level == LevelError
 
     makeLogger = return . appLogger
 
@@ -1120,7 +1109,7 @@ instance YesodAuth UniWorX where
         acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
 
       $logDebugS "auth" $ tshow Creds{..}
-      AppSettings{..} <- getsYesod appSettings
+      AppSettings{ appUserDefaults = UserDefaultConf{..},  ..} <- getsYesod appSettings
 
       flip catches excHandlers $ case appLdapConf of
         Just ldapConf -> fmap (either id id) . runExceptT $ do
@@ -1154,12 +1143,15 @@ instance YesodAuth UniWorX where
               -> throwError $ ServerError "Could not decode user matriculation"
 
           let
-            userMaxFavourites = appDefaultMaxFavourites
+            newUser = User
-            userTheme = appDefaultTheme
+              { userMaxFavourites  = userDefaultMaxFavourites
-            userDateTimeFormat = appDefaultDateTimeFormat
+              , userTheme          = userDefaultTheme
-            userDateFormat = appDefaultDateFormat
+              , userDateTimeFormat = userDefaultDateTimeFormat
-            userTimeFormat = appDefaultTimeFormat
+              , userDateFormat     = userDefaultDateFormat
-            newUser = User{..}
+              , userTimeFormat     = userDefaultTimeFormat
+              , userDownloadFiles  = userDefaultDownloadFiles
+              , ..
+              }
             userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
                          , UserDisplayName =. userDisplayName
                          , UserEmail =. userEmail

src/Handler/Course.hs

@@ -187,7 +187,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
       whereClause = const $ E.val True
       validator = def
         & defaultSorting [("course", SortAsc), ("term", SortDesc)]
-  coursesTable <- makeCourseTable whereClause colonnade validator
+  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI MsgCourseListTitle
     [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
@@ -217,7 +217,7 @@ getTermCourseListR tid = do
       whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
       validator = def
         & defaultSorting [("cshort", SortAsc)]
-  coursesTable <- makeCourseTable whereClause colonnade validator
+  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
   defaultLayout $ do
     setTitleI . MsgTermCourseListTitle $ tid
     $(widgetFile "courses")

src/Handler/Home.hs

@@ -65,7 +65,7 @@ homeAnonymous = do
                         E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
             return course
 
-      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ())
+      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
           sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
@@ -77,7 +77,7 @@ homeAnonymous = do
         , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
             cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
         ]
-  courseTable <- dbTable def $ DBTable
+  ((), courseTable) <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
     , dbtProj      = return
@@ -144,7 +144,7 @@ homeUser uid = do
                                              , E.Value UTCTime
                                              , E.Value (Maybe SubmissionId)
                                              ))
-                                      (DBCell (WidgetT UniWorX IO) ())
+                                      (DBCell (HandlerT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
           sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } ->
@@ -162,7 +162,7 @@ homeUser uid = do
                                         tickmark
         ]
   let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
-  sheetTable <- dbTable validator $ DBTable
+  ((), sheetTable) <- dbTable validator $ DBTable
     { dbtSQLQuery  = tableData
     , dbtColonnade = colonnade
     , dbtProj      = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) }

src/Handler/Profile.hs

@@ -25,19 +25,23 @@ data SettingsForm = SettingsForm
       , stgDateTime      :: DateTimeFormat
       , stgDate          :: DateTimeFormat
       , stgTime          :: DateTimeFormat
+      , stgDownloadFiles :: Bool
       }
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template = identForm FIDsettings $ \html -> do
-    let themeList = [(display t,t) | t <- allThemes]
+    let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
-      <*> areq (selectFieldList themeList)
+      <*> areq (selectField . return $ mkOptionList themeList)
-            (fslpI  MsgTheme "theme-select"       ) (stgTheme         <$> template) -- TODO: pass theme-select as id-attribute or similar.
+            (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
       <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+      <*> areq checkBoxField (fslI MsgDownloadFiles
+                               & setTooltip MsgDownloadFilesTip
+                             ) (stgDownloadFiles <$> template)
       <*  submitButton
     return (result, widget) -- no validation required here
 
@@ -52,6 +56,7 @@ getProfileR = do
         , stgDateTime      = userDateTimeFormat
         , stgDate          = userDateFormat
         , stgTime          = userTimeFormat
+        , stgDownloadFiles = userDownloadFiles
         }
   ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
   case res of
@@ -62,6 +67,7 @@ getProfileR = do
                       , UserDateTimeFormat =. stgDateTime
                       , UserDateFormat     =. stgDate
                       , UserTimeFormat     =. stgTime
+                      , UserDownloadFiles  =. stgDownloadFiles
                       ]
           when (stgMaxFavourties < userMaxFavourites) $ do
             -- prune Favourites to user-defined size

src/Handler/Sheet.hs

@@ -56,6 +56,8 @@ import qualified Data.Map as Map
 import Data.Map (Map, (!), (!?))
 import qualified Data.Map as Map
 
+import Data.Monoid (Sum(..))
+
 import Control.Lens
 import Utils.Lens
 
@@ -199,7 +201,8 @@ getSheetListR tid csh = do
                     mkRoute = do
                       cid <- mkCid
                       return $ CSubmissionR tid csh sheetName cid CorrectionR
-                in anchorCellM mkRoute $(widgetFile "widgets/rating")
+                    protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
+                in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
       , sortable Nothing -- (Just "percent")
                         (i18nCell MsgRatingPercent)
           $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
@@ -214,7 +217,7 @@ getSheetListR tid csh = do
       ]          
     psValidator = def
       & defaultSorting [("submission-since", SortAsc)]
-  table <- dbTable psValidator $ DBTable
+  (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
     { dbtSQLQuery  = sheetData
     , dbtColonnade = sheetCol
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
@@ -248,19 +251,6 @@ getSheetListR tid csh = do
     , 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")
@@ -301,7 +291,7 @@ getSShowR tid csh shn = do
         ]
   let psValidator = def
         & defaultSorting [("type", SortAsc), ("path", SortAsc)]
-  fileTable <- dbTable psValidator $ DBTable
+  ((), fileTable) <- dbTable psValidator $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles
     , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
@@ -357,7 +347,8 @@ getSFileR tid csh shn typ title = do
   case results of
     [(E.Value fileTitle, E.Value fileContent)]
       | Just fileContent' <- fileContent -> do
-          addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          whenM downloadFiles $
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
           return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
       | otherwise -> sendResponseStatus noContent204 ()
     [] -> notFound

src/Handler/Submission.hs

@@ -246,7 +246,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
   maySubmit <- (== Authorized) <$> isAuthorized actionUrl True
 
   -- Maybe construct a table to display uploaded archive files
-  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
+  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
       colonnadeFiles cid = mconcat
         [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
               Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
@@ -299,7 +299,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
                         ]
         , dbtFilter = []
         }
-  mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+  mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
 
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid csh shn
@@ -335,7 +335,8 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
         let fileName = Text.pack $ takeFileName path
         case results of
           [Entity _ File{ fileContent = Just c, fileTitle }] -> do
-            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+            whenM downloadFiles $ 
+              addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
             return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
           [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
           other -> do

src/Handler/Term.hs

@@ -78,7 +78,7 @@ getTermShowR = do
 --                       #{termToText termName}
 --                 |]
 --           ]
-      table <- dbTable def $ DBTable
+      ((), table) <- dbTable def $ DBTable
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms
         , dbtProj = return . dbrOutput

src/Handler/Users.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 
 module Handler.Users where
 
@@ -12,6 +12,8 @@ import Import
 -- import Data.Text
 import Handler.Utils
 
+import Utils.Lens
+
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -29,7 +31,7 @@ hijackUserForm uid csrf = do
 getUsersR :: Handler Html
 getUsersR = do
   let
-    colonnadeUsers = dbColonnade . mconcat $
+    dbtColonnade = dbColonnade . mconcat $
       [ dbRow
       , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
           (AdminUserR <$> encrypt uid)
@@ -40,32 +42,28 @@ getUsersR = do
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
-      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
+      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-          { dbCellContents = do
+          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
-              schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
+            E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
-                E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
+            E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
-                E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+            E.orderBy [E.asc $ school E.^. SchoolShorthand]
-                E.orderBy [E.asc $ school E.^. SchoolShorthand]
+            return $ school E.^. SchoolShorthand
-                return $ school E.^. SchoolShorthand
+          return [whamlet|
-              return [whamlet|
+            <ul .list--inline .list--comma-separated>
-                  <ul .list--inline .list--comma-separated>
+              $forall (E.Value sh) <- schools
-                    $forall (E.Value sh) <- schools
+                <li>#{sh}
-                      <li>#{sh}
+            |]
-                |]
+      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
-          }
+          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
-      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty
+            E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
-          { dbCellContents = do
+            E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
-              schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
+            E.orderBy [E.asc $ school E.^. SchoolShorthand]
-                E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
+            return $ school E.^. SchoolShorthand
-                E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+          return [whamlet|
-                E.orderBy [E.asc $ school E.^. SchoolShorthand]
+            <ul .list--inline .list--comma-separated>
-                return $ school E.^. SchoolShorthand
+              $forall (E.Value sh) <- schools
-              return [whamlet|
+                <li>#{sh}
-                  <ul .list--inline .list--comma-separated>
+            |]
-                    $forall (E.Value sh) <- schools
-                      <li>#{sh}
-                |]
-          }
       , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
           (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
           cID <- encrypt uid
@@ -77,9 +75,9 @@ getUsersR = do
     psValidator = def
       & defaultSorting [("display-name", SortAsc)]
   
-  userList <- dbTable psValidator $ DBTable
+  ((), userList) <- dbTable psValidator $ DBTable
     { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
-    , dbtColonnade = colonnadeUsers
+    , dbtColonnade
     , dbtProj      = return
     , dbtSorting   = Map.fromList
         [ ( "display-name"

src/Handler/Utils.hs

@@ -2,13 +2,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 
 
 module Handler.Utils
   ( module Handler.Utils
   ) where
 
-
+import Import
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
@@ -21,3 +22,13 @@ import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
 import Handler.Utils.Sheet      as Handler.Utils
 import Handler.Utils.Templates  as Handler.Utils
+
+
+downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
+downloadFiles = do
+  mauth <- liftHandlerT maybeAuth
+  case mauth of
+    Just (Entity _ User{..}) -> return userDownloadFiles
+    Nothing -> do
+      AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+      return userDefaultDownloadFiles

src/Handler/Utils/DateTime.hs

@@ -57,7 +57,7 @@ getTimeLocale = getTimeLocale' <$> languages
 getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
 getDateTimeFormat sel = do
   mauth <- liftHandlerT maybeAuth
-  AppSettings{..} <- getsYesod appSettings
+  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
   let
     fmt
       | Just (Entity _ User{..}) <- mauth
@@ -67,9 +67,9 @@ getDateTimeFormat sel = do
           SelFormatTime     -> userTimeFormat
       | otherwise
       = case sel of
-          SelFormatDateTime -> appDefaultDateTimeFormat
+          SelFormatDateTime -> userDefaultDateTimeFormat
-          SelFormatDate     -> appDefaultDateFormat
+          SelFormatDate     -> userDefaultDateFormat
-          SelFormatTime     -> appDefaultTimeFormat
+          SelFormatTime     -> userDefaultTimeFormat
   return fmt
 
 validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat

src/Handler/Utils/Table/Pagination.hs

@@ -40,6 +40,7 @@ module Handler.Utils.Table.Pagination
   , dbRow, dbSelect
   , (&)
   , module Control.Monad.Trans.Maybe
+  , module Colonnade
   ) where
 
 import Handler.Utils.Table.Pagination.Types
@@ -124,6 +125,86 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
         | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
         | otherwise = go (acc, is' . (i:)) is
 
+data PaginationSettings = PaginationSettings
+  { psSorting      :: [(CI Text, SortDirection)]
+  , psFilter       :: Map (CI Text) [Text]
+  , psLimit        :: Int64
+  , psPage         :: Int64
+  , psShortcircuit :: Bool
+  }
+
+makeClassy_ ''PaginationSettings
+
+instance Default PaginationSettings where
+  def = PaginationSettings
+    { psSorting      = []
+    , psFilter       = Map.empty
+    , psLimit        = 50
+    , psPage         = 0
+    , psShortcircuit = False
+    }
+
+data PaginationInput = PaginationInput
+  { piSorting      :: Maybe [(CI Text, SortDirection)]
+  , piFilter       :: Maybe (Map (CI Text) [Text])
+  , piLimit        :: Maybe Int64
+  , piPage         :: Maybe Int64
+  , piShortcircuit :: Bool
+  }
+
+makeClassy_ ''PaginationInput
+
+piIsUnset :: PaginationInput -> Bool
+piIsUnset PaginationInput{..} = and
+  [ isNothing piSorting
+  , isNothing piFilter
+  , isNothing piLimit
+  , isNothing piPage
+  , not piShortcircuit
+  ]
+
+newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
+
+instance Default (PSValidator m x) where
+  def = PSValidator $ \DBTable{..} -> \case
+    Nothing -> def
+    Just pi -> swap . (\act -> execRWS act pi def) $ do
+      asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
+      asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
+      
+      l <- asks piLimit
+      case l of
+        Just l'
+          | l' <= 0   -> tell . pure $ SomeMessage MsgPSLimitNonPositive
+          | otherwise -> modify $ \ps -> ps { psLimit = l' }
+        Nothing -> return ()
+
+      asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
+      asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
+
+defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
+defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piFilter of
+      Just _  -> id
+      Nothing -> set (_2._psFilter) psFilter
+
+defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
+defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piSorting of
+      Just _  -> id
+      Nothing -> set (_2._psSorting) psSorting
+
+restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
+restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
+
+restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
+restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
 
 data DBRow r = DBRow
   { dbrOutput :: r
@@ -173,82 +254,6 @@ data DBTable m x = forall a r r' h i t.
   , dbtIdent :: i
   }
 
-
-data PaginationSettings = PaginationSettings
-  { psSorting      :: [(CI Text, SortDirection)]
-  , psFilter       :: Map (CI Text) [Text]
-  , psLimit        :: Int64
-  , psPage         :: Int64
-  , psShortcircuit :: Bool
-  }
-
-instance Default PaginationSettings where
-  def = PaginationSettings
-    { psSorting      = []
-    , psFilter       = Map.empty
-    , psLimit        = 50
-    , psPage         = 0
-    , psShortcircuit = False
-    }
-
-data PaginationInput = PaginationInput
-  { piSorting      :: Maybe [(CI Text, SortDirection)]
-  , piFilter       :: Maybe (Map (CI Text) [Text])
-  , piLimit        :: Maybe Int64
-  , piPage         :: Maybe Int64
-  , piShortcircuit :: Bool
-  }
-
-piIsUnset :: PaginationInput -> Bool
-piIsUnset PaginationInput{..} = and
-  [ isNothing piSorting
-  , isNothing piFilter
-  , isNothing piLimit
-  , isNothing piPage
-  , not piShortcircuit
-  ]
-
-newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
-
-instance Default (PSValidator m x) where
-  def = PSValidator $ \DBTable{..} -> \case
-    Nothing -> def
-    Just pi -> swap . (\act -> execRWS act pi def) $ do
-      asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
-      asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
-      
-      l <- asks piLimit
-      case l of
-        Just l'
-          | l' <= 0   -> tell . pure $ SomeMessage MsgPSLimitNonPositive
-          | otherwise -> modify $ \ps -> ps { psLimit = l' }
-        Nothing -> return ()
-
-      asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
-      asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
-
-defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
-defaultFilter psFilter (runPSValidator -> f) = PSValidator g
-  where
-    g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
-    g dbTable x = f dbTable x
-
-defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
-defaultSorting psSorting (runPSValidator -> f) = PSValidator g
-  where
-    g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
-    g dbTable x = f dbTable x
-
-restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
-restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
-  where
-    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
-
-restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
-restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
-  where
-    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
-
 class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
   type DBResult m x :: *
   -- type DBResult' m x :: *
@@ -267,46 +272,46 @@ cellAttrs = dbCell . _1
 cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
 cellContents = dbCell . _2
 
-instance IsDBTable (WidgetT UniWorX IO) () where
+instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
-  type DBResult (WidgetT UniWorX IO) () = Widget
+  type DBResult (HandlerT UniWorX IO) x = (x, Widget)
   -- type DBResult' (WidgetT UniWorX IO) () = ()
 
-  data DBCell (WidgetT UniWorX IO) () = WidgetCell
+  data DBCell (HandlerT UniWorX IO) x = WidgetCell
     { wgtCellAttrs :: [(Text, Text)]
-    , wgtCellContents :: Widget
+    , wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
     }
 
   dbCell = iso
-    (\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents))
+    (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
-    (\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget)
+    (\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
   
   -- dbWidget Proxy Proxy = iso (, ()) $ view _1
-  dbWidget _ = return
+  dbWidget _ = return . snd
-  dbHandler _ f x = return $ f x
+  dbHandler _ f = return . over _2 f
-  runDBTable = return . join . fmap (view _2)
+  runDBTable act = liftHandlerT act
 
-instance Monoid (DBCell (WidgetT UniWorX IO) ()) where
+instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
-  mempty = WidgetCell mempty mempty
+  mempty = WidgetCell mempty $ return mempty
-  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c')
+  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
 
-instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
+instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
-  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget
+  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
 
-  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell
+  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
     { dbCellAttrs :: [(Text, Text)]
-    , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
+    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
     }
 
   dbCell = iso
-    (\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
+    (\DBCell{..} -> (dbCellAttrs, dbCellContents))
-    (\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
+    (\(attrs, mkWidget) -> DBCell attrs mkWidget)
 
-  dbWidget _ = return
+  dbWidget _ = return . snd
-  dbHandler _ f x = return $ f x
+  dbHandler _ f = return . over _2 f
   -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
-  runDBTable = fmap snd . mapReaderT liftHandlerT
+  runDBTable = mapReaderT liftHandlerT
 
-instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) where
+instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
   mempty = DBCell mempty $ return mempty
   (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
 
@@ -368,7 +373,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     
   psResult <- runInputGetResult $ PaginationInput
     <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
-    <*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
+    <*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
     <*> iopt intField (wIdent "pagesize")
     <*> iopt intField (wIdent "page")
     <*> ireq checkBoxField (wIdent "table-only")
@@ -450,9 +455,9 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
 
 --- DBCell utility functions
 
-widgetColonnade :: Headedness h
+widgetColonnade :: (Headedness h, Monoid x)
-                => Colonnade h r (DBCell (WidgetT UniWorX IO) ())
+                => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-                -> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
+                -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
 widgetColonnade = id
 
 formColonnade :: (Headedness h, Monoid a)
@@ -460,9 +465,9 @@ formColonnade :: (Headedness h, Monoid a)
               -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
 formColonnade = id
 
-dbColonnade :: Headedness h
+dbColonnade :: (Headedness h, Monoid x)
-            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
 dbColonnade = id
 
 cell :: IsDBTable m a => Widget -> DBCell m a

src/Import/NoFoundation.hs

@@ -21,3 +21,5 @@ import Data.UUID              as Import (UUID)
 import Text.Lucius            as Import
 
 import Text.Shakespeare.Text  as Import hiding (text, stext)
+
+import Data.Universe          as Import

src/Model/Types.hs

@@ -16,11 +16,15 @@ import ClassyPrelude
 import Utils
 import Control.Lens
 
-import Data.Map (Map)
-import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Fixed
+import Data.Monoid (Sum(..))
+import Data.Maybe (fromJust)
+import Data.Universe
+import Data.Universe.Helpers
+
+import Text.Read (readMaybe)
 
 import Database.Persist.TH
 import Database.Persist.Class
@@ -31,17 +35,17 @@ import Web.HttpApiData
 import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-
+import qualified Data.Text.Lens as Text
-import Text.Read (readMaybe,readsPrec)
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import Yesod.Core.Dispatch (PathPiece(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
-import Data.Aeson.TH (deriveJSON, defaultOptions)
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
 
 import GHC.Generics (Generic)
+import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
 import Data.Typeable (Typeable)
 
 import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
@@ -77,29 +81,24 @@ deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON "SheetType"
 
 data SheetTypeSummary = SheetTypeSummary
-  { sumBonusPoints  :: Points
+  { sumBonusPoints  :: Sum Points
-  , sumNormalPoints :: Points
+  , sumNormalPoints :: Sum Points
-  , numPassSheets   :: Int
+  , numPassSheets   :: Sum Int
-  , numNotGraded    :: Int
+  , numNotGraded    :: Sum Int
-  , achievedBonus   :: Maybe Points
+  , achievedBonus   :: Maybe (Sum Points)
-  , achievedNormal  :: Maybe Points
+  , achievedNormal  :: Maybe (Sum Points)
-  , achievedPasses  :: Maybe Int
+  , achievedPasses  :: Maybe (Sum Int)
-  }
+  } deriving (Generic)
 
+instance Monoid SheetTypeSummary where
+  mempty = gmemptydefault
+  mappend = gmappenddefault
 
-emptySheetTypeSummary :: SheetTypeSummary
+sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
-emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing
+sheetTypeSum (Bonus{..},  achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
-
+sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
--- TODO: refactor with lenses!
+sheetTypeSum (Pass{..},   achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
-sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
-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
@@ -110,19 +109,19 @@ data SheetGroup
 deriveJSON defaultOptions ''SheetGroup
 derivePersistFieldJSON "SheetGroup"
 
-enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a
-enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
-
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
 
+instance Universe SheetFileType where universe = universeDef
+instance Finite SheetFileType
+
 instance PathPiece SheetFileType where
   toPathPiece SheetExercise = "file"
   toPathPiece SheetHint     = "hint"
   toPathPiece SheetSolution = "solution"
   toPathPiece SheetMarking  = "marking"
-  fromPathPiece = enumFromPathPiece
+  fromPathPiece = finiteFromPathPiece
 
 -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
 instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
@@ -151,6 +150,9 @@ partitionFileType fts =
 data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
+instance Universe SubmissionFileType where universe = universeDef
+instance Finite SubmissionFileType
+
 submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
 submissionFileTypeIsUpdate SubmissionOriginal  = False
 submissionFileTypeIsUpdate SubmissionCorrected = True
@@ -162,7 +164,7 @@ isUpdateSubmissionFileType True  = SubmissionCorrected
 instance PathPiece SubmissionFileType where
   toPathPiece SubmissionOriginal  = "original"
   toPathPiece SubmissionCorrected = "corrected"
-  fromPathPiece = enumFromPathPiece
+  fromPathPiece = finiteFromPathPiece
 
 instance DisplayAble SubmissionFileType where
   display SubmissionOriginal  = "Abgabe"
@@ -322,38 +324,43 @@ data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
 
+data Theme
+  = ThemeDefault
+  | ThemeLavender
+  | ThemeNeutralBlue
+  | ThemeAberdeenReds
+  | ThemeMossGreen
+  | ThemeSkyLove
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
 
--- Skins / Themes
+deriveJSON defaultOptions
-data Theme       --Simply add Themes to this type only. CamelCase will be converted to "-lower"
+  { constructorTagModifier = fromJust . stripPrefix "Theme"
-  = Default
+  } ''Theme
-  | Lavender
-  | NeutralBlue
-  | AberdeenReds -- e.g. turned into "theme--aberdeen-reds"
-  | MossGreen
-  | SkyLove
-  deriving (Eq,Ord,Bounded,Enum)
 
-$(deriveJSON defaultOptions ''Theme)
+instance Universe Theme where universe = universeDef
-$(deriveShowWith uncamel ''Theme)                             -- show    for internal use in css/js
+instance Finite Theme
-$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user
 
-allThemes :: [Theme]
+instance PathPiece Theme where
-allThemes = [minBound..maxBound]
+  toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  fromPathPiece = finiteFromPathPiece
 
-readTheme :: Map String Theme
+$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
-readTheme = Map.fromList [ (show t,t) | t <- allThemes ]
+  
+-- derivePersistFieldJSON "Theme" -- Preferred Version
+-- Backwards-compatibility until database versioning is implemented (#120):
+instance PersistField Theme where
+  toPersistValue = PersistText . ("theme--" <>) . toPathPiece
+  fromPersistValue (PersistText t) = do
+    pp <- case Text.stripPrefix "theme--" t of
+      Just pp -> return pp
+      Nothing -> Left "Expected 'theme--'-Prefix"
+    case fromPathPiece pp of
+      Just th -> return th
+      Nothing -> Left "Could not parse PathPiece"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
 
-instance Read Theme where -- generic Read-Instance for Show/Bounded
+instance PersistFieldSql Theme where
-  readsPrec _ s
+  sqlType _ = SqlString
-    | (Just t) <- (Map.lookup s readTheme) = [(t,"")]
-    | otherwise = [(Default,"")] -- read shall always succeed
-
-{-
-instance Default Theme where
-  def = Default
--}
-
-derivePersistField "Theme"
 
 
 newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
@@ -383,6 +390,9 @@ instance PersistField (CI String) where
 instance PersistFieldSql (CI Text) where
   sqlType _ = SqlOther "citext"
 
+instance PersistFieldSql (CI String) where
+  sqlType _ = SqlOther "citext"
+
 instance ToJSON a => ToJSON (CI a) where
   toJSON = toJSON . CI.original
 

src/Settings.hs

@@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
+import Utils
+import Control.Lens
+
+import Data.Maybe (fromJust)
+import qualified Data.Char as Char
+
 import Model
 
 -- | Runtime settings to configure this application. These settings can be
@@ -42,6 +48,7 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appLdapConf               :: Maybe LdapConf
+    -- ^ Configuration settings for accessing the LDAP-directory
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -63,29 +70,37 @@ data AppSettings = AppSettings
     -- ^ Assume that files in the static dir may change after compilation
     , appSkipCombining          :: Bool
     -- ^ Perform no stylesheet/script combining
-
-    , appDefaultTheme           :: Theme
-    , appDefaultMaxFavourites   :: Int
-    , appDefaultDateTimeFormat  :: DateTimeFormat
-    , appDefaultDateFormat      :: DateTimeFormat
-    , appDefaultTimeFormat      :: DateTimeFormat
-
-    -- Example app-specific configuration values.
-    , appCopyright              :: Text
-    -- ^ Copyright text to appear in the footer of the page
-    , appAnalytics              :: Maybe Text
-    -- ^ Google Analytics code
-    , appCryptoIDKeyFile        :: FilePath
-
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
-    , appAuthPWFile             :: Maybe FilePath
-    -- ^ If set authenticate against a local password file
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
+    , appAuthPWFile             :: Maybe FilePath
+    -- ^ If set authenticate against a local password file
+    , appMinimumLogLevel        :: LogLevel
 
+    , appUserDefaults           :: UserDefaultConf
+
+    , appCryptoIDKeyFile        :: FilePath
     }
 
+data UserDefaultConf = UserDefaultConf
+  { userDefaultTheme :: Theme
+  , userDefaultMaxFavourites :: Int
+  , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
+  , userDefaultDownloadFiles :: Bool
+  }
+
+instance FromJSON UserDefaultConf where
+  parseJSON = withObject "UserDefaultConf" $ \o -> do
+    userDefaultTheme          <- o .: "theme"
+    userDefaultMaxFavourites  <- o .: "favourites"
+    userDefaultDateTimeFormat <- o .: "date-time-format"
+    userDefaultDateFormat     <- o .: "date-format"
+    userDefaultTimeFormat     <- o .: "time-format"
+    userDefaultDownloadFiles  <- o .: "download-files"
+
+    return UserDefaultConf{..}
+
 data LdapConf = LdapConf
   { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
   , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
@@ -115,6 +130,13 @@ instance FromJSON LdapConf where
         ldapTimeout <- o .: "timeout"
         return LdapConf{..}
 
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
+    , sumEncoding = UntaggedValue
+    }
+  ''LogLevel
+
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -128,7 +150,7 @@ instance FromJSON AppSettings where
         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"
+        appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
@@ -136,24 +158,18 @@ instance FromJSON AppSettings where
 
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
+        appMinimumLogLevel        <- o .:  "minimum-log-level"
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
+        appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
+        appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
+        appAuthPWFile             <- assertM (not . null) <$> o .:? "auth-pwfile"
 
-        appDefaultMaxFavourites   <- o .:  "default-favourites"
+        appUserDefaults           <- o .:  "user-defaults"
-        appDefaultTheme           <- o .:  "default-theme"
-        appDefaultDateTimeFormat  <- o .:  "default-date-time-format"
-        appDefaultDateFormat      <- o .:  "default-date-format"
-        appDefaultTimeFormat      <- o .:  "default-time-format"
 
-        appCopyright              <- o .:  "copyright"
-        appAnalytics              <- o .:? "analytics"
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 
-        appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= defaultDev
-        appAuthPWFile             <- ((\f -> f <$ guard (not $ null f)) =<<) <$> o .:? "auth-pwfile"
-        appAllowDeprecated        <- o .:? "allow-deprecated"      .!= defaultDev
-
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and

src/Utils.hs

@@ -25,6 +25,7 @@ import qualified Data.CaseInsensitive as CI
 import Utils.DB as Utils
 import Utils.Common as Utils
 import Utils.DateTime as Utils
+import Utils.PathPiece as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -109,24 +110,6 @@ withFragment :: ( Monad m
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
 
-uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
-uncamel = ("theme-" ++) . reverse . foldl helper []
-  where
-    helper _   '.' = []
-    helper acc  c
-      | Char.isSpace c = acc
-      | Char.isUpper c = Char.toLower c : '-' : acc
-      | otherwise      = c : acc
-
-camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
-camelSpace = reverse . foldl helper []
-  where
-    helper _   '.' = []
-    helper acc  c
-      | Char.isSpace c = acc
-      | Char.isUpper c = c : ' ' : acc
-      | otherwise      = c : acc
-
 -- Convert anything to Text, and I don't care how
 class DisplayAble a where
   display :: a -> Text
@@ -302,6 +285,12 @@ shortCircuitM sc mx my op = do
 guardM :: MonadPlus m => m Bool -> m ()
 guardM f = guard =<< f
 
+assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
+assertM f x = x >>= assertM' f
+
+assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' f x = x <$ guard (f x)
+
 -- Some Utility Functions from Agda.Utils.Monad
 -- | Monadic if-then-else.
 ifM :: Monad m => m Bool -> m a -> m a -> m a

src/Utils/Common.hs

@@ -73,7 +73,7 @@ deriveSimpleWith cls fun strOp ty = do
     genClause :: Con -> Q Clause
     genClause (NormalC name []) =
       let pats = [ConP name []]
-          body = NormalB $ LitE $ StringL $ strOp $ show $ name
+          body = NormalB $ LitE $ StringL $ strOp $ nameBase name
       in return $ Clause pats body []
     genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
 

src/Utils/PathPiece.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE NoImplicitPrelude
+  #-}
+
+module Utils.PathPiece
+  ( finiteFromPathPiece
+  , nullaryToPathPiece
+  , splitCamel
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
+import Data.Universe
+
+import qualified Data.Text as Text
+import qualified Data.Char as Char
+
+import Data.Monoid (Endo(..))
+
+finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
+finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
+  [x] -> Just x
+  _xs -> Nothing
+
+nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ
+nullaryToPathPiece nullaryType manglers = do
+  TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
+  helperName <- newName "helper"
+  let
+    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
+    toClause con = fail $ "Unsupported constructor: " ++ show con
+    helperDec = funD helperName $ map toClause constructors
+  letE [helperDec] $ varE helperName
+  where
+    mangle = appEndo (foldMap Endo manglers) . Text.pack
+  
+splitCamel :: Text -> [Text]
+splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
+  where
+    helper hadChange words thisWord [] = reverse thisWord : words
+    helper hadChange words [] (c:cs) = helper True words [c] cs
+    helper hadChange words ws@(w:ws') (c:cs)
+      | sameCategory w c
+      , null ws'         = helper False words (c:ws) cs
+      | sameCategory w c = helper hadChange words (c:ws) cs
+      | null ws'         = helper True words (c:ws) cs
+      | not hadChange    = helper True (reverse ws':words) [c,w] cs
+      | otherwise        = helper True (reverse ws:words) [c] cs
+
+    sameCategory = (==) `on` Char.generalCategory

start.sh

@@ -7,4 +7,15 @@ export DUMMY_LOGIN=true
 export ALLOW_DEPRECATED=true
 export PWFILE=users.yml
 
-exec -- stack exec -- yesod devel
+move-back() {
+    mv -v .stack-work .stack-work-run
+    [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
+}
+
+if [[ -d .stack-work-run ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
+    mv -v .stack-work-run .stack-work
+    trap move-back EXIT
+fi
+
+stack exec -- yesod devel

templates/default-layout-wrapper.hamlet

@@ -39,21 +39,9 @@ $newline never
       }
 
 
-  <body .no-js .#{currentTheme} :isAuth:.logged-in>
+  <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
     <!-- removes no-js class from body if client supports javascript -->
     <script>
       document.body.classList.remove('no-js');
 
     ^{pageBody pc}
-
-    $maybe analytics <- appAnalytics $ appSettings master
-      <script>
-        if(!window.location.href.match(/localhost/)){
-            (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
-            (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
-            m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
-            })(window,document,'script','https://www.google-analytics.com/analytics.js','ga');
-
-            ga('create', '#{analytics}', 'auto');
-            ga('send', 'pageview');
-        }

templates/profile.julius

@@ -1,6 +1,6 @@
 document.addEventListener('DOMContentLoaded', function () {
 
-  var themeSelector = document.querySelector('[placeholder="theme-select"]');
+  var themeSelector = document.querySelector('#theme-select');
   themeSelector.addEventListener('change', function() {
     // get rid of old themes on body
     var options = Array.from(themeSelector.options)
@@ -8,10 +8,10 @@ document.addEventListener('DOMContentLoaded', function () {
       document.body.classList.remove(optionToTheme(option));
     });
     // add newly selected theme
-    document.body.classList.add(optionToTheme(themeSelector.options[themeSelector.value - 1]));
+    document.body.classList.add(optionToTheme(themeSelector.selectedOptions[0]));
   });
 
   function optionToTheme(option) {
-    return optionValue = 'theme--' + option.innerText.toLowerCase().trim().replace(/\s/g, '-');
+    return optionValue = 'theme--' + option.value;
   }
 });

templates/widgets/sheetTypeSummary.hamlet

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

testdata/H10-2.hs

@@ -0,0 +1,25 @@
+{- Übung H10-2 zur Vorlesung "Programmierung und Modellierung"
+   Lehrstuhl für theoretische Informatik, LMU München
+   Steffen Jost, Leah Neukirchen
+-}
+
+import Control.Monad
+
+chainAction1 :: Monad m => a -> [(a -> m a)] -> m a
+chainAction1 = undefined -- !!! TODO !!!
+    
+chainAction2 :: Monad m => a -> [(a -> m a)] -> m a
+chainAction2 = undefined -- !!! TODO !!!
+
+chainAction3 :: Monad m => a-> [(a -> m a)] -> m a
+chainAction3 = undefined -- !!! TODO !!!
+
+
+tellOp :: (Show a, Show b) => (a -> b) -> a -> IO b
+tellOp f x = let fx = f x in do
+  putStrLn $ (show x) ++ " -> " ++ (show fx)
+  return fx
+  
+test1 :: [Int -> IO Int]  
+test1 = map tellOp [(*3),(+1),(`mod` 7),(+5),(*2)]
+  

testdata/H10-3.hs

@@ -0,0 +1,84 @@
+{-  Übung H10-3 zur Vorlesung "Programmierung und Modellierung"
+    Lehrstuhl für theoretische Informatik, LMU München
+    Steffen Jost, Leah Neukirchen
+
+    Bitte nur die Zeilen mit
+      error "TODO" -- TODO: Ihre Aufgabe !!!
+    bearbeiten.
+    (Sie dürfen an diesen Stellen auch beliebig
+    viele neue Zeilen einfügen.)
+
+    Entweder mit ghc kompilieren und ausführen oder
+    einfach in ghci laden und main auswerten.
+-}
+
+
+import Control.Monad.Trans.State
+
+type Wetter = String
+data Welt = Welt { zeit :: Int, wetter :: Wetter }
+  deriving Show
+
+main =
+  let startState = Welt { zeit=0, wetter="Regen" }
+      (result,finalState) = runState actions startState
+  in do
+    putStrLn "Zustand Welt bei Start ist: "
+    print startState
+    putStrLn "Zustand Welt bei Ende ist: "
+    print finalState
+    putStrLn "Ergebnis der Aktion ist: "
+    print result
+
+
+actions :: State Welt [(String,Int)]
+actions = do
+  tick
+  tick
+  tick
+  tick
+  wetter1 <- swapWetter "Sonne"
+  zeit1 <- gets zeit
+  let r1 = (wetter1, zeit1)
+  tick
+  tick
+  wetter2 <- swapWetter "Sturm"
+  zeit2 <- zeit <$> get
+  let r2 = (wetter2, zeit2)
+  tick
+  return [r1,r2]
+
+
+--- !!! NUR AB HIER BEARBEITEN !!!
+
+
+
+tick :: State Welt ()
+tick =
+  error "TODO: tick noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!
+
+
+
+
+swapWetter :: Wetter -> State Welt Wetter
+swapWetter =
+  error "TODO: swapWetter noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+