Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

messages/de.msg

@@ -22,6 +22,8 @@ InvalidInput: Eingaben bitte korrigieren.
 Term: Semester
 TermPlaceholder: W/S + vierstellige Jahreszahl
 
+LectureStart: Beginn Vorlesungen
+
 Course: Kurs
 CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
@@ -70,6 +72,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
 UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 
+Submission: Abgabenummer
 
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
@@ -79,11 +82,27 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
 SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt.
 
+CorrectionsTitle: Zugewiesene Korrekturen
+CourseCorrectionsTitle: Korrekturen für diesen Kurs
 
 EMail: E-Mail
 EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
 NotAParticipant user@Text tid@TermId csh@Text: #{user} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
 
+AddCorrector: Zusätzlicher Korrektor
+CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
+SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
+CountTutProp: Tutorien zählen gegen Proportion
+Corrector: Korrektor
+Correctors: Korrektoren
+CorByTut: Nach Tutorium
+CorProportion: Anteil
+DeleteRow: Zeile entfernen
+ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
+CorrectorsPlaceholder: Korrektoren...
+CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
+
 Users: Benutzer
 HomeHeading: Aktuelle Termine
 ProfileHeading: Benutzerprofil und Einstellungen
@@ -107,4 +126,20 @@ SheetSolution: Lösung
 SheetMarking: Korrekturhinweise
 
 MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
+
+NrColumn: Nr
+SelectColumn: Auswahl
+
+CorrDownload: Herunterladen
+CorrUploadField: Korrekturen
+CorrUpload: Korrekturen hochladen
+CorrSetCorrector: Korrektor zuweisen
+CorrAutoSetCorrector: Korrekturen verteilen
 NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
+
+SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
+UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
+NoCorrector: Kein Korrektor
+RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
+UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt.
+CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:

models

@@ -119,6 +119,7 @@ SheetCorrector
     sheet           SheetId
     load            Load
     UniqueSheetCorrector user sheet
+    deriving Show Eq Ord
 SheetFile
     sheet           SheetId
     file            FileId

package.yaml

@@ -81,6 +81,7 @@ dependencies:
 - exceptions
 - lens
 - MonadRandom
+- email-validate
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -51,26 +51,24 @@
   /show                       CShowR          GET             !free
   /register                   CRegisterR          POST        !time
   /edit                       CEditR          GET POST
+  /subs                       CourseCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials
   !/ex/new                    SheetNewR       GET POST
   /ex/#Text SheetR:
     /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
-    !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
     /edit                       SEditR        GET POST
     /delete                     SDelR         GET POST
-    !/sub/new                   SubmissionNewR GET POST        !timeANDregistered
+    /sub/new                   SubmissionNewR GET POST        !timeANDregistered
-    !/sub/own                   SubmissionOwnR GET             !free
+    /sub/own                   SubmissionOwnR GET             !free
+    !/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector
     !/sub/#CryptoFileNameSubmission SubmissionR    GET POST        !owner !corrector
+    !/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector
+    /correctors                 SCorrR        GET POST
+    /subs                       SSubsR        GET POST
+    !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
+/corrections  CorrectionsR GET POST !free
 
--- TODO below
-!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
-!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated
-
-/submission                 SubmissionListR GET                 !deprecated
-/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST      !deprecated
-/submissions.zip SubmissionDownloadMultiArchiveR POST           !deprecated
--- TODO above
 
 !/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
