Mockup of SheetCorrectorsR

messages/de.msg

@@ -39,3 +39,6 @@ SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem
 EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
 NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText 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}

routes

@@ -21,13 +21,14 @@
   /edit                       CourseEditR GET POST            !lecturer
 
   /ex SheetR                                                  !registered:
-    /                                SheetListR GET
+    /                                  SheetListR       GET
-    /#Text/show                      SheetShowR GET            !time
+    /#Text/show                        SheetShowR       GET            !time
-    /#Text/#SheetFileType/#FilePath  SheetFileR GET            !time
+    /#Text/#SheetFileType/#FilePath    SheetFileR       GET            !time
-    /new                             SheetNewR  GET POST       !lecturer
+    /new                               SheetNewR        GET POST       !lecturer
-    /#Text/edit                      SheetEditR GET POST       !lecturer
+    /#Text/edit                        SheetEditR       GET POST       !lecturer
-    /#Text/delete                    SheetDelR  GET POST       !lecturer
+    /#Text/delete                      SheetDelR        GET POST       !lecturer
-    !/#Text/submission/#SubmissionMode SubmissionR GET POST    !time
+    /#Text/correctors                  SheetCorrectorsR GET POST       !lecturer
+    !/#Text/submission/#SubmissionMode SubmissionR      GET POST       !time
 
 
 !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET

src/Foundation.hs

@@ -331,6 +331,7 @@ isAuthorizedDB (CourseR t c (SheetR SheetNewR))           _ = courseLecturerAcce
 isAuthorizedDB (CourseR t c (SheetR (SheetEditR s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseR t c (SheetR (SheetDelR  s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m)))   _ = return Authorized -- TODO -- submissionAccess $ Right cID
+isAuthorizedDB (CourseR t c (SheetR (SheetCorrectorsR s)))   _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseEditIDR cID)     _ = do
   courseId <- decrypt cID
   courseLecturerAccess courseId
@@ -453,6 +454,12 @@ pageActions (CSheetR tid csh (SheetShowR shn)) =
       , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
       , menuItemAccessCallback' = return True
       }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Korrektoren"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CSheetR tid csh (SheetCorrectorsR shn)
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions TermShowR =
   [ PageActionPrime $ MenuItem

src/Handler/Sheet.hs

@@ -8,6 +8,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Handler.Sheet where
 
@@ -31,11 +33,20 @@ 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)
+
+import qualified Data.List as List
 
 import Network.Mime
 
 import qualified Data.Set as Set
 
+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) =
@@ -62,7 +73,6 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
       -- Keine SheetId im Formular!
-      , sfCorrectors   :: [(UserId,Load)]
       }
 
 
@@ -90,8 +100,7 @@ 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
-      -- <*  submitButton
     return $ case result of
       FormSuccess sheetResult
         | errorMsgs <- validateSheet sheetResult
@@ -120,14 +129,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 = do undefined
-  -- 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
@@ -298,7 +299,6 @@ getSheetEditR 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
@@ -407,3 +407,132 @@ 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, cfViewCountTut, cfViewProp :: 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 = 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.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 Loads, [FieldView UniWorX])
+correctorForm shid = do
+  cListIdent <- newFormIdent
+  formCIDs <- lift $ mapM decrypt =<< (catMaybes . map fromPathPiece <$> lookupPostParams cListIdent :: Handler [CryptoUUIDUser])
+  loads'' <- lift . runDB $ defaultLoads shid
+  let loads' = loads'' `Map.union` Map.fromList [(uid, mempty) | uid <- formCIDs]
+  
+  (addTutRes, addTutView) <- mopt emailField (fsm MsgAddCorrector) (Just Nothing)
+
+  loads <- case addTutRes of
+    FormSuccess (Just 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'
+  
+  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)
+      (countTutRes, cfViewCountTut) <- mreq checkBoxField (fs "counttut") byTutorial
+      (propRes, cfViewProp) <- mreq rationalField (fs "prop") (Just byProportion)
+      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
+
+  let
+    corrColonnade = mconcat
+      [ headed "Korrektor" $ \CorrectorForm{..} -> textCell cfUserName
+      , headed "Nach Tutorium" $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
+      , headed "Tutorium zählt gegen Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewCountTut -- TODO: set this once for entire sheet?
+      , headed "Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
+      ]
+    corrResults
+      | FormSuccess _ <- addTutRes = FormMissing
+      | otherwise = fmap Map.fromList $ sequenceA [ (,) <$> pure cfUserId <*> cfResult
+                                                  | CorrectorForm{..} <- corrData
+                                                  ]
+    idField CorrectorForm{..} = do
+      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
+
+  return (corrResults, [ FieldView
+                           { fvLabel = mempty
+                           , fvTooltip = Nothing
+                           , fvId = ""
+                           , fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData
+                           , fvErrors = Nothing
+                           , fvRequired = True
+                           }
+                       , addTutView
+                           { fvInput = fvInput addTutView >> toWidget [hamlet|<button type=submit formnovalidate>Hinzufügen|]
+                           }
+                       ])
+  
+  -- Eingabebox für Korrektor hinzufügen
+  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+
+getSheetCorrectorsR, postSheetCorrectorsR :: TermId
+                                          -> Text -- ^ Course shorthand
+                                          -> Text -- ^ Sheet name
+                                          -> Handler Html
+postSheetCorrectorsR = getSheetCorrectorsR
+getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
+  Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
+
+  ((res,formWidget), formEnctype) <- runFormPost . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+
+  let
+    formTitle = MsgSheetCorrectorsTitle tident csh shn
+    formText  = Nothing :: Maybe (SomeMessage UniWorX)
+    actionUrl = CSheetR tid csh $ SheetCorrectorsR shn
+  defaultLayout $ do
+    setTitleI $ MsgSheetCorrectorsTitle tident csh shn
+    $(widgetFile "formPageI18n")