Better UI for submission users & submission user invitations

messages/uniworx/de.msg

@@ -198,11 +198,13 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
 SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
 CorrectionHead     tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
-SubmissionMember n@Int: Mitabgebende(r) ##{display n}
+SubmissionMembers: Abgebende
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
 SubmissionFiles: Abgegebene Dateien
-SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
+SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt.
+SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden
+SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen
 
 SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
 SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
@@ -508,6 +510,7 @@ BothSubmissions: Abgabe direkt & extern mit Pseudonym
 SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
 
 SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
+SubmissionReplace: Abgabe ersetzen
 
 AdminFeaturesHeading: Studiengänge
 StudyTerms: Studiengänge
@@ -586,6 +589,8 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S
 
 MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
 
+MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
@@ -863,6 +868,11 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #
 TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
 TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
 
+SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
+SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
+SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
+SubmissionUserInviteExplanation: Sie wurden eingeladen, Mitabgebende(r) bei einer Abgabe zu sein.
+
 InvitationAction: Aktion
 InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
 InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten

routes

@@ -107,6 +107,7 @@
       /delete                   SubDelR        GET POST        !ownerANDtime
       /assign                   SAssignR       GET POST        !lecturerANDtime
       /correction               CorrectionR    GET POST        !corrector !ownerANDreadANDrated
+      /invite                   SInviteR       GET POST        !ownerANDtime
       !/#SubmissionFileType/*FilePath SubDownloadR  GET        !owner !corrector
     /correctors                 SCorrR         GET POST
     /pseudonym                  SPseudonymR    GET POST        !course-registeredANDcorrector-submissions

src/Foundation.hs

@@ -155,6 +155,11 @@ instance HasAppSettings UniWorX where
 -- type Widget    = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+deriving instance Generic CourseR
+deriving instance Generic SheetR
+deriving instance Generic SubmissionR
+deriving instance Generic MaterialR
+deriving instance Generic TutorialR
 deriving instance Generic (Route UniWorX)
 
 -- | Convenient Type Synonyms:
@@ -503,13 +508,19 @@ validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo valid
       User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority
       guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
 
+      let
+        -- Prevent infinite loops
+        noTokenAuth :: AuthDNF -> AuthDNF
+        noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
+
       authorityVal <- do
         dnf <- either throwM return $ routeAuthTags route
-        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite
+        fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just tokenAuthority) route isWrite
       guardExceptT (is _Authorized authorityVal) authorityVal
 
       whenIsJust tokenAddAuth $ \addDNF -> do
-        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite
+        $logDebugS "validateToken" $ tshow addDNF
+        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
         guardExceptT (is _Authorized additionalVal) additionalVal
 
       return Authorized
@@ -2108,6 +2119,14 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuSubmissionNew
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
   [ MenuItem
@@ -2409,7 +2428,9 @@ routeNormalizers =
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend
-    runDB action = runSqlPool action =<< appConnPool <$> getYesod
+    runDB action = do
+      $logDebugS "YesodPersist" "runDB"
+      runSqlPool action =<< appConnPool <$> getYesod
 instance YesodPersistRunner UniWorX where
     getDBRunner = defaultGetDBRunner appConnPool
 

src/Handler/Admin.hs

@@ -191,12 +191,10 @@ postAdminTestR = do
       (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ initial <|> Just cData
       return (intRes, toWidget csrf >> fvInput intView)
     -- | How does the shape (`ListLength`) change if a certain cell is deleted?
-    deleteCell :: ListLength -- ^ Current shape
+    deleteCell :: Map ListPosition Int -- ^ Current shape, including initialisation data
                -> ListPosition -- ^ Coordinate to delete
                -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
-    deleteCell l pos
+    deleteCell = miDeleteList
-      | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)] -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
-      | otherwise = return Map.empty
     -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
     allowAdd :: ListPosition -> Natural -> ListLength -> Bool
     allowAdd _ _ l = l < 7 -- Limit list length; much more complicated checks are possible (this could in principle be monadic, but @massInput@ is probably already complicated enough to cover just current (2019-03) usecases)

src/Handler/Course.hs

@@ -686,14 +686,14 @@ instance FromJSON (InvitationDBData Lecturer) where
 
 instance ToJSON (InvitationTokenData Lecturer) where
   toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
 instance FromJSON (InvitationTokenData Lecturer) where
   parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
 
 lecturerInvitationConfig :: InvitationConfig Lecturer
 lecturerInvitationConfig = InvitationConfig{..}
   where
-    invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
+    invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
     invitationResolveFor = do
       Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
       getKeyBy404 $ TermSchoolCourseShort tid csh ssh