-!/*{CI FilePath} CryptoFileNameDispatchR GET                  !free
+-- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists

src/Application.hs

@@ -48,6 +48,7 @@ import Handler.Term
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
+import Handler.Corrections
 import Handler.CryptoIDDispatch
 
 

src/Foundation.hs

@@ -39,6 +39,8 @@ import Data.ByteArray (convert)
 import Crypto.Hash (Digest, SHAKE256)
 import Crypto.Hash.Conduit (sinkHash)
 
+import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
+
 import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
 import Data.ByteString (ByteString)
@@ -72,13 +74,19 @@ import Handler.Utils.DateTime
 import Control.Lens
 import Utils.Lens
 
--- -- TODO: Move me to appropriate Place
+
+-- -- TODO: Move the following to the appropriate place, if DisplayAble is kept
 instance DisplayAble TermId where
   display = termToText . unTermKey
 
 instance DisplayAble UTCTime where
   display = pack . formatTimeGerDT2 -- default Time Format to be used: 00.00.00 00:00
 
+instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where
+  display = toPathPiece -- requires import of Data.CryptoID here
+-- -- MOVE ABOVE
+
+
 -- infixl 9 :$:
 -- pattern a :$: b = a b
 
@@ -153,6 +161,9 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX String where
+  renderMessage f ls str = renderMessage f ls $ Text.pack str
+
 instance RenderMessage UniWorX SheetFileType where
   renderMessage foundation ls = \case
       SheetExercise -> renderMessage' MsgSheetExercise
@@ -565,7 +576,6 @@ instance Yesod UniWorX where
     makeLogger = return . appLogger
 
 
-
 -- Define breadcrumbs.
 instance YesodBreadcrumbs UniWorX where
   breadcrumb (AuthR _)        = return ("Login"   , Just HomeR)
@@ -595,14 +605,27 @@ instance YesodBreadcrumbs UniWorX where
   --         (CSheetR tid csh shn SFileR) -- just for Downloads
   breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit",   Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
+  breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
+  breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn SubmissionNewR)  = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn SubmissionOwnR)  = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
   breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
-  -- Deprecated below
-  breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
   -- Others
   breadcrumb  _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
 
+submissionList :: TermId -> Text -> Text -> UserId -> DB [E.Value SubmissionId]
+submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
+  E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+
+  E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
+       E.&&. sheet E.^. SheetName E.==. E.val shn
+       E.&&. course E.^. CourseShorthand E.==. E.val csh
+       E.&&. course E.^. CourseTerm E.==. E.val tid
+
+  return $ submission E.^. SubmissionId
+
 pageActions :: Route UniWorX -> [MenuTypes]
 pageActions (CourseR tid csh CShowR) =
   [ PageActionPrime $ MenuItem
@@ -627,6 +650,12 @@ pageActions (CourseR tid csh CShowR) =
             return (sheets,lecturer)
           or2M (return lecturer) $ anyM sheets sheetRouteAccess
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CourseR tid csh CourseCorrectionsR
+      , menuItemAccessCallback' = return True
+      }
   , PageActionSecondary $ MenuItem
       { menuItemLabel = "Neues Übungsblatt anlegen"
       , menuItemIcon  = Nothing
@@ -647,13 +676,33 @@ pageActions (CSheetR tid csh shn SShowR) =
       { menuItemLabel = "Abgabe anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid csh shn SubmissionNewR
-      , menuItemAccessCallback' = return True -- TODO: check that no submission already exists
+      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
+          uid <- MaybeT $ liftHandlerT maybeAuthId
+          submissions <- lift $ submissionList tid csh shn uid
+          guard $ null submissions
+          return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Abgabe ansehen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CSheetR tid csh shn SubmissionOwnR
-      , menuItemAccessCallback' = return True -- TODO: check that a submission already exists
+      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
+          uid <- MaybeT $ liftHandlerT maybeAuthId
+          submissions <- lift $ submissionList tid csh shn uid
+          guard . not $ null submissions
+          return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrektoren"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CSheetR tid csh shn SCorrR
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgaben"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CSheetR tid csh shn SSubsR
+      , menuItemAccessCallback' = return True
       }
   ]
 pageActions TermShowR =
@@ -697,7 +746,7 @@ pageActions (HomeR) =
 --   ,
     NavbarAside $ MenuItem
       { menuItemLabel = "AdminDemo"
-      , menuItemIcon  = Nothing
+      , menuItemIcon  = Just "book"
       , menuItemRoute = AdminTestR
       , menuItemAccessCallback' = return True
       }
@@ -741,6 +790,8 @@ pageHeading (CourseR tid csh CShowR)
   = Just $ do
     Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh
     toWidget courseName
+pageHeading CorrectionsR
+  = Just $ i18nHeading MsgCorrectionsTitle
 --          (CourseR tid csh CRegisterR) -- just for POST
 pageHeading (CourseR tid csh CEditR)
   = Just $ i18nHeading $ MsgCourseEditHeading tid csh

src/Handler/Corrections.hs

@@ -0,0 +1,342 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Handler.Corrections where
+
+import Import
+-- import System.FilePath (takeFileName)
+
+import Handler.Utils
+import Handler.Utils.Submission
+-- import Handler.Utils.Zip
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+--
+import Colonnade hiding (fromMaybe, singleton)
+-- import Yesod.Colonnade
+--
+-- import qualified Data.UUID.Cryptographic as UUID
+-- import qualified Data.Conduit.List as C
+
+import qualified Database.Esqueleto as E
+-- import qualified Database.Esqueleto.Internal.Sql as E
+
+import Control.Lens
+-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
+
+-- import Network.Mime
+
+import Web.PathPieces
+
+import Text.Hamlet (ihamletFile)
+import Text.Blaze.Html (preEscapedToHtml)
+
+import Database.Persist.Sql (updateWhereCount)
+
+import Data.List (genericLength)
+
+
+
+type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
+            (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
+            -> expr (E.Value Bool)
+
+ratedBy :: Key User -> CorrectionsWhere
+ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+
+courseIs :: Key Course -> CorrectionsWhere
+courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
+
+sheetIs :: Key Sheet -> CorrectionsWhere
+sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
+
+
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
+
+colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
+        $ \DBRow{ dbrOutput=(_, _, course, _) } ->
+          -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
+          textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
+
+colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
+        $ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
+          let tid = E.unValue $ course ^. _3
+              csh = E.unValue $ course ^. _2
+          in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
+
+colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
+        $ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
+          let tid = E.unValue $ course ^. _3
+              csh = E.unValue $ course ^. _2
+              shn = sheetName $ entityVal sheet
+          in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
+          -- textCell $ sheetName $ entityVal sheet
+
+colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
+  DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
+  DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
+
+colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
+        $ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
+          let tid = E.unValue $ course ^. _3
+              csh = E.unValue $ course ^. _2
+              shn = sheetName $ entityVal sheet
+          cid <- encrypt (entityKey submission :: SubmissionId)
+          [whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
+
+colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
+colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
+
+type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
+            
+makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
+                     => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCorrectionsTable whereClause colChoices psValidator = do
+  let tableData :: CorrectionTableExpr -> E.SqlQuery _
+      tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
+        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+        E.where_ $ whereClause (course,sheet,submission)
+        let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value Text)
+                    , course E.^. CourseShorthand
+                    , course E.^. CourseTerm
+                    , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
+                    )
+        return (submission, sheet, crse, corrector)
+  dbTable psValidator $ DBTable
+    { dbtSQLQuery  = tableData
+    , dbtColonnade = colChoices
+    , dbtSorting   = [ ( "term"
+                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
+                       )
+                     , ( "course"
+                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
+                       )
+                     , ( "sheet"
+                       , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+                       )
+                     , ( "corrector"
+                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
+                       )
+                     ]
+    , dbtFilter    = [ ( "term"
+                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
+                           | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                       )
+                     , ( "course"
+                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
+                           | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
+                       )
+                     , ( "sheet"
+                       , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
+                           | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
+                       )
+                     , ( "corrector"
+                       , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
+                           | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
+                                          E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+                       )
+                     ]
+    , dbtAttrs     = tableDefault
+    , dbtIdent     = "corrections" :: Text
+    }
+
+data ActionCorrections = CorrDownload
+                       | CorrSetCorrector
+                       | CorrAutoSetCorrector
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+instance PathPiece ActionCorrections where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+instance RenderMessage UniWorX ActionCorrections where
+  renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
+  renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
+  renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
+
+data ActionCorrectionsData = CorrDownloadData
+                           | CorrSetCorrectorData (Maybe UserId)
+                           | CorrAutoSetCorrectorData SheetId
+
+correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
+correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
+  ((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do
+    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
+    (actionRes, action) <- multiAction actions
+    return ((,) <$> actionRes <*> selectionRes, table <> action)
+
+  Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
+  case actionRes of
+    FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
+    FormMissing      -> return ()
+    FormSuccess (CorrDownloadData, subs) -> do
+      ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
+      addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
+      sendResponse =<< submissionMultiArchive ids
+    FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
+      subs <- mapM decrypt $ Set.toList subs'
+      runDB $ do
+        alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
+        when (not $ null alreadyAssigned) $ do
+          mr <- (toHtml . ) <$> getMessageRender
+          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
+          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+        let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
+        when (not $ null unassigned) $ do
+          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
+          addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
+      redirect currentRoute
+    FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
+      subs <- mapM decrypt $ Set.toList subs'
+      runDB $ do
+        num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
+                                                        , SubmissionRatingComment =. Nothing
+                                                        , SubmissionRatingBy =. Nothing
+                                                        , SubmissionRatingTime =. Nothing
+                                                        ]
+        addMessageI "success" $ MsgRemovedCorrections num
+      redirect currentRoute
+    FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
+      subs <- mapM decrypt $ Set.toList subs'
+      runDB $ do
+        alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
+        when (not $ null alreadyAssigned) $ do
+          mr <- (toHtml . ) <$> getMessageRender
+          alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
+          addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+        let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
+        when (not $ null unassigned) $ do
+          (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
+          when (not $ null assigned) $
+            addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
+          when (not $ null unassigned) $ do
+            mr <- (toHtml . ) <$> getMessageRender
+            unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) 
+            addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
+      redirect currentRoute
+
+  fmap toTypedContent . defaultLayout $ do
+    setTitleI MsgCourseCorrectionsTitle
+    $(widgetFile "corrections")
+
+
+type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
+  
+downloadAction :: ActionCorrections'
+downloadAction = ( CorrDownload
+                 , return (pure CorrDownloadData, Nothing)
+                 )
+
+assignAction :: Either CourseId SheetId -> ActionCorrections'
+assignAction selId = ( CorrSetCorrector
+                     , over (mapped._2) Just $ do
+                         correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
+                           E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
+                           E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+                           E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+
+                           E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
+
+                           return user
+
+                         mr <- getMessageRender
+
+                         correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
+
+                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
+                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
+                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
+                     )
+
+autoAssignAction :: SheetId -> ActionCorrections'
+autoAssignAction shid = ( CorrAutoSetCorrector
+                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
+                        )
+
+getCorrectionsR, postCorrectionsR :: Handler TypedContent
+getCorrectionsR = postCorrectionsR
+postCorrectionsR = do
+  uid <- requireAuthId
+  let whereClause = ratedBy uid
+      colonnade = mconcat
+        [ colSelect
+        , dbRow
+        , colTerm
+        , colCourse
+        , colSheet
+        , colSubmissionLink
+        ] -- Continue here
+      psValidator = def
+        & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+        & restrictSorting (\name _ -> name /= "corrector")
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    ]
+
+getCourseCorrectionsR, postCourseCorrectionsR ::  TermId -> Text -> Handler TypedContent
+getCourseCorrectionsR = postCourseCorrectionsR
+postCourseCorrectionsR tid csh = do
+  Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
+  let whereClause = courseIs cid
+      colonnade = mconcat
+        [ colSelect
+        , dbRow
+        , colSheet
+        , colCorrector
+        , colSubmissionLink
+        ] -- Continue here
+      psValidator = def
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    , assignAction (Left cid)
+    ]
+
+getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent
+getSSubsR = postSSubsR
+postSSubsR tid csh shn = do
+  shid <- runDB $ fetchSheetId tid csh shn
+  let whereClause = sheetIs shid
+      colonnade = mconcat
+        [ colSelect
+        , dbRow
+        , colCorrector
+        , colSubmissionLink
+        ]
+      psValidator = def
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    , assignAction (Right shid)
+    , autoAssignAction shid
+    ]

src/Handler/Home.hs

@@ -24,7 +24,7 @@ import Data.Time
 
 -- import Control.Lens
 import Colonnade hiding (fromMaybe, singleton)
-import Yesod.Colonnade
+-- import Yesod.Colonnade
 import qualified Database.Esqueleto as E
 
 -- import qualified Data.UUID.Cryptographic as UUID
@@ -68,10 +68,10 @@ homeAnonymous = do
             E.limit nrSheetDeadlines
             return course
 
-      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (Cell UniWorX)
+      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
-          sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
+          sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
             let tid = courseTerm course
                 csh = courseShorthand course
             cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
@@ -134,17 +134,17 @@ homeUser uid = do
           , sheet   E.^. SheetActiveTo
           )
 
-      colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (Cell UniWorX)
+      colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (DBCell (WidgetT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
-          sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } ->
+          sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } ->
             cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
-        , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } ->
+        , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } ->
             cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
-        , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
+        , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
             textCell $ display deadline
-        , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
+        , sortable (Just "done") (textCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
-            textCell $ "?"
+            textCell ("?" :: Text)
         ]
   sheetTable <- dbTable def $ DBTable
     { dbtSQLQuery  = tableData

src/Handler/Profile.hs

@@ -31,7 +31,7 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
       <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
             (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
       <*> areq (selectFieldList themeList)
-            (fslI  MsgTheme         ) (stgTheme         <$> template)
+            (fslpI  MsgTheme "theme-select"       ) (stgTheme         <$> template) -- TODO: pass theme-select as id-attribute or similar.
       <*  submitButton
     return (result, widget) -- no validation required here
 
@@ -70,7 +70,7 @@ getProfileR = do
                 E.where_ $ adright ^. UserAdminUser E.==. E.val uid
                 E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId
                 return (school ^. SchoolShorthand)
-            ) 
+            )
             <*>
             (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
                 E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid

src/Handler/Sheet.hs

@@ -8,7 +8,12 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Handler.Sheet where
 
@@ -22,9 +27,10 @@ import Handler.Utils.Zip
 import qualified Data.Text as T
 -- import Data.Function ((&))
 --
-import Colonnade hiding (fromMaybe, singleton)
+import Colonnade hiding (fromMaybe, singleton, bool)
-import Yesod.Colonnade
+import qualified Yesod.Colonnade as Yesod
---
+import Text.Blaze (text)
+-- 
 import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
@@ -32,12 +38,24 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
 import Control.Monad.Writer (MonadWriter(..), execWriterT)
+import Control.Monad.Trans.RWS.Lazy (RWST, local)
+
+import qualified Text.Email.Validate as Email
+
+import qualified Data.List as List
 
 import Network.Mime
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
+import Data.Map (Map, (!), (!?))
+import qualified Data.Map as Map
+
+import Control.Lens
+import Utils.Lens
+
 
 instance Eq (Unique Sheet) where
   (CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@@ -64,7 +82,6 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
       -- Keine SheetId im Formular!
-      , sfCorrectors   :: [(UserId,Load)]
       }
 
 
@@ -92,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> fileAFormOpt        (fsb "Hinweis")
       <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
       <*> fileAFormOpt        (fsb "Lösung")
-      <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template))
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
@@ -123,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         -- TODO: continue validation here!!!
       ] ]
 
-correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX])
-correctorForm _msid templates = return mempty -- TODO deprecated
-  -- Datenbank UserId -> UserName
-  -- Eingabelist für Colonnade
-     -- enthält die benötigten Felder
-  -- FormResult konstruieren
-  -- Eingabebox für Korrektor hinzufügen
-  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
-
-
 -- List Sheets
 getSheetListCID :: CourseId -> Handler Html
 getSheetListCID cid = getSheetList =<<
@@ -180,7 +186,7 @@ getSheetList courseEnt = do
     setTitle $ toHtml $ csh <> " Übungsblätter"
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
-      else encodeWidgetTable tableDefault colSheets sheets
+      else Yesod.encodeWidgetTable tableDefault colSheets sheets
 
 
 -- Show single sheet
@@ -211,8 +217,8 @@ getSShowR tid csh shn = do
               E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
         -- return desired columns
         return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-  let colonnadeFiles = mconcat
+  let colonnadeFiles = widgetColonnade $ mconcat
-        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> cell $ [whamlet| _{ftype}|]
+        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
         , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
                                                           (\(E.Value fName,_,_) -> str2widget fName)
         , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
@@ -303,7 +309,6 @@ getSEditR tid csh shn = do
         , sfHintF        = Nothing -- TODO
         , sfSolutionFrom = sheetSolutionFrom
         , sfSolutionF    = Nothing -- TODO
-        , sfCorrectors   = [] -- TODO read correctors from list
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
@@ -410,3 +415,201 @@ insertSheetFile' sid ftype fs = do
     finsert (Right file) = lift $ do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+
+  
+data CorrectorForm = CorrectorForm
+  { cfUserId :: UserId
+  , cfUserName :: Text
+  , cfResult :: FormResult Load
+  , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
+  }
+
+type Loads = Map UserId Load
+
+defaultLoads :: SheetId -> DB Loads
+-- ^ Generate `Loads` in such a way that minimal editing is required
+--
+-- For every user, that ever was a corrector for this course, return their last `Load`.
+-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
+defaultLoads shid = do
+  cId <- sheetCourse <$> getJust shid
+  fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
+    E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+
+    let creationTime = E.sub_select . E.from $ \sheetEdit -> do
+          E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+          return . E.min_ $ sheetEdit E.^. SheetEditTime
+
+    E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
+    
+    E.orderBy [E.desc creationTime]
+  
+    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
+  where
+    toMap :: [(E.Value UserId, E.Value Load)] -> Loads
+    toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
+
+
+correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
+correctorForm shid = do
+  cListIdent <- newFormIdent
+  let
+    guardNonDeleted :: UserId -> Handler (Maybe UserId)
+    guardNonDeleted uid = do
+      cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
+      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
+      return $ bool Just (const Nothing) (isJust deleted) uid
+  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
+  let
+    currentLoads :: DB Loads
+    currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+  (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
+  loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
+    | Map.null currentLoads'
+    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
+    | otherwise              -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
+
+  deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
+
+  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
+      didDelete = any (flip Set.member deletions) formCIDs
+
+  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
+  let
+    tutorField :: Field Handler [Text]
+    tutorField = multiEmailField
+      { fieldView = \theId name attrs val isReq -> asWidgetT $ do
+          listIdent <- newIdent
+          userId <- handlerToWidget requireAuthId
+          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
+            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+            return $ user E.^. UserEmail
+          [whamlet|
+            $newline never
+            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
+            <datalist id=#{listIdent}>
+              $forall E.Value prev <- previousCorrectors
+                <option value=#{prev}>
+          |]
+      }
+  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
+
+  loads <- case addTutRes of
+    FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
+      mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
+      case mUid of
+        Nothing  -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
+        Just uid
+          | not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
+          | otherwise                   -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
+    FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
+    _ -> return loads''
+
+  let deletions' = deletions `Set.difference` Map.keysSet loads
+  
+  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
+    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
+    return $ (user E.^. UserId, user E.^. UserDisplayName)
+    
+  let
+    constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
+    constructFields (uid, uname, Load{..}) = do
+      cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
+      let
+        fs name = ""
+          { fsName = Just $ tshow ciphertext <> "-" <> name
+          }
+        rationalField = convertField toRational fromRational doubleField
+
+      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
+      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
+      let
+        cfResult :: FormResult Load
+        cfResult = Load <$> tutRes' <*> propRes
+        tutRes'
+          | FormSuccess True <- byTutRes  = Just <$> countTutRes
+          | otherwise                     = Nothing <$ byTutRes
+        cfUserId = uid
+        cfUserName = uname
+      return CorrectorForm{..}
+
+  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
+
+  mr <- getMessageRender
+
+  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
+
+  let
+    corrColonnade = mconcat
+      [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+      , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
+      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
+      , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
+      ]
+    corrResults
+      | FormSuccess (Just es) <- addTutRes
+      , not $ null es = FormMissing
+      | didDelete = FormMissing
+      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
+                                                  | CorrectorForm{..} <- corrData
+                                                  ]
+    idField CorrectorForm{..} = do
+      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
+
+    delField uid = do
+      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
+
+  return (corrResults, [ countTutView
+                       , FieldView
+                           { fvLabel = text $ mr MsgCorrectors
+                           , fvTooltip = Nothing
+                           , fvId = ""
+                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
+                           , fvErrors = Nothing
+                           , fvRequired = True
+                           }
+                       , addTutView
+                           { fvInput = [whamlet|
+                               <div>
+                                 ^{fvInput addTutView}
+                                 <button type=submit formnovalidate data-formnorequired>Hinzufügen
+                             |]
+                           }
+                       ])
+  
+  -- Eingabebox für Korrektor hinzufügen
+  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+
+getSCorrR, postSCorrR :: TermId
+                      -> Text -- ^ Course shorthand
+                      -> Text -- ^ Sheet name
+                      -> Handler Html
+postSCorrR = getSCorrR
+getSCorrR tid@(unTermKey -> tident) csh shn = do
+  Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
+
+  ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+
+  case res of
+    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormSuccess res -> runDB $ do
+      deleteWhere [SheetCorrectorSheet ==. shid]
+      insertMany_ $ Set.toList res
+      addMessageI "success" MsgCorrectorsUpdated
+    FormMissing -> return ()
+
+  let
+    formTitle = MsgSheetCorrectorsTitle tident csh shn
+    formText  = Nothing :: Maybe (SomeMessage UniWorX)
+    actionUrl = CSheetR tid csh shn SCorrR
+    -- actionUrl = CSheetR tid csh shn SShowR
+  defaultLayout $ do
+    setTitleI $ MsgSheetCorrectorsTitle tident csh shn
+    $(widgetFile "formPageI18n")

src/Handler/Submission.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 module Handler.Submission where
 
@@ -49,7 +50,7 @@ import Data.Bifunctor
 import System.FilePath
 
 import Colonnade hiding (bool)
-import Yesod.Colonnade
+import qualified Yesod.Colonnade as Yesod
 import qualified Text.Blaze.Html5.Attributes as HA
 
 
@@ -204,7 +205,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
             (Nothing, Just smid)   -- no new files, existing submission partners updated
               -> return smid
             (Just files, _)  -- new files
-              -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid)
+              -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False
             _ -> error "Impossible, because of definition of `makeSubmissionForm`"
           -- Determine members of pre-registered group
           groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
@@ -236,9 +237,10 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
   let formText  = Nothing :: Maybe UniWorXMessage
   actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
   -- Maybe construct a table to display uploaded archive files
-  let colonnadeFiles cid = mconcat
+  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
+      colonnadeFiles cid = mconcat
         -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
-        [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
+        [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle)
                                                           (\(Entity _ File{..}) -> str2widget fileTitle)
         , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
         ]
@@ -265,7 +267,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
       $maybe arCid <- mArCid
         <hr>
         <h2>
-          <a href=@{SubmissionDownloadArchiveR arCid}>Archiv
+          <a href=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv
         $forall (name,time) <- lastEdits
           <div>last edited by #{name} at #{formatTimeGerDTlong time}
         $maybe fileTable <- mFileTable
@@ -274,26 +276,15 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
     |]
 
 
-
+getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent
-
+getSubmissionDownloadSingleR tid csh shn cID path = do
-
-submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
-submissionFileSource = E.selectSource . E.from . submissionFileQuery
-
-submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
-                        -> E.SqlQuery (E.SqlExpr (Entity File))
-submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
-  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
-  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
-  return f
-
-getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
-getSubmissionDownloadSingleR cID path = do
   submissionID <- decrypt cID
 
   runDB $ do
+    shid <- fetchSheetId tid csh shn
+    Submission{..} <- get404 submissionID
+    when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
+
     isRating <- maybe False (== submissionID) <$> isRatingFile path
     case isRating of
       True  -> do
@@ -311,202 +302,24 @@ getSubmissionDownloadSingleR cID path = do
 
         let fileName = Text.pack $ takeFileName path
         case results of
-          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
+          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
           _ -> notFound
 
-getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent
+getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent
-getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
+getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
   submissionID <- decrypt cID
   cUUID <- encrypt submissionID
   respondSourceDB "application/zip" $ do
+    lift $ do
+      shid <- fetchSheetId tid csh shn
+      Submission{..} <- get404 submissionID
+      when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
+
     rating <- lift $ getRating submissionID
     case rating of
       Nothing -> lift notFound
       Just rating' -> do
         let fileEntitySource' :: Source (YesodDB UniWorX) File
             fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
-            info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
+            info = ZipInfo { zipComment = Text.encodeUtf8 . pack . CI.foldedCase $ ciphertext (cUUID :: CryptoFileNameSubmission) }
         fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
-
-
-
-
-
-
-
------------------------------------------------------------------------------------------------
-------------------------- DEMO BELOW
-
-
-submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
-submissionTable = do
-  subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-    E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
-    E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
-
-    return (sub, sheet, course)
-
-  cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
-    (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
-
-  let
-    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
-    courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
-    anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
-    submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
-    colonnade = mconcat
-      [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
-      , headed "Kurs" $ anchorCell anchorCourse courseText
-      , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
-      ]
-    toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
-    toExternal (_, cID, _) = return cID
-    fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
-    fromExternal = decrypt
-  headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
-
-
-getSubmissionListR, postSubmissionListR :: Handler Html
-getSubmissionListR = postSubmissionListR
-postSubmissionListR = do
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField "Dies sind Korrekturen" (Just False)
-    <*> fileAFormReq "Archiv"
-    <*  submitButton
-
-  runDB $ do
-    case uploadResult of
-      FormMissing -> return ()
-      FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren."
-      FormSuccess (isUpdate, fInfo) -> do
-        userId <- lift requireAuthId
-        let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) ()
-            feed sId val = do
-              mSink <- gets $ Map.lookup sId
-              sink <- case mSink of
-                Just sink -> return sink
-                Nothing -> do
-                  Submission{..} <- lift $ get404 sId
-                  return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate))
-              sink' <- lift $ yield val ++$$ sink
-              case sink' of
-                Left _ -> error "sinkSubmission returned prematurely"
-                Right nSink -> modify $ Map.insert sId nSink
-            sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) ()
-            sinkSubmissions = do
-              sinks <- execStateC Map.empty . awaitForever $ \case
-                v@(Right (sId, _)) -> lift $ feed sId v
-                (Left f@File{..})  -> case splitDirectories fileTitle of
-                  (cID:rest) 
-                    | not (null rest) -> do
-                        sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
-                        lift . feed sId $ Left f{ fileTitle = joinPath rest }
-                    | otherwise -> return ()
-                  [] -> invalidArgs ["Encountered file/directory with empty name"]
-              lift $ mapM_ (void . closeResumableSink) sinks
-                  
-        runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions
- 
-  (subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
-
-  defaultLayout $(widgetFile "submission-list")
-
-
-
-postSubmissionDownloadMultiArchiveR :: Handler TypedContent
-postSubmissionDownloadMultiArchiveR = do
-  ((selectResult, _), _) <- runFormPost . withFragment $ submissionTable
-
-  case selectResult of
-    FormMissing -> invalidArgs ["Missing submission numbers"]
-    FormFailure errs -> invalidArgs errs
-    FormSuccess ids -> do
-      (dbrunner, cleanup) <- getDBRunner
-
-      ratedSubmissions <- runDBRunner dbrunner $ do
-        submissions <- selectList [ SubmissionId <-. ids ] []
-        forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
-  
-      (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
-        let
-          fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
-          fileEntitySource' (rating, Entity submissionID Submission{..}) = do
-            cID <- encrypt submissionID
-
-            let
-              directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
-              
-              fileEntitySource = do
-                submissionFileSource submissionID =$= Conduit.map entityVal
-                yieldM (ratingFile cID rating)
-
-              withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
-
-            lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
-            lastEditTime <- case lastEditMb of
-                [(submissionEditTime.entityVal -> time)] -> return time
-                _other -> liftIO getCurrentTime
-            yield $ File
-              { fileModified = lastEditTime
-              , fileTitle = directoryName
-              , fileContent = Nothing
-              }
-
-            fileEntitySource =$= mapC withinDirectory
-          
-        mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
-
-
-
-
-
-getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
-getSubmissionDemoR = postSubmissionDemoR
-postSubmissionDemoR cID = do
-  submissionId <- decrypt cID
-  
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
-    <*> fileAFormReq "Datei"
-    <*  submitButton
-
-  (submission, files) <- runDB $ do
-    submission <- do
-      submission@Submission{..} <- get404 submissionId
-      case uploadResult of
-        FormMissing -> return submission
-        FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren."
-        FormSuccess (isUpdate, fInfo) -> do
-          userId <- lift requireAuthId
-          let mimeType = defaultMimeLookup (fileName fInfo) 
-              source
-                | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
-                | otherwise = do
-                  let fileTitle = Text.unpack $ fileName fInfo
-                  fileModified <- liftIO getCurrentTime
-                  yieldM $ do
-                    fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
-                    return File{..}
-          submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate))
-          get404 submissionId'
-  
-    files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-      E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
-      E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId)
-      E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-      return (f, sf)
-    return (submission, files)
-
-  let
-    Rating'{..} = Rating'
-      { ratingPoints = submissionRatingPoints submission
-      , ratingComment = submissionRatingComment submission
-      , ratingTime = submissionRatingTime submission
-      }
-
-  cID' <- encrypt submissionId
-  let
-    archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
-    archiveName = archiveBaseName <.> "zip"
-
-  defaultLayout $(widgetFile "submission")

src/Handler/Term.hs

@@ -7,6 +7,7 @@
            , MultiParamTypeClasses
            , TypeFamilies
            , FlexibleContexts
+           , PartialTypeSignatures
   #-}
 
 module Handler.Term where
@@ -18,7 +19,6 @@ import Handler.Utils
 import Yesod.Form.Bootstrap3
 
 import Colonnade hiding (bool)
-import Yesod.Colonnade
 
 import qualified Database.Esqueleto as E
 
@@ -41,7 +41,7 @@ getTermShowR = do
   selectRep $ do
     provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
     provideRep $ do
-      let colonnadeTerms = mconcat
+      let colonnadeTerms = widgetColonnade $ mconcat
             [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
                 -- Scrap this if to slow, create term edit page instead
                 adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
@@ -52,21 +52,21 @@ getTermShowR = do
                   $else
                       #{termToText termName}
                 |]
-            , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
+            , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                 stringCell $ formatTimeGerWD termLectureStart
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
                 stringCell $ formatTimeGerWD termLectureEnd
             , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
-                textCell $ bool "" tickmark termActive
+                textCell $ (bool "" tickmark termActive :: Text)
             , sortable Nothing "Kursliste" $ anchorCell
                 (\(Entity tid _, _) -> TermCourseListR tid)
                 (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
             , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
-              stringCell $ formatTimeGerWD termStart
+                stringCell $ formatTimeGerWD termStart
             , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
-              stringCell $ formatTimeGerWD termEnd
+                stringCell $ formatTimeGerWD termEnd
             , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
-              stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
+                stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
             ]
       table <- dbTable def $ DBTable
         { dbtSQLQuery = termData

src/Handler/Utils/Form.hs

@@ -40,15 +40,19 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+
 import Control.Monad.Writer.Class
 
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrectionsUpload
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -530,3 +534,16 @@ mforced Field{..} FieldSettings{..} val = do
 aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ second pure <$> mforced field settings val
+
+multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+multiAction acts = do
+  mr <- getMessageRender
+  let
+    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
+  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
+  results <- sequence acts
+  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+      actionResults = Map.map fst results
+  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

src/Handler/Utils/Submission.hs

@@ -8,20 +8,26 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 
 module Handler.Utils.Submission
-  ( SubmissionSinkException(..)
+  ( AssignSubmissionException(..)
+  , assignSubmissions
+  , submissionFileSource, submissionFileQuery
+  , submissionMultiArchive 
+  , SubmissionSinkException(..)
   , sinkSubmission
   ) where
 
-import Import hiding ((.=))
+import Import hiding ((.=), joinPath)
 
 import Control.Lens
 import Control.Lens.Extras (is)
 import Utils.Lens
 
-import Control.Monad.State hiding (forM_)
+import Control.Monad.State hiding (forM_, mapM_,foldM)
 import qualified Control.Monad.Random as Rand
 
 import Data.Maybe
@@ -32,15 +38,21 @@ import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
 
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 import Handler.Utils.Rating
+import Handler.Utils.Zip
 
 import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
+import Data.Conduit.ResumableSink
+
+import System.FilePath
 
 
 data AssignSubmissionException = NoCorrectorsByProportion
@@ -49,12 +61,12 @@ data AssignSubmissionException = NoCorrectorsByProportion
 instance Exception AssignSubmissionException
 
 -- | Assigns all submissions according to sheet corrector loads
-assignSubmissions ::
+assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
-    SheetId -- ^ Sheet do distribute to correction
+                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-    -> YesodDB UniWorX (Set SubmissionId -- ^ assigned submissions
+                  -> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
-                       ,Set SubmissionId -- ^ unassigend submissions (no tutors by load)
+                                     , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
-                       )
+                                     )
-assignSubmissions sid = do
+assignSubmissions sid restriction = do
     correctors <- selectList [SheetCorrectorSheet ==. sid] []
     let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
     let corrsProp  = filter hasPositiveLoad correctors
@@ -74,7 +86,8 @@ assignSubmissions sid = do
                 E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
                 return $ tutorial E.^. TutorialTutor
         E.on $ user E.?. UserId `E.in_` E.justList tutors
-        E.where_ $  submission E.^. SubmissionSheet E.==. E.val sid
+        E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
+             E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
         E.orderBy [E.rand] -- randomize for fair tutor distribution
         return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
 
@@ -105,6 +118,57 @@ assignSubmissions sid = do
       hasTutorialLoad = isJust . byTutorial   . sheetCorrectorLoad . entityVal
 
 
+submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource = E.selectSource . E.from . submissionFileQuery
+
+submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
+                        -> E.SqlQuery (E.SqlExpr (Entity File))
+submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
+  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
+  return f
+
+submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
+submissionMultiArchive (Set.toList -> ids) = do
+  (dbrunner, cleanup) <- getDBRunner
+
+  ratedSubmissions <- runDBRunner dbrunner $ do
+    submissions <- selectList [ SubmissionId <-. ids ] []
+    forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
+  
+  (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
+    let
+      fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
+      fileEntitySource' (rating, Entity submissionID Submission{..}) = do
+        cID <- encrypt submissionID
+
+        let
+          directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
+              
+          fileEntitySource = do
+            submissionFileSource submissionID =$= Conduit.map entityVal
+            yieldM (ratingFile cID rating)
+
+          withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
+
+        lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
+        lastEditTime <- case lastEditMb of
+          [(submissionEditTime.entityVal -> time)] -> return time
+          _other -> liftIO getCurrentTime
+        yield $ File
+          { fileModified = lastEditTime
+          , fileTitle = directoryName
+          , fileContent = Nothing
+          }
+
+        fileEntitySource =$= mapC withinDirectory
+          
+    mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
+
+
+
 
 
 data SubmissionSinkState = SubmissionSinkState
@@ -125,9 +189,9 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
 
 instance Exception SubmissionSinkException
 
-sinkSubmission :: SheetId
+sinkSubmission :: UserId
-               -> UserId
+               -> Either SheetId SubmissionId
-               -> Maybe (SubmissionId, Bool {-^ Is this a correction -})
+               -> Bool -- ^ Is this a correction
                -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
 -- ^ Replace the currently saved files for the given submission (either
 --   corrected files or original ones, depending on arguments) with the supplied
@@ -137,25 +201,28 @@ sinkSubmission :: SheetId
 -- are deleted (or marked as deleted in the case of this being a correction).
 --
 -- A 'Submission' is created if no 'SubmissionId' is supplied
-sinkSubmission sheetId userId mExists = do
+sinkSubmission userId mExists isUpdate = do
-  now <- liftIO getCurrentTime
+  sId <- lift $ case mExists of
-  let
+    Left sheetId -> do
-    submissionSheet       = sheetId
+      let
-    submissionRatingPoints  = Nothing
+        submissionSheet         = sheetId
-    submissionRatingComment = Nothing
+        submissionRatingPoints  = Nothing
-    submissionRatingBy      = Nothing
+        submissionRatingComment = Nothing
-    submissionRatingTime    = Nothing
+        submissionRatingBy      = Nothing
-
+        submissionRatingTime    = Nothing
-  (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists
+      sId <- insert Submission{..}
-
+      -- now <- liftIO getCurrentTime
+      -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
+      return sId
+    Right sId -> return sId
 
   sId <$ sinkSubmission' sId isUpdate
   where
     tell = modify . mappend
 
     sinkSubmission' :: SubmissionId
-                   -> Bool -- ^ Is this a correction
+                    -> Bool -- ^ Is this a correction
-                   -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> Sink SubmissionContent (YesodDB UniWorX) ()
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@@ -303,3 +370,43 @@ sinkSubmission sheetId userId mExists = do
               , SubmissionRatingBy =. Nothing
               , SubmissionRatingComment =. Nothing
               ]
+
+sinkMultiSubmission :: UserId
+                    -> Bool {-^ Are these corrections -}
+                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
+               
+-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
+--
+-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
+sinkMultiSubmission userId isUpdate = do
+  let
+    feed :: SubmissionId
+         -> SubmissionContent
+         -> StateT
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
+              (YesodDB UniWorX)
+              ()
+    feed sId val = do
+      mSink <- gets $ Map.lookup sId
+      sink <- case mSink of
+        Just sink -> return sink
+        Nothing -> do
+          -- Submission{..} <- lift $ get404 sId
+          return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
+      sink' <- lift $ yield val ++$$ sink
+      case sink' of
+        Left _ -> error "sinkSubmission returned prematurely"
+        Right nSink -> modify $ Map.insert sId nSink
+  sinks <- execStateLC Map.empty . awaitForever $ \case
+    v@(Right (sId, _)) -> lift $ feed sId v
+    (Left f@File{..})  -> do
+      let
+        tryDecrypt :: FilePath -> _ (Either CryptoIDError SubmissionId)
+        tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
+        acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
+        acc (Nothing , fp) segment = do
+          msId <- tryDecrypt segment
+          return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
+      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
+      lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
+  fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks

src/Handler/Utils/Table.hs

@@ -35,9 +35,6 @@ numberColonnade = headed "Nr" (fromString.show)
 pairColonnade :: (Functor h) =>  Colonnade h a c -> Colonnade h b c ->  Colonnade h (a,b) c
 pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
 
-i18nCell :: RenderMessage site a => a -> Cell site
-i18nCell msg = cell [whamlet|_{msg}|]
-
 
 -- Table Modification
 encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
@@ -94,3 +91,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
   return ( catMaybes <$> collectResult selectionResults
          , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
          )
+
+

src/Handler/Utils/Table/Pagination.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , RecordWildCards
+           , NamedFieldPuns
            , OverloadedStrings
            , TemplateHaskell
            , QuasiQuotes
@@ -10,29 +11,37 @@
            , FlexibleInstances
            , MultiParamTypeClasses
            , TypeFamilies
+           , ScopedTypeVariables
+           , TupleSections
+           , RankNTypes
   #-}
 
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), DBOutput
-  , DBTable(..)
+  , DBTable(..), IsDBTable(..)
   , PaginationSettings(..)
   , PSValidator(..)
-  , Sortable(..), sortable
+  , defaultFilter, defaultSorting
+  , restrictFilter, restrictSorting
+  , ToSortable(..), Sortable(..), sortable
   , dbTable
+  , widgetColonnade, formColonnade
+  , textCell, stringCell, i18nCell, anchorCell
+  , formCell, DBFormResult, getDBFormResult
+  , dbRow, dbSelect
   ) where
 
 import Handler.Utils.Table.Pagination.Types
 
-import Import
+import Import hiding (Proxy(..))
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)
 import Text.Blaze (Attribute)
 import qualified Text.Blaze.Html5.Attributes as Html5
 import qualified Text.Blaze.Html5 as Html5
-import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
 
 import qualified Data.Binary.Builder as Builder
 
@@ -42,6 +51,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
 
 import Data.Map (Map, (!))
 import qualified Data.Map as Map
@@ -49,13 +59,17 @@ import qualified Data.Map as Map
 import Data.Profunctor (lmap)
 
 import Colonnade hiding (bool, fromMaybe, singleton)
+import qualified Colonnade (singleton)
 import Colonnade.Encode
-import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
 
 import Data.Ratio ((%))
 
+import Control.Lens
+
+import Data.Proxy
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -99,38 +113,38 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
 
 
 data DBRow r = DBRow
-  { dbrIndex, dbrCount :: Int64
+  { dbrOutput :: r
-  , dbrOutput :: r
+  , dbrIndex, dbrCount :: Int64
-  }
+  } deriving (Show, Read, Eq, Ord)
 
 class DBOutput r r' where
   dbProj :: r -> r'
 
-instance DBOutput r r where
+instance DBOutput (DBRow r) (DBRow r) where
   dbProj = id
 instance DBOutput (DBRow r) r where
   dbProj = dbrOutput
 instance DBOutput (DBRow r) (Int64, r) where
   dbProj = (,) <$> dbrIndex <*> dbrOutput
 
- 
+data DBTable m x = forall a r r' h i t.
-data DBTable = forall a r r' h i t.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, DBOutput (DBRow r) r'
   , PathPiece i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
-  , dbtColonnade :: Colonnade h r' (Cell UniWorX)
+  , dbtColonnade :: Colonnade h r' (DBCell m x)
-  , dbtSorting :: Map Text (SortColumn t)
+  , dbtSorting :: Map (CI Text) (SortColumn t)
-  , dbtFilter :: Map Text (FilterColumn t)
+  , dbtFilter :: Map (CI Text) (FilterColumn t)
-  , dbtAttrs :: Attribute
+  , dbtAttrs :: Attribute -- FIXME: currently unused
   , dbtIdent :: i
   }
 
+
 data PaginationSettings = PaginationSettings
-  { psSorting      :: [(Text, SortDirection)]
+  { psSorting      :: [(CI Text, SortDirection)]
-  , psFilter       :: Map Text [Text]
+  , psFilter       :: Map (CI Text) [Text]
   , psLimit        :: Int64
   , psPage         :: Int64
   , psShortcircuit :: Bool
@@ -145,9 +159,9 @@ instance Default PaginationSettings where
     , psShortcircuit = False
     }
 
-newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
 
-instance Default PSValidator where
+instance Default (PSValidator m x) where
   def = PSValidator $ \DBTable{..} -> \case
     Nothing -> def
     Just ps -> swap . (\act -> execRWS act () ps) $ do
@@ -156,15 +170,94 @@ instance Default PSValidator where
         modify $ \ps -> ps { psLimit = psLimit def }
         tell . pure $ SomeMessage MsgPSLimitNonPositive
 
+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
 
-dbTable :: PSValidator -> DBTable -> Handler Widget
+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) => IsDBTable (m :: * -> *) (x :: *) where
+  type DBResult m x :: *
+  -- type DBResult' m x :: *
+
+  data DBCell m x :: *
+  cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
+  cellContents :: DBCell m x -> WriterT x m Widget
+
+  cell :: Widget -> DBCell m x
+
+    
+  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
+  dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
+
+instance IsDBTable (WidgetT UniWorX IO) () where
+  type DBResult (WidgetT UniWorX IO) () = Widget
+  -- type DBResult' (WidgetT UniWorX IO) () = ()
+
+  data DBCell (WidgetT UniWorX IO) () = WidgetCell
+    { dbCellAttrs :: [(Text, Text)]
+    , dbCellContents :: Widget
+    }
+  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellContents = return . dbCellContents
+
+  cell = WidgetCell []
+  
+  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
+  dbWidget Proxy Proxy = return
+  runDBTable = return . join . fmap (view _2)
+
+instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
+  -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
+  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
+  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
+
+  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
+    { formCellAttrs :: [(Text, Text)]
+    , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+    }
+  cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
+  cellContents = WriterT . fmap swap . formCellContents
+
+  cell widget = FormCell [] $ return (mempty, widget)
+  
+  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
+  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
+  dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
+  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
+  runDBTable = return . withFragment
+
+instance IsDBTable m a => IsString (DBCell m a) where
+  fromString = cell . fromString
+      
+
+dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
 dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
   let
     sortingOptions = mkOptionList
       [ Option t' (t, d) t'
       | (t, _) <- mapToList dbtSorting
       , d <- [SortAsc, SortDesc]
-      , let t' = t <> "-" <> toPathPiece d
+      , let t' = CI.foldedCase t <> "-" <> toPathPiece d
       ]
     (_, defPS) = runPSValidator dbtable Nothing
     wIdent n
@@ -181,7 +274,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     
   psResult <- runInputGetResult $ PaginationSettings
     <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
-    <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ wIdent k) dbtFilter)
+    <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
     <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
     <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
     <*> ireq checkBoxField (wIdent "table-only")
@@ -212,25 +305,44 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     rowCount
       | ((_, E.Value n), _):_ <- rows' = n
       | otherwise = 0
-    rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
+    rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows'
 
-  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
+    table' :: WriterT x m Widget
-    getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+    table' = do
-    let table = $(widgetFile "table/colonnade")
+      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
-        pageCount = max 1 . ceiling $ rowCount % psLimit
+
-        pageNumbers = [0..pred pageCount]
+      let
         tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
 
-        withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
+        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-          { cellContents = $(widgetFile "table/sortable-header")
+          widget <- cellContents sortableContent
-          , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
+          let
-          }
-          where
             directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-            sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
+            isSortable = isJust sortableKey
-            toAttr SortAsc = ["sorted-asc"]
+            isSorted = (`elem` directions)
-            toAttr SortDesc = ["sorted-desc"]
+            attrs = sortableContent ^. cellAttrs
-    $(widgetFile "table/layout")
+          return $(widgetFile "table/cell/header")
+
+        columnCount :: Int64
+        columnCount = olength64 $ getColonnade dbtColonnade
+
+      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+
+      wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
+        widget <- cellContents cell
+        let attrs = cell ^. cellAttrs
+        return $(widgetFile "table/cell/body")
+      
+      let table = $(widgetFile "table/colonnade")
+          pageCount = max 1 . ceiling $ rowCount % psLimit
+          pageNumbers = [0..pred pageCount]
+
+      return $(widgetFile "table/layout")
+
+    dbWidget' :: DBResult m x -> Handler Widget
+    dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
+
+  bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
     tblLayout :: Widget -> Handler Html
     tblLayout tbl' = do
@@ -240,22 +352,62 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
 
-widgetFromCell ::
+--- DBCell utility functions
-  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
-  -> Cell site
-  -> WidgetT site IO ()
-widgetFromCell f (Cell attrs contents) =
-  f attrs contents
-td,th ::
-  Attribute -> WidgetT site IO () -> WidgetT site IO ()
 
-td = liftParent Html5.td
+widgetColonnade :: Headedness h
-th = liftParent Html5.th
+                => Colonnade h r (DBCell (WidgetT UniWorX IO) ())
+                -> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
+widgetColonnade = id
 
-liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
+formColonnade :: (Headedness h, Monoid a)
-liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
+              => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
-  (a,gwd) <- f hdata
+              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
-  let Body bodyFunc = gwdBody gwd
+formColonnade = id
-      newBodyFunc render =
+
-        el Html5.! attrs $ (bodyFunc render)
+textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
-  return (a,gwd { gwdBody = Body newBodyFunc })
+stringCell = textCell
+i18nCell = textCell
+textCell msg = cell [whamlet|_{msg}|]
+
+anchorCell :: IsDBTable m a
+           => (r -> Route UniWorX)
+           -> (r -> Widget)
+           -> (r -> DBCell m a)
+anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
+  where
+    route = mkRoute val
+    widget = mkWidget val
+
+newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
+
+instance Ord i => Monoid (DBFormResult r i a) where
+  mempty = DBFormResult Map.empty
+  (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
+
+getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
+getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
+
+formCell :: forall r i a. Ord i
+         => (r -> MForm (HandlerT UniWorX IO) i)
+         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
+         -> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
+formCell genIndex genForm input = FormCell
+  { formCellAttrs    = []
+  , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
+      i <- genIndex input
+      (edit, w) <- genForm input i
+      return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
+  }
+
+-- Predefined colonnades
+
+dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
+dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
+
+dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
+         => Setter' a Bool
+         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
+dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
+  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
+  return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

src/Handler/Utils/Table/Pagination/Types.hs

@@ -11,12 +11,14 @@ import Import hiding (singleton)
 import Colonnade
 import Colonnade.Encode
 
+import Data.CaseInsensitive (CI)
+
 data Sortable a = Sortable
-  { sortableKey :: Maybe Text
+  { sortableKey :: Maybe (CI Text)
   , sortableContent :: a
   }
 
-sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c
+sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c
 sortable k h = singleton (Sortable k h)
 
 instance Headedness Sortable where
@@ -40,4 +42,3 @@ instance ToSortable Headed where
 
 instance ToSortable Headless where
   pSortable = Nothing
- 

src/Model/Types.hs

@@ -109,7 +109,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
     = Load { byTutorial :: Maybe Bool  -- ^ Just all from Tutorial, True if counting towards overall workload
            , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
            }
-  deriving (Show, Read, Eq)
+  deriving (Show, Read, Eq, Ord)
 derivePersistField "Load"
 
 instance Semigroup Load where
@@ -169,14 +169,30 @@ termFromText t
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
   | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
-  
+
+termToRational :: TermIdentifier -> Rational
+termToRational TermIdentifier{..} = fromInteger year + seasonOffset
+  where
+    seasonOffset
+      | Summer <- season = 0
+      | Winter <- season = 0.5
+
+termFromRational :: Rational -> TermIdentifier
+termFromRational n = TermIdentifier{..}
+  where
+    year = floor n
+    remainder = n - (fromInteger $ floor n)
+    season
+      | remainder == 0 = Summer
+      | otherwise      = Winter
+
 instance PersistField TermIdentifier where
-  toPersistValue = PersistText . termToText
+  toPersistValue = PersistRational . termToRational
-  fromPersistValue (PersistText t) = termFromText t
+  fromPersistValue (PersistRational t) = Right $ termFromRational t
   fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
 
 instance PersistFieldSql TermIdentifier where
-  sqlType _ = SqlString
+  sqlType _ = SqlNumeric 5 1
 
 instance ToHttpApiData TermIdentifier where
   toUrlPiece = termToText
@@ -193,20 +209,20 @@ instance ToJSON TermIdentifier where
 
 instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
-  
+
 {- Must be defined in a later module:
 termField :: Field (HandlerT UniWorX IO) TermIdentifier
 termField = checkMMap (return . termFromText) termToText textField
-  -- TODO: this is too simple and inconvenient, use selector and year picker  
+  -- TODO: this is too simple and inconvenient, use selector and year picker
--} 
+-}
 
 
 withinTerm :: Day -> TermIdentifier -> Bool
 time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
-  where 
+  where
-    timeYear = fst3 $ toGregorian time      
+    timeYear = fst3 $ toGregorian time
-    termYear = year term 
+    termYear = year term
-      
+
 
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
@@ -216,9 +232,10 @@ derivePersistField "StudyFieldType"
 -- Skins / Themes
 data Theme       --Simply add Themes to this type only. CamelCase will be converted to "-lower"
   = Default
+  | Lavender
   | NeutralBlue
   | AberdeenReds
-  | MintGreen
+  | MossGreen
   | SkyLove
   deriving (Eq,Ord,Bounded,Enum)
 
@@ -242,5 +259,3 @@ instance Default Theme where
 -}
 
 derivePersistField "Theme"
-
-

src/Utils.hs

@@ -43,6 +43,10 @@ getMsgRenderer = do
   mr <- getMessageRender
   return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
 
+instance Monad FormResult where
+  FormMissing        >>= _ = FormMissing
+  (FormFailure errs) >>= _ = FormFailure errs
+  (FormSuccess a)    >>= f = f a
 
 ---------------------
 -- Text and String --

src/Utils/Common.hs

@@ -16,7 +16,7 @@ import Language.Haskell.TH
 -- Tuples --
 ------------
 
-
+-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
 projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
 projNI n i = lamE [pat] rhs

templates/adminTest.hamlet

@@ -36,10 +36,7 @@
       <a href=@{TermEditR}>Neues Semester anlegen
 
     <li .list-group-item>
-                        <a href=@{CourseNewR}>Kurse anlegen
+      <a href=@{CourseNewR}>Kurse anlegen
-
-    <li .list-group-item>
-      <a href=@{SubmissionListR}>Dateien hochladen und abrufen
 
 <hr>
 <div .container>

templates/corrections.hamlet

@@ -0,0 +1,5 @@
+<div .container>
+  <form method=POST enctype=#{tableEncoding}>
+    ^{table}
+    <button type=submit>
+      _{MsgBtnSubmit}

templates/course.hamlet

@@ -1,4 +1,4 @@
-0<div .container>
+<div .container>
   <div .scrolltable>
     <table .table.table--striped.table--hover.table--vertical>
       $maybe school <- schoolMB
@@ -22,18 +22,17 @@
           #{participants}
           $maybe capacity <- courseCapacity course
             \ von #{capacity}
-      <tr .table__row>
+      $maybe regFrom <- courseRegisterFrom course
-        <th #registration>Anmeldezeitraum
+        <tr .table__row>
-        <td>
+          <th #registration>Anmeldezeitraum
-          $maybe regFrom <- courseRegisterFrom course
+          <td>
-            #{formatTimeGerWD regFrom}
+            Ab #{formatTimeGerWD regFrom}
-          $maybe regTo   <- courseRegisterTo   course
+            $maybe regTo   <- courseRegisterTo   course
-            \ bis #{formatTimeGerWD regTo}
+              \ bis #{formatTimeGerWD regTo}
-
+      $if registrationOpen
-      <tr .table__row>
+        <tr .table__row>
-        <th>
+          <th>
-        <td>
+          <td>
-          $if registrationOpen
             <div .course__registration.container>
               <form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
                 $# regWidget is defined through templates/widgets/registerForm

templates/default-layout.lucius

@@ -16,7 +16,7 @@
   --font-logo: "Roboto", var(--font-base);
 
   /* DIMENSIONS */
-  --header-height: 80px;
+  --header-height: 100px;
   --header-height-collapsed: 50px;
 }
 
@@ -38,15 +38,25 @@ body {
 /* THEMES */
 
 body {
-  /* DEFAULT THEME */
+  /* DEFAULT LMU THEME */
-  --color-primary: #4C7A9C;
+  --color-primary: #0a9342;
-  --color-light: #598EB5;
+  --color-light: #31cc72;
-  --color-lighter: #5F98C2;
+  --color-lighter: #35db7a;
-  --color-dark: #425d79;
+  --color-dark: #087536;
-  --color-darker: #274a65;
+  --color-darker: #075728;
-  --color-link: var(--color-dark);
+  --color-link: var(--color-font);
-  --color-link-hover: var(--color-darker);
+  --color-link-hover: var(--color-font);
+  --color-lmu-box-border: var(--color-lightwhite);
 
+  &.theme--lavender {
+    --color-primary: #4C7A9C;
+    --color-light: #598EB5;
+    --color-lighter: #5F98C2;
+    --color-dark: #425d79;
+    --color-darker: #274a65;
+    --color-link: var(--color-dark);
+    --color-link-hover: var(--color-darker);
+  }
 
   &.theme--neutral-blue {
     --color-primary: #3E606F;
@@ -64,7 +74,7 @@ body {
     --color-darker: #2E112D;
   }
 
-  &.theme--mint-green {
+  &.theme--moss-green {
     --color-primary: #5C996B;
     --color-light: #7ACC8F;
     --color-lighter: #99FFB2;
@@ -159,7 +169,6 @@ h4 {
 .main__content {
   position: relative;
   background-color: white;
-  z-index: 0;
   overflow: hidden;
 
   > .container {
@@ -281,38 +290,31 @@ a.btn.btn-info:hover,
 }
 
 /* TABLE DESIGN */
-.table__row {
+.table__td, .table__th {
+  padding-top: 14px;
+  padding-bottom: 10px;
+  padding-left: 10px;
+  padding-right: 10px;
+  max-width: 300px;
+}
 
-  /* TODO: move outside of table__row as soon as tds and ths get their own class */
+.table__td {
-  /* .table__td, .table__th { */
+  font-size: 16px;
-  td, th {
+  color: var(--color-font);
-    padding-top: 14px;
+  line-height: 1.4;
-    padding-bottom: 10px;
+  vertical-align: top;
-    padding-left: 10px;
+}
-    padding-right: 10px;
-    max-width: 300px;
-  }
 
-  /* .table__td { */
+.table__th {
-  td {
+  background-color: var(--color-dark);
-    font-size: 16px;
+  position: relative;
-    color: #808080;
+  font-size: 16px;
-    line-height: 1.4;
+  color: #fff;
-    vertical-align: top;
+  line-height: 1.4;
-  }
+  padding-top: 10px;
-
+  padding-bottom: 10px;
-  /* .table__th { */
+  font-weight: bold;
-  th {
+  text-align: left;
-    background-color: var(--color-dark);
-    position: relative;
-    font-size: 16px;
-    color: #fff;
-    line-height: 1.4;
-    padding-top: 10px;
-    padding-bottom: 10px;
-    font-weight: bold;
-    text-align: left;
-  }
 }
 
 @media (max-width: 1200px) {
@@ -323,7 +325,7 @@ a.btn.btn-info:hover,
 }
 
 .table__td-content {
-  max-height: 100px;
+  max-height: 200px;
   overflow-y: auto;
 }
 

templates/messages/submissionsAlreadyAssigned.hamlet

@@ -0,0 +1,5 @@
+_{MsgSubmissionsAlreadyAssigned (genericLength alreadyAssigned')}
+
+<ul>
+  $forall (cID, _) <- alreadyAssigned'
+    <li><pre>#{toPathPiece cID}

templates/messages/submissionsNotAssignedAuto.hamlet

@@ -0,0 +1,5 @@
+_{MsgCouldNotAssignCorrectorsAuto (genericLength unassigned')}
+
+<ul>
+  $forall cID <- unassigned'
+    <li><pre>#{toPathPiece cID}

templates/profile.hamlet

@@ -3,71 +3,71 @@
   <div .scrolltable>
     <table .table.table--striped.table--hover.table--vertical>
       <tr.table__row>
-        <th> _{MsgName}
+        <th .table__th> _{MsgName}
-        <td> #{display userDisplayName}
+        <td .table__td> #{display userDisplayName}
       <tr.table__row>
-        <th> _{MsgMatrikelNr}
+        <th .table__th> _{MsgMatrikelNr}
-        <td> #{display userMatrikelnummer}
+        <td .table__td> #{display userMatrikelnummer}
       <tr.table__row>
-        <th> _{MsgEMail}
+        <th .table__th> _{MsgEMail}
-        <td> #{display userEmail}
+        <td .table__td> #{display userEmail}
       <tr.table__row>
-        <th> _{MsgIdent}
+        <th .table__th> _{MsgIdent}
-        <td> #{display userIdent}
+        <td .table__td> #{display userIdent}
       <tr.table__row>
-        <th> _{MsgPlugin}
+        <th .table__th> _{MsgPlugin}
-        <td> #{display userPlugin}
+        <td .table__td> #{display userPlugin}
       $if not $ null admin_rights
         <tr.table__row>
-          <th> Administrator
+          <th .table__th> Administrator
-          <td>
+          <td .table__td>
             <ul>
               $forall institute <- admin_rights
                 <li>#{display institute}
       $if not $ null lecturer_rights
         <tr.table__row>
-          <th> Lehrberechtigt
+          <th .table__th> Lehrberechtigt
-          <td>
+          <td .table__td>
             <ul>
               $forall institute <- lecturer_rights
                 <li>#{display institute}
       $if not $ null lecture_owner
         <tr.table__row>
-          <th> Eigene Kurse
+          <th .table__th> Eigene Kurse
-          <td>
+          <td .table__td>
             <ul>
               $forall (E.Value csh, E.Value tid) <- lecture_owner
                 <li>
                   <a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
       $if not $ null lecture_corrector
         <tr.table__row>
-          <th> Korrektor
+          <th .table__th> Korrektor
-          <td>
+          <td .table__td>
             <ul>
               $forall (E.Value csh, E.Value tid) <- lecture_corrector
                 <li>
                   <a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
       $if not $ null studies
         <tr.table__row>
-          <th> Studiengänge
+          <th .table__th> Studiengänge
-          <td>
+          <td .table__td>
             <table .table .table-striped .table-hover>
               <tr.table__row>
-                <th> Abschluss
+                <th .table__th> Abschluss
-                <th> Studiengang
+                <th .table__th> Studiengang
-                <th> Studienart
+                <th .table__th> Studienart
-                <th> Semester
+                <th .table__th> Semester
 
               $forall (degree,field,fieldtype,semester) <- studies
                 <tr.table__row>
-                  <td> #{display degree}
+                  <td .table__td> #{display degree}
-                  <td> #{display field}
+                  <td .table__td> #{display field}
-                  <td> #{display fieldtype}
+                  <td .table__td> #{display fieldtype}
-                  <td> #{display semester}
+                  <td .table__td> #{display semester}
       $if not $ null participant
         <tr.table__row>
-          <th> Teilnehmer
+          <th .table__th> Teilnehmer
-          <td>
+          <td .table__td>
             <ul>
               $forall (E.Value csh, E.Value tid, regSince) <- participant
                 <li>

templates/profile.julius

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

templates/standalone/alerts.julius

@@ -11,6 +11,13 @@
       alertEl.classList.add('alert--invisible');
     });
     alertEl.insertBefore(closeEl, alertEl.children[0]);
+
+    // auto-hide info and success-alerts after 3 seconds
+    if (!alertEl.matches('.alert-danger, .alert-warning')) {
+      window.setTimeout(function() {
+        alertEl.classList.add('alert--invisible');
+      }, 3000);
+    }
   }
 
 })();

templates/standalone/alerts.lucius

@@ -8,6 +8,15 @@
   display: flex;
   flex-direction: column;
 }
+
+@media (min-width: 768px) {
+
+  .alerts {
+    top: 150px;
+    bottom: auto;
+  }
+}
+
 .alert {
   position: relative;
   display: inline-block;
@@ -23,6 +32,7 @@
   margin-left: 20px;
   margin-right: 60px;
   box-shadow: 0 0 7px var(--color-dark);
+  animation: slide-in-alert .2s ease-out forwards;
 
   + .alert:not(.alert--invisible) {
     margin-top: 20px;
@@ -39,6 +49,15 @@
   }
 }
 
+@keyframes slide-in-alert {
+  from {
+    left: 120%;
+  }
+  to {
+    left: 0;
+  }
+}
+
 @media (min-width: 425px) {
 
   .alert {
@@ -91,6 +110,7 @@
     align-items: center;
     font-size: 40px;
     color: var(--color-dark);
+    box-shadow: 0 0 2px var(--color-dark);
   }
 }
 
@@ -146,6 +166,7 @@
     &::after {
       content: '\f05a';
       color: var(--color-success);
+      box-shadow: 0 0 2px var(--color-success);
     }
   }
 }
@@ -173,6 +194,7 @@
     &::after {
       content: '\f071';
       color: var(--color-warning);
+      box-shadow: 0 0 2px var(--color-warning);
     }
   }
 }
@@ -189,7 +211,7 @@
     /* TODO: remove me as soon as messagerenderer-error in julius gets resolved */
     &::before {
       color: var(--color-lightwhite);
-    }
+   }
   }
 
   .alert__content {
@@ -201,6 +223,7 @@
     &::after {
       content: '\f071';
       color: var(--color-error);
+      box-shadow: 0 0 2px var(--color-error);
     }
   }
 }