@@ -802,7 +802,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
           let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
           return (lrwRes,lrwView')
 
-        miDelete :: ListLength   -- ^ Current shape
+        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
                  -> ListPosition -- ^ Coordinate to delete
                  -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
         miDelete = miDeleteList

src/Handler/Sheet.hs

@@ -705,7 +705,7 @@ correctorForm shid = wFormToAForm $ do
       return (res, $(widgetFile "sheetCorrectors/cell"))
 
 
-    miDelete :: ListLength
+    miDelete :: Map ListPosition (Either UserEmail UserId)
              -> ListPosition
              -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
     miDelete = miDeleteList
@@ -814,14 +814,14 @@ instance FromJSON (InvitationDBData SheetCorrector) where
 
 instance ToJSON (InvitationTokenData SheetCorrector) where
   toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
 instance FromJSON (InvitationTokenData SheetCorrector) where
   parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
 
 correctorInvitationConfig :: InvitationConfig SheetCorrector
 correctorInvitationConfig = InvitationConfig{..}
   where
-    invitationRoute Sheet{..} _ = do
+    invitationRoute (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
     invitationResolveFor = do

src/Handler/Submission.hs

@@ -1,15 +1,21 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.Submission where
 
 import Import
 
 import Jobs
 
+import Utils.Lens
+
 -- import Yesod.Form.Bootstrap3
 
 import Handler.Utils
 import Handler.Utils.Delete
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
+import Handler.Utils.Form.MassInput
+import Handler.Utils.Invitations
 
 import Network.Mime
 
@@ -22,9 +28,6 @@ import Data.Maybe (fromJust)
 -- import qualified Data.Maybe
 import qualified Data.Text.Encoding as Text
 
-import Data.CaseInsensitive (CI)
--- import qualified Data.CaseInsensitive as CI
-
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
 
@@ -33,12 +36,16 @@ import qualified Data.Conduit.List as Conduit
 
 -- import Data.Set (Set)
 import qualified Data.Set as Set
-import Data.Map (Map)
+import Data.Map (Map, (!), (!?))
 import qualified Data.Map as Map
 -- import Data.Bifunctor
 
 import System.FilePath
 
+import Text.Blaze (Markup)
+import Data.Aeson hiding (Result(..))
+import Text.Hamlet (ihamlet)
+
 -- import Colonnade hiding (bool, fromMaybe)
 -- import qualified Yesod.Colonnade as Yesod
 -- import qualified Text.Blaze.Html5.Attributes as HA
@@ -48,30 +55,203 @@ import System.FilePath
 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> NonEmpty UserEmail -> Form (Maybe (Source Handler File), NonEmpty UserEmail)
+instance IsInvitableJunction SubmissionUser where
-makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do
+  type InvitationFor SubmissionUser = Submission
-    let
+  data InvitableJunction SubmissionUser = JunctionSubmissionUser
-      fileUploadForm = case uploadMode of
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
-        NoUpload -> pure Nothing
+  data InvitationDBData SubmissionUser = InvDBDataSubmissionUser
-        (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
-    flip (renderAForm FormStandard) html $ (,)
+  data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser
-      <$> fileUploadForm
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
-      <*> ( (:|)
-        -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
-        <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
-        <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
-                                      | g <- [2..(fromIntegral groupNr)]
-                                      | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
-                                      ])
-        )
-  where
-    (groupNr, editableBuddies)
-      | Arbitrary{..} <- grouping = (maxParticipants, True)
-      | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
-      | otherwise = (0, False)
 
-    aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
+  _InvitableJunction = iso
-    aforced' _ _  _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
+    (\SubmissionUser{..} -> (submissionUserUser, submissionUserSubmission, JunctionSubmissionUser))
+    (\(submissionUserUser, submissionUserSubmission, JunctionSubmissionUser) -> SubmissionUser{..})
+
+instance ToJSON (InvitableJunction SubmissionUser) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction SubmissionUser) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData SubmissionUser) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData SubmissionUser) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData SubmissionUser) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData SubmissionUser) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+submissionUserInvitationConfig :: InvitationConfig SubmissionUser
+submissionUserInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity subId Submission{..}) _ = do
+      Sheet{..} <- getJust submissionSheet
+      Course{..} <- getJust sheetCourse
+      cID <- encrypt subId
+      return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
+    invitationResolveFor = do
+      Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
+      subId <- decrypt cID
+      bool notFound (return subId) =<< existsKey subId
+    invitationSubject Submission{..} _ = do
+      Sheet{..} <- getJust submissionSheet
+      Course{..} <- getJust sheetCourse
+      return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
+    invitationHeading Submission{..} _ = do
+      Sheet{..} <- getJust submissionSheet
+      return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
+    invitationTokenConfig Submission{..} _ = do
+      Sheet{..} <- getJust submissionSheet
+      Course{..} <- getJust sheetCourse
+      itAuthority <- liftHandlerT requireAuthId
+      itAddAuth <- either throwM (return . Just) $ routeAuthTags (CSheetR courseTerm courseSchool courseShorthand sheetName SubmissionNewR)
+      let itExpiresAt = Nothing
+          itStartsAt = Nothing
+      return InvitationTokenConfig{..}
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ _ = pure JunctionSubmissionUser
+    invitationSuccessMsg Submission{..} _ = do
+      Sheet{..} <- getJust submissionSheet
+      return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
+    invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do
+      Sheet{..} <- getJust submissionSheet
+      Course{..} <- getJust sheetCourse
+      cID <- encrypt submissionUserSubmission
+      return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
+
+
+makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (Source Handler File), Set (Either UserEmail UserId))
+makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
+  <$> fileUploadForm
+  <*> wFormToAForm submittorsForm
+  where
+    fileUploadForm = case uploadMode of
+      NoUpload
+        -> pure Nothing
+      (Upload unpackZips)
+        -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+
+    miCell' :: Markup -> Either UserEmail UserId -> Widget
+    miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
+    miCell' csrf (Right uid) = do
+      User{..} <- liftHandlerT . runDB $ getJust uid
+      $(widgetFile "widgets/massinput/submissionUsers/cellKnown")
+
+    miLayout :: ListLength
+             -> Map ListPosition (Either UserEmail UserId, FormResult ()) -- ^ massInput state
+             -> Map ListPosition Widget -- ^ Cell widgets
+             -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+             -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+             -> Widget
+    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/submissionUsers/layout")
+
+    miIdent :: Text
+    miIdent = "submittors"
+
+    courseUsers :: E.SqlQuery (E.SqlExpr (Entity User))
+    courseUsers = E.from $ \(user `E.InnerJoin` participant) -> do
+      E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
+      E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+      E.orderBy [E.asc $ user E.^. UserEmail]
+      return user
+
+    addField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Bool -> Field m (Set (Either UserEmail UserId))
+    addField isAdmin = multiUserField True $ courseUsers <$ guard isAdmin
+
+    addFieldSettings, submittorSettings :: FieldSettings UniWorX
+    addFieldSettings = fslI MsgSubmissionMembers
+    submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip
+
+    miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag)
+
+    submittorsForm 
+      | isLecturer = do-- Form is being used by lecturer; allow Everything™
+        let
+          miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+          miAdd nudge btn csrf = do
+            MsgRenderer mr <- getMsgRenderer
+            (addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
+            let addRes' = addRes <&> \newData oldData -> if
+                  | existing <- newData `Set.intersection` Set.fromList oldData
+                  , not $ Set.null existing
+                    -> FormFailure [mr MsgSubmissionUserAlreadyAdded]
+                  | otherwise
+                    -> FormSuccess $ Set.toList newData
+            return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
+        
+        mRoute <- getCurrentRoute
+        submittors <- massInputAccumW miAdd (miCell' mempty) (miButtonAction' mRoute) miLayout miIdent submittorSettings True (Just $ Set.toList prefillUsers)
+        MsgRenderer mr <- getMsgRenderer
+        return $ submittors >>= \submittors' -> if
+          | null submittors' -> FormFailure [mr MsgSubmissionUsersEmpty]
+          | otherwise -> FormSuccess $ Set.fromList submittors'
+      | otherwise = do
+        uid <- liftHandlerT requireAuthId
+        mRoute <- getCurrentRoute
+        
+        let
+          maxSize
+            | Arbitrary{..} <- grouping = Just maxParticipants
+            | otherwise = Nothing
+          mayEdit = is _Arbitrary grouping
+
+          miAdd :: ListPosition
+                -> Natural
+                -> (Text -> Text)
+                -> FieldView UniWorX
+                -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+          miAdd _ _ nudge btn = Just $ \csrf -> do
+            MsgRenderer mr <- getMsgRenderer
+            (addRes, addView) <- mpreq (addField True) (addFieldSettings & addName (nudge "emails")) Nothing
+            let addRes' = addRes <&> \newData oldData -> if
+                  | existing <- newData `Set.intersection` setOf folded oldData
+                  , not $ Set.null existing
+                    -> FormFailure [mr MsgSubmissionUserAlreadyAdded]
+                  | otherwise -> let numStart = maybe 0 (succ . fst) $ Map.lookupMax oldData
+                                  in FormSuccess . Map.fromList . zip [numStart..] $ Set.toList newData
+            return (addRes', $(widgetFile "widgets/massinput/submissionUsers/add"))
+
+          miCell :: ListPosition
+                 -> Either UserEmail UserId
+                 -> Maybe ()
+                 -> (Text -> Text)
+                 -> Form ()
+          miCell _ dat _ _ csrf = return (FormSuccess (), miCell' csrf dat)
+
+          miDelete :: Map ListPosition (Either UserEmail UserId)
+                   -> ListPosition
+                   -> MaybeT (MForm Handler) (Map ListPosition ListPosition)
+          miDelete dat delPos = do
+            guard mayEdit
+            guard $ Map.size dat > 1
+
+            -- User may drop from submission only if it already exists; no directly creating submissions for other people
+            guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid 
+
+            miDeleteList dat delPos
+
+          miAllowAdd :: ListPosition
+                     -> Natural
+                     -> ListLength
+                     -> Bool
+          miAllowAdd _ _ l = mayEdit && maybe False ((l <) . fromIntegral) maxSize
+
+          miAddEmpty _ _ _ = Set.empty
+
+          miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+          miButtonAction = miButtonAction' mRoute
+
+          postProcess :: Map ListPosition (Either UserEmail UserId, ()) -> Set (Either UserEmail UserId)
+          postProcess = setOf $ folded . _1
+        fmap postProcess <$> massInputW MassInput{..} submittorSettings True (Just . Map.fromList . zip [0..] . map (, ()) $ Set.toList prefillUsers)
+        
 
 getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
 getSubmissionNewR = postSubmissionNewR
@@ -100,13 +280,14 @@ getSubmissionOwnR tid ssh csh shn = do
 
 submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
 submissionHelper tid ssh csh shn mcid = do
-  (Entity uid userData) <- requireAuth
+  uid <- requireAuthId
   msmid     <- traverse decrypt mcid
-  actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
+  Just actionUrl <- getCurrentRoute
-  maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
 
-  (Entity shid Sheet{..}, buddies, lastEdits)  <- runDB $ do
+  (Entity shid Sheet{..}, buddies, lastEdits, maySubmit, isLecturer, isOwner)  <- runDB $ do
     csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
+    maySubmit  <- (== Authorized) <$> evalAccessDB actionUrl True
+    isLecturer <- (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SSubsR) True
     case msmid of
       Nothing     -> do
         submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -132,8 +313,8 @@ submissionHelper tid ssh csh shn mcid = do
               E.where_ $  submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
                     E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
               E.orderBy  [E.asc $ user E.^. UserEmail]
-              return $ user E.^. UserEmail
+              return $ user E.^. UserId
-            return (csheet, map E.unValue buddies, [])
+            return (csheet, Set.fromList $ map (Right . E.unValue) buddies, [], maySubmit, isLecturer, not isLecturer)
           (E.Value smid:_) -> do
             cID <- encrypt smid
             addMessageI Info MsgSubmissionAlreadyExists
@@ -146,15 +327,18 @@ submissionHelper tid ssh csh shn mcid = do
           invalidArgsI [MsgSubmissionWrongSheet]
         -- fetch buddies from current submission
         (Any isOwner, buddies) <- do
-          submitters <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+          submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
             E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
             E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
             E.orderBy  [E.asc $ user E.^. UserEmail]
-            return (user E.^. UserId, user E.^. UserEmail)
+            return $ user E.^. UserId
-          let breakUserFromBuddies (E.Value userID, E.Value email)
+          let breakUserFromBuddies (E.Value userID)
-                | uid == userID  =  (Any True ,      [])
+                | uid == userID  =  (Any True , mempty                      )
-                | otherwise      =  (Any False, [email])
+                | otherwise      =  (mempty   , Set.singleton $ Right userID)
-          return $ foldMap breakUserFromBuddies submitters
+
+          invites <- sourceInvitationsList smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email)
+          
+          return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors
 
         lastEdits <- do
             raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
@@ -167,38 +351,38 @@ submissionHelper tid ssh csh shn mcid = do
                               else E.nothing
               return (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
-        return (csheet,buddies,lastEdits)
+        return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
-  ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
+  ((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
   let formWidget = wrapForm formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
         }
+
   mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
     res' <- case res of
       FormMissing              -> return   FormMissing
       (FormFailure failmsgs)   -> return $ FormFailure failmsgs
       -- #227 Part II: no longer ignore submitter, if the user is lecturer or admin (allow lecturers to submit for their students)
-      (FormSuccess (mFiles,_submitter:|[])) -> return $ FormSuccess (mFiles,[]) -- Type change
+      (FormSuccess res'@(_, groupMembers))
-      (FormSuccess (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members
+        | Set.null groupMembers -> return $ FormSuccess res'
-        | Arbitrary{..} <- sheetGrouping -> do
+        | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
           -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
-          let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
+          let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
+              prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
               prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
           participants <- fmap prep . E.select . E.from $ \user -> do
-            E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
+            E.where_ $ (user E.^. UserId) `E.in_` E.valList gIds
             let
-              isParticipant = E.sub_select . E.from $ \courseParticipant -> do
+              isParticipant = E.exists . E.from $ \courseParticipant -> do
                 E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
                      E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
-                return $ E.countRows E.>. E.val (0 :: Int64)
+              hasSubmitted = E.exists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
-              hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
                 E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
                 E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
                      E.&&. submission E.^. SubmissionSheet E.==. E.val shid
                 case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
                   Nothing   -> return ()
                   Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
-                return $ E.countRows E.>. E.val (0 :: Int64)
             return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
 
           $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
@@ -207,22 +391,22 @@ submissionHelper tid ssh csh shn mcid = do
           let
             failmsgs = (concat :: [[Text]] -> [Text])
               [ flip Map.foldMapWithKey participants $ \email -> \case
-                  Nothing            -> pure . mr $ MsgEMailUnknown email
+                  -- Nothing            -> pure . mr $ MsgEMailUnknown email
                   (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
                   (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
                   _other             -> mempty
-              , case fromIntegral (length participants) `compare` maxParticipants of
+              , case fromIntegral (Map.size participants) `compare` maxParticipants of
                   LT -> mempty
                   _  -> pure $ mr MsgTooManyParticipants
               ]
           return $ if null failmsgs
-            then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
+            then FormSuccess res'
             else FormFailure failmsgs
         | otherwise -> return $ FormFailure ["Mismatching number of group participants"]
 
 
     case res' of
-      (FormSuccess (mFiles, setFromList -> adhocIds)) -> do
+      (FormSuccess (mFiles, adhocMembers)) -> do
         smid <- do
           smid <- case (mFiles, msmid) of
             (Nothing, Just smid)   -- no new files, existing submission partners updated
@@ -238,19 +422,24 @@ submissionHelper tid ssh csh shn mcid = do
                   , submissionRatingAssigned = Nothing
                   , submissionRatingTime     = Nothing
                   }
-          -- Determine members of pre-registered group
+          subUsers <- if
-          groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
+            | isLecturer -> return adhocMembers
-            E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
+            | otherwise -> do
-            E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+                -- Determine members of pre-registered group
-            E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+                groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
-                E.&&.  submissionGroup     E.^. SubmissionGroupCourse   E.==. E.val sheetCourse
+                  E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
-            return $ submissionGroupUser' E.^. SubmissionGroupUserUser
+                  E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
-          -- SubmissionUser for all group members (pre-registered & ad-hoc)
+                  E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
-          let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
+                      E.&&.  submissionGroup     E.^. SubmissionGroupCourse   E.==. E.val sheetCourse
-          -- remove obsolete old entries
+                  return $ submissionGroupUser' E.^. SubmissionGroupUserUser
-          deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
+                -- SubmissionUser for all group members (pre-registered & ad-hoc)
-          -- maybe add current users
+                return $ groupUids `Set.union` adhocMembers
-          forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
+          let (subEmails, subUids) = partitionEithers $ Set.toList subUsers
+
+          deleteWhere [SubmissionUserSubmission ==. smid]
+          deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails]
+          insertMany_ $ map (flip SubmissionUser smid) subUids
+          sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails
           return smid
         cID <- encrypt smid
         return $ Just cID
@@ -327,6 +516,10 @@ submissionHelper tid ssh csh shn mcid = do
         urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
     $(widgetFile "submission")
 
+getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSInviteR = postSInviteR
+postSInviteR = invitationR submissionUserInvitationConfig
+
 
 getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
 getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do

src/Handler/Tutorial.hs

@@ -227,14 +227,14 @@ instance FromJSON (InvitationDBData Tutor) where
 
 instance ToJSON (InvitationTokenData Tutor) where
   toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
-  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
 instance FromJSON (InvitationTokenData Tutor) where
   parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
 
 tutorInvitationConfig :: InvitationConfig Tutor
 tutorInvitationConfig = InvitationConfig{..}
   where
-    invitationRoute Tutorial{..} _ = do
+    invitationRoute (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
     invitationResolveFor = do

src/Handler/Utils/Communication.hs

@@ -162,7 +162,7 @@ commR CommunicationRoute{..} =  do
                 hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
                 categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
             $(widgetFile "widgets/communication/recipientLayout")
-          miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
+          miDelete :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId) -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
           -- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
           miDelete _ _ = mzero
           miIdent :: Text

src/Handler/Utils/Form/MassInput.hs

@@ -8,7 +8,7 @@ module Handler.Utils.Form.MassInput
   , module Handler.Utils.Form.MassInput.Liveliness
   , massInputA, massInputW
   , massInputList
-  , massInputAccum, massInputAccumA
+  , massInputAccum, massInputAccumA, massInputAccumW
   , ListLength(..), ListPosition(..), miDeleteList
   , EnumLiveliness(..), EnumPosition(..)
   , MapLiveliness(..)
@@ -144,10 +144,11 @@ instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) wher
 
 
 
-miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
+miDeleteList :: Applicative m => Map ListPosition a -> ListPosition -> m (Map ListPosition ListPosition)
-miDeleteList l pos
+miDeleteList dat pos
     -- Close gap left by deleted position with values from further down the list; try prohibiting certain deletions by utilising `guard`
-  | l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
+  | Just l <- preview liveCoords $ Map.keysSet dat :: Maybe ListLength
+  , l >= 2 = pure . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
   | otherwise = pure Map.empty
 
 data ButtonMassInput coord
@@ -245,7 +246,7 @@ data MassInput handler liveliness cellData cellResult = forall i. PathPiece i =>
            -> Maybe cellResult -- Initial result from Argument to @massInput@
            -> (Text -> Text) -- Nudge deterministic field ids
            -> (Markup -> MForm handler (FormResult cellResult, Widget)) -- ^ Construct a singular cell
-  , miDelete :: liveliness
+  , miDelete :: Map (BoxCoord liveliness) cellData
              -> BoxCoord liveliness
              -> MaybeT (MForm handler) (Map (BoxCoord liveliness) (BoxCoord liveliness)) -- ^ Decide whether a deletion-operation should be permitted and produce a finite map of new coordinates to their old correspondants
   , miAllowAdd :: BoxCoord liveliness
@@ -349,13 +350,12 @@ massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvR
   addedShape <- if
     | Just s <- addShape -> return s
     | otherwise -> return sentShape'
-  addedLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet addedShape ^? liveCoords :: MForm handler liveliness
 
   let
     delForm :: BoxCoord liveliness -> MaybeT (MForm handler) (FormResult (Map (BoxCoord liveliness) (BoxCoord liveliness)), FieldView UniWorX)
     delForm miCoord = do
       (delRes, delView) <- lift $ mopt (buttonField $ MassInputDeleteCell miCoord) ("" & addName MassInputDeleteButton{..} & addFormAction) Nothing
-      shapeUpdate <- miDelete addedLiveliness miCoord
+      shapeUpdate <- miDelete addedShape miCoord
       guard $ isJust (Map.keysSet shapeUpdate ^? liveCoords :: Maybe liveliness)
       return (shapeUpdate <$ assertM (is _Just) delRes, delView)
 
@@ -545,6 +545,24 @@ massInputAccumA :: forall handler cellData ident.
 massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
   = formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
 
+massInputAccumW :: forall handler cellData ident.
+                  ( MonadHandler handler, HandlerSite handler ~ UniWorX
+                  , MonadLogger handler
+                  , ToJSON cellData, FromJSON cellData
+                  , PathPiece ident
+                  )
+               => ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
+               -> (cellData -> Widget)
+               -> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
+               -> MassInputLayout ListLength cellData ()
+               -> ident
+               -> FieldSettings UniWorX
+               -> Bool
+               -> Maybe [cellData]
+               -> WForm handler (FormResult [cellData])
+massInputAccumW miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
+  = mFormToWForm $ massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
+
 
 massInputA :: forall handler cellData cellResult liveliness.
            ( MonadHandler handler, HandlerSite handler ~ UniWorX

src/Handler/Utils/Invitations.hs

@@ -113,7 +113,7 @@ invRef = toJSON . InvRef @junction
 --
 -- It is advisable to define this once per `junction` in a global constant
 data InvitationConfig junction = InvitationConfig
-  { invitationRoute       :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
+  { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
     -- ^ Which route calls `invitationR` for this kind of invitation?
   , invitationResolveFor  :: YesodDB UniWorX (Key (InvitationFor junction))
     -- ^ Monadically resolve `InvitationFor` during `inviteR`
@@ -200,7 +200,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
         fRec <- get404 fid
         
         jInviter <- liftHandlerT requireAuthId
-        route <- mapReaderT liftHandlerT $ invitationRoute fRec dat
+        route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
         InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
         protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
         let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)

src/Handler/Utils/Tokens.hs

@@ -27,8 +27,8 @@ requireBearerToken = liftHandlerT $ do
   guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
   return token
 
-currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a)
+currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
 currentTokenRestrictions = runMaybeT $ do
-  token <- MaybeT maybeBearerToken
+  token <- requireBearerToken
   route <- MaybeT getCurrentRoute
   hoistMaybe $ preview (_tokenRestrictionIx route) token

src/Import/NoFoundation.hs

@@ -49,7 +49,7 @@ import GHC.Generics           as Import (Generic)
 import GHC.Exts               as Import (IsList)
 
 import Data.Hashable          as Import
-import Data.List.NonEmpty     as Import (NonEmpty(..))
+import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
 import Data.List.NonEmpty.Instances as Import ()
 import Data.NonNull.Instances as Import ()
 import Data.Text.Encoding.Error as Import(UnicodeException(..))

src/Model/Types.hs

@@ -557,7 +557,7 @@ derivePersistField "Theme"
 
 
 newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
-  deriving (Show, Read, Eq)
+  deriving (Show, Read, Eq, Ord, Generic, Typeable)
 
 instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
     fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
@@ -832,8 +832,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
 instance Hashable a => Hashable (PredLiteral a)
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
-  , sumEncoding = ObjectWithSingleField
+  , sumEncoding = TaggedObject "val" "var"
-  , unwrapUnaryRecords = True
   } ''PredLiteral
 
 instance PathPiece a => PathPiece (PredLiteral a) where

src/Utils.hs

@@ -77,6 +77,8 @@ import Network.Wai (requestMethod)
 
 import Data.Time.Clock
 
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+
 {-# ANN choice ("HLint: ignore Use asum" :: String) #-}
 
 
@@ -363,6 +365,9 @@ partitionWith f (x:xs) = case f x of
                          Right c -> (bs, c:cs)
     where (bs,cs) = partitionWith f xs
 
+nonEmpty' :: Alternative f => [a] -> f (NonEmpty a)
+nonEmpty' = maybe empty pure . nonEmpty
+
 ----------
 -- Sets --
 ----------
@@ -372,7 +377,8 @@ setIntersections :: Ord a => [Set a] -> Set a
 setIntersections []    = Set.empty
 setIntersections (h:t) = foldl' Set.intersection h t
 
-
+setMapMaybe :: (Ord a, Ord b) => (a -> Maybe b) -> Set a -> Set b
+setMapMaybe f = Set.fromList . mapMaybe f . Set.toList
 
 ----------
 -- Maps --

src/Utils/Form.hs

@@ -636,6 +636,10 @@ aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
       ((a, vs), ints, enctype) <- lift f
       writer ((a, ints, enctype), vs)
 
+infixl 4 `fmapAForm`
+  
+fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
+fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
 
 ---------------------------------------------
 -- Special variants of @mopt@, @mreq@, ... --

src/Utils/Lens.hs

@@ -27,6 +27,9 @@ _InnerJoinLeft  f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
 _InnerJoinRight :: Lens' (E.InnerJoin l r) r
 _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
 
+_nullable :: MonoFoldable mono => Prism' mono (NonNull mono)
+_nullable = prism' toNullable fromNullable
+
 
 -----------------------------------
 -- Lens Definitions for our Types
@@ -80,6 +83,8 @@ makeLenses_ ''SheetGrading
 
 makeLenses_ ''SheetType
 
+makePrisms ''SheetGroup
+
 makePrisms ''AuthResult
 
 makePrisms ''FormResult
@@ -112,6 +117,8 @@ makePrisms ''OccurenceException
 
 makeLenses_ ''Occurences
 
+makeLenses_ ''PredDNF
+
 
 -- makeClassy_ ''Load
 

static/js/utils/massInput.js

@@ -116,12 +116,14 @@
         var requestBody = serializeForm(submitButton, enctype);
 
         if (requestFn && requestBody) {
+          var headers = {'Mass-Input-Shortcircuit': massInputId};
+
+          if (enctype !== 'multipart/form-data')
+            headers['Content-Type'] = enctype;
+          
           requestFn(
             url,
-            {
+            headers,
-              'Content-Type': enctype,
-              'Mass-Input-Shortcircuit': massInputId,
-            },
             requestBody,
           ).then(function(response) {
             return response.text();

templates/submission.hamlet

@@ -22,7 +22,9 @@ $maybe cID <- mcid
           $nothing
             <li>#{display time}
 
-
+  $if maySubmit
-$if maySubmit
+    <section>
-  <section>
+      <h2>_{MsgSubmissionReplace}
-    ^{formWidget}
+      ^{formWidget}
+$nothing
+  ^{formWidget}

templates/widgets/massinput/submissionUsers/add.hamlet

@@ -0,0 +1,6 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{fvInput addView}
+<td>
+  ^{fvInput btn}

templates/widgets/massinput/submissionUsers/cellInvitation.hamlet

@@ -0,0 +1,10 @@
+ $newline never
+ <td>
+   #{csrf}
+   <span style="font-family: monospace">
+     #{email}
+ <td>
+   <div .tooltip>
+     <div .tooltip__handle>
+     <div .tooltip__content>
+       _{MsgEmailInvitationWarning}

templates/widgets/massinput/submissionUsers/cellKnown.hamlet

@@ -0,0 +1,4 @@
+$newline never
+<td colspan=2>
+  #{csrf}
+  ^{nameEmailWidget userEmail userDisplayName userSurname}

templates/widgets/massinput/submissionUsers/layout.hamlet

@@ -0,0 +1,13 @@
+$newline never
+<table>
+  <tbody>
+    $forall coord <- review liveCoords lLength
+      <tr .massinput__cell>
+        ^{cellWdgts ! coord}
+        <td>
+          $maybe delButton <- delButtons !? coord
+            ^{fvInput delButton}
+  $maybe addWdgt <- addWdgts !? (0, 0)
+    <tfoot>
+      <tr .massinput__cell.massinput__cell--add>
+        ^{addWdgt}

test/FoundationSpec.hs

@@ -0,0 +1,58 @@
+module FoundationSpec where
+
+import TestImport
+
+import ModelSpec ()
+
+import qualified Data.CryptoID as CID
+import Yesod.EmbeddedStatic
+
+instance Arbitrary TermId where
+  arbitrary = TermKey <$> arbitrary
+  
+instance Arbitrary SchoolId where
+  arbitrary = SchoolKey <$> arbitrary
+
+instance Arbitrary (Route Auth) where
+  arbitrary = oneof
+    [ return CheckR
+    , return LoginR
+    , return LogoutR
+    , PluginR <$> arbitrary <*> arbitrary
+    ]
+
+instance Arbitrary (Route EmbeddedStatic) where
+  arbitrary = embeddedResourceR <$> arbitrary <*> arbitrary
+
+instance Arbitrary CourseR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary SheetR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary SubmissionR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary MaterialR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary TutorialR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary (Route UniWorX) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+instance Arbitrary a => Arbitrary (CID.CryptoID ns a) where
+  arbitrary = CID.CryptoID <$> arbitrary
+
+spec :: Spec
+spec = do
+  parallel $ 
+    lawsCheckHspec (Proxy @(Route UniWorX))
+      [ eqLaws, hashableLaws, jsonLaws, jsonKeyLaws, pathPieceLaws ]

test/Model/TypesSpec.hs

@@ -148,6 +148,10 @@ instance Arbitrary AuthenticationMode where
 instance Arbitrary LecturerType where
   arbitrary = genericArbitrary
   shrink = genericShrink
+
+instance Arbitrary a => Arbitrary (ZIPArchiveName a) where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
   
 
 spec :: Spec
@@ -211,6 +215,8 @@ spec = do
       [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @LecturerType)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
+    lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text)))
+      [ eqLaws, ordLaws, showReadLaws, pathPieceLaws ]
 
   describe "TermIdentifier" $ do
     it "has compatible encoding/decoding to/from Text" . property $

test/Test/QuickCheck/Classes/Binary.hs

@@ -0,0 +1,17 @@
+module Test.QuickCheck.Classes.Binary
+  ( binaryLaws
+  ) where
+
+import ClassyPrelude
+import Test.QuickCheck
+import Test.QuickCheck.Classes
+
+import Data.Proxy (Proxy(..))
+import Data.Binary
+import Data.Binary.Put
+
+binaryLaws :: forall a. (Arbitrary a, Binary a, Eq a, Show a) => Proxy a -> Laws
+binaryLaws _ = Laws "Binary"
+  [ ("Partial Isomorphism", property $ \(a :: a) -> decode (encode a) == Just a)
+  , ("Valid list encoding", property $ \(as :: [a]) -> runPut (putList as) == runPut (put as))
+  ]

test/TestImport.hs

@@ -26,6 +26,7 @@ import Test.QuickCheck.Classes.Hashable as X
 import Test.QuickCheck.Classes.JSON as X
 import Test.QuickCheck.Classes.HttpApiData as X
 import Test.QuickCheck.Classes.Universe as X
+import Test.QuickCheck.Classes.Binary as X
 import Data.Proxy as X
 import Data.UUID as X (UUID)
 import System.IO as X (hPrint, hPutStrLn, stderr)