templates/table/cell/body.hamlet

@@ -0,0 +1,3 @@
+<td .table__td *{attrs}>
+  <div .table__td-content>
+    ^{widget}

templates/table/cell/header.hamlet

@@ -0,0 +1,11 @@
+<th .table__th *{attrs} :isSortable:.sortable :isSorted SortAsc:.sorted-asc :isSorted SortDesc:.sorted-desc>
+  $maybe flag <- sortableKey
+    $case directions
+      $of [SortAsc]
+        <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-desc")}>
+          ^{widget}
+      $of _
+        <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-asc")}>
+          ^{widget}
+  $nothing
+    ^{widget}

templates/table/cell/link.hamlet

@@ -0,0 +1,2 @@
+<a href=@{route}>
+  ^{widget}

templates/table/colonnade.hamlet

@@ -1,18 +1,20 @@
 $newline never
 <table id="#{dbtIdent}" .table.table--striped.table--hover>
-  $maybe sortableP <- pSortable
+  $maybe wHeaders' <- wHeaders
-    $with toSortable <- toSortable sortableP
+    <thead>
-      <thead>
+      <tr .table__row.table__row--head>
-        <tr .table__row>
+        $forall widget <- wHeaders'
-          $forall OneColonnade{..} <- getColonnade dbtColonnade
+          $# cell/header.hamlet
-            <!-- TODO: give ths a class 'table__th' -->
+          ^{widget}
-            <!-- TODO: wrap content of th in 'div.table__th-content' -->
-            ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
   $nothing
   <tbody>
-    $forall row <- rows
+    $if null wRows
-      <tr .table__row>
+      <tr>
-        $forall OneColonnade{..} <- getColonnade dbtColonnade
+        <td colspan=#{show columnCount}>
-          <!-- TODO: give tds a class 'table__td' -->
+          Kein Inhalt.
-          <!-- TODO: wrap content of td in 'div.table__td-content' -->
+    $else
-          ^{widgetFromCell td $ oneColonnadeEncode row}
+      $forall row <- wRows
+        <tr .table__row>
+          $forall widget <- row
+            $# cell/body.hamlet 
+            ^{widget}

templates/table/colonnade.lucius

@@ -1,44 +1,40 @@
-/* SORTABLE TABLE */
+/* SORTABLE TABLE-HEADERS*/
-.table {
+.table__th.sortable {
-
+  position: relative;
-  /* TODO: move outside of table as soon as tds and ths get their own class */
+  padding-right: 24px;
-  th.sortable {
+  cursor: pointer;
-    position: relative;
+}
-    padding-right: 24px;
+
-    cursor: pointer;
+.table__th.sortable::after,
-  }
+.table__th.sortable::before {
-
+  content: '';
-  th.sortable::after,
+  position: absolute;
-  th.sortable::before {
+  top: 50%;
-    content: '';
+  right: 4px;
-    position: absolute;
+  width: 0;
-    top: 50%;
+  height: 0;
-    right: 4px;
+  border-left: 8px solid transparent;
-    width: 0;
+  border-right: 8px solid transparent;
-    height: 0;
+  border-bottom: 8px solid rgba(255, 255, 255, 0.4);
-    border-left: 8px solid transparent;
+}
-    border-right: 8px solid transparent;
+
-    border-bottom: 8px solid rgba(255, 255, 255, 0.4);
+.table__th.sortable::before {
-  }
+  /* magic numbers to move arrow back in the right position after flipping it.
-
+  this allows us to use the same border for the up and the down arrow */
-  th.sortable::before {
+  transform: translateY(150%) scale(1, -1);
-    /* magic numbers to move arrow back in the right position after flipping it.
+  transform-origin: top;
-    this allows us to use the same border for the up and the down arrow */
+}
-    transform: translateY(150%) scale(1, -1);
+
-    transform-origin: top;
+.table__th.sortable::after {
-  }
+  transform: translateY(-150%);
-
+}
-  th.sortable::after {
+
-    transform: translateY(-150%);
+.table__th.sortable:hover::before,
-  }
+.table__th.sortable:hover::after {
-
+  border-bottom-color: rgba(255, 255, 255, 0.7);
-  th.sortable:hover::before,
+}
-  th.sortable:hover::after {
+
-    border-bottom-color: rgba(255, 255, 255, 0.7);
+.table__th.sorted-asc::before,
-  }
+.table__th.sorted-desc::after {
-
+  border-bottom-color: white !important;
-  th.sorted-asc::before,
-  th.sorted-desc::after {
-    border-bottom-color: white !important;
-  }
 }

templates/widgets/asidenav.lucius

@@ -48,9 +48,15 @@
   justify-content: flex-start;
   align-items: center;
 
+  &:not(.asidenav__list-item--active):hover {
+    background-color: var(--color-darker);
+
+    > .asidenav__link-wrapper {
+      color: var(--color-lightwhite);
+    }
+  }
+
   &:hover {
-    color: var(--color-link);
-    background-color: var(--color-lightwhite);
 
     .asidenav__link-shorthand {
       transform: scale(1.05, 1.0);
@@ -58,10 +64,6 @@
       text-shadow: none;
     }
 
-    > .asidenav__link-wrapper {
-      color: var(--color-link);
-    }
-
     .asidenav__nested-list {
       transform: translateX(100%);
       opacity: 1;
@@ -109,7 +111,6 @@
     width: 50px;
   }
 
-
   .glyphicon + .asidenav__link-label {
     padding-left: 0;
   }
@@ -143,15 +144,10 @@
   background-color: var(--color-dark);
 
   &:hover {
-    color: var(--color-link);
+    background-color: var(--color-darker);
-    background-color: var(--color-lightwhite);
-
-    .asidenav__link-wrapper {
-      background-color: white;
-      color: var(--color-link);
-    }
   }
-    .asidenav__link-wrapper {
+
+  .asidenav__link-wrapper {
     padding-left: 13px;
     padding-right: 13px;
     border-left: 20px solid white;

templates/widgets/form.hamlet

@@ -7,5 +7,4 @@ $case formLayout
         $if not (Blaze.null $ fvLabel view)
           <label .form-group__label for=#{fvId view}>#{fvLabel view}
         <div .form-group__input>
-          $# FIXME: file-input does not have `required` attribute, although set on form-group
           ^{fvInput view}

templates/widgets/form.julius

@@ -10,6 +10,12 @@
     if (requireds.length == 0) {
       return false;
     }
+    if (typeof button.dataset.formnorequired !== 'undefined' && button.dataset.formnorequired !== null) {
+      button.addEventListener('click', function() {
+        form.submit();
+      });
+      return false;
+    }
     updateButtonState();
 
     requireds.forEach(function(el) {
@@ -28,17 +34,52 @@
       }
     }
   };
+
+  window.utils.interactiveFieldset = function(form, fieldSets) {
+
+    var fields = fieldSets.map(function(fs) {
+      return {
+        fieldSet: fs,
+        condId: fs.dataset.conditionalId,
+        condValue: fs.dataset.conditionalValue,
+        condEl: form.querySelector('#' + fs.dataset.conditionalId),
+      };
+    }).filter(function(field) {
+      return !!field.condEl;
+    });
+
+    function updateFields() {
+      fields.forEach(function(field) {
+        field.fieldSet.classList.toggle('hidden', field.condEl.value !== field.condValue);
+      });
+    }
+
+    function addEventListeners() {
+      fields.forEach(function(field) {
+        field.condEl.addEventListener('input', updateFields)
+      });
+    }
+
+    if (fieldSets.length) {
+      addEventListeners();
+      updateFields();
+    }
+  };
 })();
 
 document.addEventListener('DOMContentLoaded', function() {
 
-  // auto reactiveButton submit-buttons with required fields
   var forms = document.querySelectorAll('form');
   Array.from(forms).forEach(function(form) {
-    var submitBtn = form.querySelector('[type=submit]');
+    // auto reactiveButton submit-buttons with required fields
-    if (submitBtn) {
+    var submitBtns = Array.from(form.querySelectorAll('[type=submit]'));
+    submitBtns.forEach(function(submitBtn) {
       window.utils.reactiveButton(form, submitBtn, validateForm);
-    }
+    });
+
+    // auto conditonal fieldsets
+    var fieldSets = Array.from(form.querySelectorAll('fieldset[data-conditional-id][data-conditional-value]'));
+    window.utils.interactiveFieldset(form, fieldSets);
   });
 
   function validateForm(inputs) {

templates/widgets/form.lucius

@@ -0,0 +1,15 @@
+.hidden {
+  visibility: hidden;
+  height: 0;
+  opacity: 0;
+}
+
+
+fieldset {
+  border: 0;
+  margin: 20px 0 30px;
+
+  legend {
+    display: none;
+  }
+}

templates/widgets/multiAction.hamlet

@@ -0,0 +1,4 @@
+<fieldset data-conditional-id="#{fvId actionView}" data-conditional-value="#{toPathPiece act}">
+  <legend>
+    _{act}
+  ^{w}

templates/widgets/multiActionCollect.hamlet

@@ -0,0 +1,4 @@
+^{fvInput actionView}
+
+$forall w <- actionWidgets
+  ^{w}

templates/widgets/navbar.hamlet

@@ -4,7 +4,7 @@ $newline never
 
     <a href="/" .navbar__logo>
 
-    <ul .navbar__list.list--inline>
+    <ul .navbar__list.list--inline.navbar__list-left>
         $forall menuType <- menuTypes
           $case menuType
             $of NavbarAside (MenuItem label mIcon route _)

templates/widgets/navbar.lucius

@@ -3,11 +3,10 @@
   display: flex;
   flex-direction: row;
   align-items: center;
-  justify-content: space-between;
+  justify-content: flex-start;
   width: 100%;
   height: var(--header-height);
   padding-right: 2vw;
-  padding-left: calc(24% + 40px);
   background: var(--color-darker); /* Old browsers */
   background: -moz-linear-gradient(bottom, var(--color-dark) 0%, var(--color-darker) 100%); /* FF3.6-15 */
   background: -webkit-linear-gradient(bottom, var(--color-dark) 0%,var(--color-darker) 100%); /* Chrome10-25,Safari5.1-6 */
@@ -21,13 +20,6 @@
   transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);
 }
 
-@media (min-width: 1200px) {
-
-  .navbar {
-    padding-left: 340px;
-  }
-}
-
 @media (max-width: 768px) {
 
   .navbar {
@@ -36,31 +28,67 @@
 }
 
 .navbar__logo {
-  position: absolute;
+  top: 10px;
-  top: 15px;
   left: 20px;
-  transition: all .2s ease;
+  height: 80px;
-  transform-origin: left;
+  padding: 0 20px;
-  width: 0px;
+  display: flex;
+  flex-basis: 300px;
+  font-size: 16px;
+  align-items: center;
   color: var(--color-lightwhite);
+  transform-origin: left;
+  transition: all .2s ease;
 
   &:hover {
     color: var(--color-lightwhite);
   }
 
   &::before {
-    content: 'Uni2work';
+    content: 'LMU';
     font-family: var(--font-logo);
-    font-size: 42px;
     font-weight: bold;
     letter-spacing: 2px;
+    display: flex;
+    align-items: flex-end;
+    font-size: 30px;
+    min-width: 70px;
+    height: calc(100% - 4px);
+    padding: 0 6px 4px;
+    box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
+  }
+
+  &::after {
+    content: 'Uni2work';
+    margin-left: 12px;
+    font-weight: normal;
+    letter-spacing: 2px;
+    display: flex;
+    align-items: flex-end;
+    text-transform: uppercase;
+    width: 100%;
+    height: calc(100% - 4px);
+    padding: 0 6px 4px;
+    box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
+  }
+}
+
+@media (max-width: 1200px) {
+
+  .navbar__logo {
+    flex-basis: 24%;
+    font-size: 16px;
   }
 }
 
 @media (max-width: 1024px) {
 
   .navbar__logo {
-    transform: scale(0.7);
+    font-size: 14px;
+
+    &::before {
+      content: none;
+    }
   }
 }
 
@@ -75,21 +103,30 @@
 .navbar__link-wrapper {
   display: flex;
   flex-direction: column;
-  justify-content: center;
+  justify-content: flex-end;
-  align-items: center;
+  align-items: flex-start;
-  height: var(--header-height);
+  height: 80px;
+  min-width: 90px;
   color: var(--color-lightwhite);
   transition: height .2s cubic-bezier(0.03, 0.43, 0.58, 1);
+  box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
 }
 
 .navbar__link-label {
   transition: opacity .2s ease;
-  padding: 0 13px;
+  padding: 4px 6px;
   text-transform: uppercase;
 }
 
 @media (max-width: 768px) {
 
+  .navbar__link-wrapper {
+    box-shadow: none;
+    min-width: 0;
+    align-items: center;
+    justify-content: center;
+  }
+
   .navbar__link-label {
     padding: 0 7px;
   }
@@ -105,6 +142,10 @@
 /* navbar list */
 .navbar__list {
   white-space: nowrap;
+
+  + .navbar__list {
+    margin-left: 12px;
+  }
 }
 
 /* list item */
@@ -112,6 +153,10 @@
   position: relative;
   transition: background-color .1s ease;
 
+  + .navbar__list-item {
+    margin-left: 12px;
+  }
+
   .glyphicon {
     position: relative;
     width: 20px;
@@ -120,10 +165,22 @@
 
   .glyphicon::before {
     height: 20px;
+    margin-left: 6px;
   }
 
   .fas {
     height: 20px;
+    margin-left: 8px;
+  }
+}
+
+@media (max-width: 768px) {
+
+  .navbar__list-item {
+
+    .fas {
+      margin-left: 0;
+    }
   }
 }
 
@@ -134,15 +191,36 @@
   }
 }
 
+.navbar__list-left {
+  flex: 5;
+  padding-left: 40px;
+}
+
+@media (max-width: 768px) {
+
+  .navbar__list-left {
+    padding-left: 0;
+  }
+}
+
 .navbar__list-item--secondary {
   margin-left: 20px;
   color: var(--color-grey);
+
+  .navbar__link-wrapper {
+    color: var(--color-grey);
+    box-shadow: 0 0 0 1px inset var(--color-grey);
+  }
 }
 
 @media (max-width: 768px) {
 
   .navbar__list-item--secondary {
     margin-left: 0;
+
+    .navbar__link-wrapper {
+      box-shadow: none;
+    }
   }
 }
 
@@ -169,10 +247,6 @@
   color: var(--color-lightwhite);
 }
 
-.navbar__list-item--secondary .navbar__link-wrapper {
-  color: var(--color-grey);
-}
-
 /* sticky state */
 .navbar--sticky {
   height: var(--header-height-collapsed);
@@ -209,7 +283,7 @@
   }
 }
 
-@media (max-height: 768px) {
+@media (max-height: 500px) {
 
   .navbar,
   .navbar__pushdown {
@@ -222,5 +296,6 @@
 
   .navbar__logo {
     top: 5px;
+    height: var(--header-height-collapsed);
   }
 }