From 6daaf6894904a523a048d695f68d98eb603bf317 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 8 May 2019 15:04:57 +0200 Subject: [PATCH 01/44] initial stub, does not compile --- messages/uniworx/de.msg | 8 +++ routes | 2 + src/Handler/Course.hs | 104 ++++++++++++++++++++++++++++++- src/Handler/Sheet.hs | 4 +- src/Handler/Tutorial.hs | 10 +-- src/Handler/Utils/Invitations.hs | 12 ++-- src/Utils/Form.hs | 6 +- 7 files changed, 130 insertions(+), 16 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7030d0c15..f35f195af 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -582,6 +582,8 @@ CommCourseSubject: Kursmitteilung MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter InvitationAcceptDecline: Einladung annehmen/ablehnen +MailSubjectParticipantInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursteilname + MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn} MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} @@ -853,6 +855,12 @@ LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursver CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName} CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein. +CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName} +CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen. +CourseParticipantEnlistDirectly: bekannte Teilnehmer sofort als Teilnehmer eintragen +CourseParticipantInviteField: einzuladende EMail Adressen + + CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} diff --git a/routes b/routes index 747207cc0..e61a0f2f4 100644 --- a/routes +++ b/routes @@ -85,6 +85,8 @@ /lecturer-invite CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET POST + !/users/new CAddUserR GET POST + !/users/invite CInviteR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 003fdfcdc..9cdd21810 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -40,7 +40,7 @@ import Jobs.Queue import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) - + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -1355,7 +1355,107 @@ postCCommR tid ssh csh = do evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } - + getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR postCLecInviteR = invitationR lecturerInvitationConfig + + + +-- Invitations for ordinary participants of this course +instance IsInvitableJunction CourseParticipant where + type InvitationFor CourseParticipant = Course + data InvitableJunction CourseParticipant = JunctionParticipant + { jParticipantRegistration :: UTCTime + , jParticipantFild :: Maybe StudyFeaturesId + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData CourseParticipant = InvDBDataParticipant + -- no data needed in DB to manage participant invitation + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData CourseParticipant = InvTokenDataParticipant + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField)) + (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..}) + + ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ())) + +instance ToJSON (InvitableJunction CourseParticipant) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction CourseParticipant) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData CourseParticipant) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationDBData CourseParticipant) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } + +instance ToJSON (InvitationTokenData CourseParticipant) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } +instance FromJSON (InvitationTokenData CourseParticipant) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } + +participantInvitationConfig :: InvitationConfig CourseParticipant +participantInvitationConfig = InvitationConfig{..} + where + invitationRoute Course{..} _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR + invitationResolveFor = do + Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute + getKeyBy404 $ TermSchoolCourseShort tid csh ssh + invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand + invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgParticipantInviteExplanation}|] + -- Keine besonderen Einschränkungen beim Einlösen der Token + -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden! + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm Course{..} _ uid = wFormToAForm $ do + now <- liftIO getCurrentTime + studyFeatures <- wreq (studyFeaturesPrimaryFieldFor [ ] (Just uid)) + (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing + return $ JunctionParticipant <$> pure now <*> studyFeatures +  invitationSuccessMsg Course{..} _ = + return . SomeMessage $ MsgParticipantInvitationAccepted courseTerm courseSchool courseShorthand + invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR + +getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCAddUserR = postCAddUserR +postCAddUserR tid ssh csh = do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + ((usersToEnlist,formWgt),formEcnoding) <- runFormPost . renderWForm FormStandard $ do + enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) + areq (multiUserField (fromMaybe False $ formResultToMaybe enlist) Nothing) + (fslI MsgCourseParticipantInviteField) Nothing + formResult usersToEnlist processUsers + where + processUsers :: Set (Either UserEmail UserId) -> Handler () + processUsers users = do + error "TODO" + {-} + let (emails,uids) = partionEithers $ Set.toList users + runDB $ do + -- send Invitation eMails to unkown users + sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] + -- register known users + (alreadyRegistered,registeredNoField,registeredOneField) <- execWriterT $ mapM registerUser uids + let statusMsg = modal _linkText (Right _widgetmessage) + statusTy = Info -- Success -- TODO + addMessageWidget statusTy statusMsg + redirect $ CourseR tid ssh csh CUsersR + + registerUser :: UserId -> WriterT ([UserEmail],[UserEmail],[UserEmail]) (YesodDB UniWorX) () + registerUser uid = do + + tell ([],[],[]) + -} + + +getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCInviteR = postCInviteR +postCInviteR = invitationR participantInvitationConfig diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5a9448177..751b77f48 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -763,7 +763,7 @@ getSCorrR tid ssh csh shn = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do update shid [ SheetAutoDistribute =. autoDistribute ] - + let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors deleteWhere [ SheetCorrectorSheet ==. shid ] @@ -836,7 +836,7 @@ correctorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state + invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest Sheet{..} _ = do Course{..} <- get404 sheetCourse diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 255f26aea..f870b43db 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -249,7 +249,7 @@ tutorInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ _ = pure JunctionTutor + invitationForm _ _ _ = pure JunctionTutor invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName invitationUltDest Tutorial{..} _ = do Course{..} <- get404 tutorialCourse @@ -279,7 +279,7 @@ tutorialForm cid template html = do Just cRoute <- getCurrentRoute uid <- liftHandlerT requireAuthId - let + let tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template) where miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) @@ -306,7 +306,7 @@ tutorialForm cid template html = do miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout") - + flip (renderAForm FormStandard) html $ TutorialForm <$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template) <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) @@ -345,7 +345,7 @@ getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> getCTutorialNewR = postCTutorialNewR postCTutorialNewR tid ssh csh = do Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - + ((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing formResult newTutResult $ \TutorialForm{..} -> do @@ -436,7 +436,7 @@ postTEditR tid ssh csh tutn = do } when (is _Nothing insertRes) $ do let (invites, adds) = partitionEithers $ Set.toList tfTutors - + deleteWhere [ TutorTutorial ==. tutid ] insertMany_ $ map (Tutor tutid) adds diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index a256a7a99..25aef86fc 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -48,7 +48,7 @@ class ( PersistRecordBackend junction (YesodPersistBackend UniWorX) type InvitationFor junction :: * -- | `junction` without `Key User` and `Key (InvitationFor junction)` data InvitableJunction junction :: * - + -- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction` -- -- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction` @@ -129,7 +129,7 @@ data InvitationConfig junction = InvitationConfig -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently) , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult -- ^ Additional restrictions to check before allowing an user to redeem an invitation token - , invitationForm :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction) + , invitationForm :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction) -- ^ Assimilate the additional data entered by the redeeming user , invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX) -- ^ What to tell the redeeming user after accepting the invitation @@ -158,7 +158,7 @@ $(return []) instance ToJSON (InvitationTokenRestriction junction) where toJSON = $(mkToJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction) - + instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction junction) where parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction) @@ -198,7 +198,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif ur <- getUrlRenderParams fRec <- get404 fid - + jInviter <- liftHandlerT requireAuthId route <- mapReaderT liftHandlerT $ invitationRoute fRec dat InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat @@ -284,7 +284,7 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do iData = review _InvitationData (dbData, itData) guardAuthResult =<< invitationRestriction fRec iData ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do - dataRes <- aFormToWForm $ invitationForm fRec iData + dataRes <- aFormToWForm $ invitationForm fRec iData invitee btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction)) case btnRes of FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing @@ -333,7 +333,7 @@ instance InvitationR (Handler Html) where instance InvitationR b => InvitationR (a -> b) where invitationR cfg _ = invitationR cfg - + -- $procedure -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index d4d0ba97e..465ef1cd4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -8,7 +8,7 @@ import Settings import Utils.Parameters --- import Text.Blaze (toMarkup) -- for debugging +import Text.Blaze (Markup) import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T @@ -498,6 +498,10 @@ renderAForm formLayout aform fragment = do let widget = $(widgetFile "widgets/aform/aform") return (res, widget) +renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here) + (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) +renderWForm formLayout = renderAForm formLayout . wFormToAForm + -- | special id to identify form section headers, see 'aformSection' and 'formSection' -- currently only treated by form generation through 'renderAForm' From b908fc4cf3422872b2195b7c33f36e552e0e6202 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 May 2019 14:49:56 +0200 Subject: [PATCH 02/44] Sheet: icon mark unpublished files works now --- routes | 3 ++- src/Handler/Course.hs | 9 +++---- src/Handler/Material.hs | 8 +++---- src/Handler/Sheet.hs | 41 +++++++++++++++++++++----------- src/Handler/Utils/Sheet.hs | 9 +++++++ src/Handler/Utils/Table/Cells.hs | 8 ++++++- src/Utils.hs | 21 +++++++++++++++- src/Utils/Form.hs | 20 +++++----------- templates/table/cell/body.hamlet | 2 +- 9 files changed, 81 insertions(+), 40 deletions(-) diff --git a/routes b/routes index 747207cc0..228583752 100644 --- a/routes +++ b/routes @@ -88,7 +88,7 @@ /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST - /notes CNotesR GET POST !corrector + /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /subs CCorrectionsR GET POST /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST @@ -109,6 +109,7 @@ /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST + /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/ SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 003fdfcdc..b73e6a1bb 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -40,7 +40,7 @@ import Jobs.Queue import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) - + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -1298,8 +1298,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- NOTE: The route getNotesR is abused for correctorORlecturer access rights! -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared? -- If they are shared, adjust MsgCourseUserNoteTooltip -getCNotesR = error "CNotesR: Not implemented" -postCNotesR = error "CNotesR: Not implemented" +getCNotesR = postCNotesR +postCNotesR _ _ _ = do + defaultLayout $ [whamlet|You have corrector access to this course.|] getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -1355,7 +1356,7 @@ postCCommR tid ssh csh = do evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } - + getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR postCLecInviteR = invitationR lecturerInvitationConfig diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b641b8ec3..b12b3b9af 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -170,13 +170,13 @@ getMShowR tid ssh csh mnm = do let matLink :: FilePath -> Route UniWorX matLink = CourseR tid ssh csh . MaterialR mnm . MFileR - seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility + seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility ( Entity _mid material@Material{materialType, materialDescription} , (Any hasFiles,fileTable)) <- runDB $ do matEnt <- fetchMaterial tid ssh csh mnm - let materialModDateCell :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) - materialModDateCell = if seeAllModificationTimestamps + let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) + materialModDateCol = if seeAllModificationTimestamps then colFileModification else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt) let psValidator = def & defaultSortingByFileTitle @@ -190,7 +190,7 @@ getMShowR tid ssh csh mnm = do , dbtColonnade = widgetColonnade $ mconcat [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty , colFilePathSimple (view $ _dbrOutput . _1) matLink - , materialModDateCell (view $ _dbrOutput . _2) + , materialModDateCol (view $ _dbrOutput . _2) ] , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr , dbtStyle = def diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6187c4580..749cd9a09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -298,18 +298,18 @@ getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do now <- liftIO getCurrentTime Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn - -- without Colonnade --- fileNameTypes <- runDB $ E.select $ E.from $ --- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do --- -- Restrict to consistent rows that correspond to each other --- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) --- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) --- -- filter to requested file --- E.where_ (sheet E.^. SheetId E.==. E.val sid ) --- -- return desired columns --- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) --- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes - -- with Colonnade + seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility + + let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a + sftVisible sft | Just dts <- sheetFileTypeDates sheet sft + = dateTimeCellVisible now dts + | otherwise = isVisibleCell False + + sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a + sftModification sft mtime + | seeAllModificationTimestamps = dateTimeCell mtime + | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime + | otherwise = mempty let fileData (sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other @@ -321,12 +321,15 @@ getSShowR tid ssh csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) + -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell (CSheetR tid ssh csh shn (SFileR fType fName)) (str2widget fName) - -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) + , sortable (toNothing "visible") (i18nCell MsgVisibleFrom) + $ \(_, _ , E.Value ftype) -> sftVisible ftype + , sortable (Just "time") (i18nCell MsgFileModified) + $ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified -- , colFileModification (view _2) - , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCellVisible now modified ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable @@ -346,6 +349,9 @@ getSShowR tid ssh csh shn = do , ( "path" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) + -- , ( "visible" + -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet + -- ) , ( "time" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) @@ -846,3 +852,10 @@ correctorInvitationConfig = InvitationConfig{..} getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSCorrInviteR = postSCorrInviteR postSCorrInviteR = invitationR correctorInvitationConfig + + +getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet! +getSIsCorrR _ _ _ shn = do + defaultLayout $ [whamlet|You have corrector access to #{shn}.|] + diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 0dbef5706..9909f0e7d 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -7,6 +7,15 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E +-- | Map sheet file types to their visibily dates of a given sheet, for convenience +sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime +sheetFileTypeDates Sheet{..} = \case + SheetExercise -> Just sheetActiveFrom + SheetHint -> sheetHintFrom + SheetSolution -> sheetSolutionFrom + SheetMarking -> Nothing + + fetchSheetAux :: ( BaseBackend backend ~ SqlBackend , E.SqlSelect b a , Typeable a, MonadHandler m, IsPersistBackend backend diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e5906e993..c135e851b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -87,6 +87,12 @@ commentCell Nothing = mempty commentCell (Just link) = anchorCell link icon where icon = toWidget $ hasComment True +isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a +isVisibleCell True = cell . toWidget $ isVisible True +isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass + where + addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning + -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) @@ -109,7 +115,7 @@ dateTimeCellVisible watershed t | otherwise = cell timeStampWgt where timeStampWgt = formatTimeW SelFormatDateTime t - addUrgencyClass = over cellAttrs $ insertAttr "class" $ statusToUrgencyClass Warning + addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname diff --git a/src/Utils.hs b/src/Utils.hs index 7f85d43a7..64e352bd1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -335,7 +335,26 @@ lastMaybe (_:t) = lastMaybe t lastMaybe' :: [a] -> Maybe a lastMaybe' l = fmap snd $ l ^? _Snoc --- | Merge two lists of attribures, also see `Utils.Form.insertAttrs` + +-- | Merge/Add any attribute-value pair to an existing list of such pairs. +-- If the attribute exists, the new valu will be prepended, separated by a single empty space +-- Also see `Utils.mergeAttrs` +insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] +insertAttr attr valu = aux + where + aux :: [(Text,Text)] -> [(Text,Text)] + aux [] = [(attr,valu)] + aux (p@(a,v) : t) + | attr==a = (a, Text.append valu $ Text.cons ' ' v) : t + | otherwise = p : aux t + +-- | Add another class attribute; special function for a frequent case to avoid mistyping "class". +-- Also see `Utils.insertAttrs` +insertClass :: Text -> [(Text,Text)] -> [(Text,Text)] +insertClass = insertAttr "class" + +-- | Append two lists of attributes, merging the class attribute only. +-- Also see `Utils.insertAttr` to merge any attribute mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index b0b4413ac..15f824b08 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -33,9 +33,10 @@ import Web.PathPieces import Data.UUID -import Utils.Message -import Utils.PathPiece -import Utils.Route +import Utils +-- import Utils.Message +-- import Utils.PathPiece +-- import Utils.Route import Data.Proxy @@ -82,17 +83,8 @@ fslpI lbl placeholder , fsAttrs = [("placeholder", placeholder)] } --- | Merge/Add an attribute-value Pair to an existing list of such pairs. --- If the attribute exists, the new valu will be prepended, separated by a single empty space --- Also see `Utils.mergeAttrs` -insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] -insertAttr attr valu = aux - where - aux :: [(Text,Text)] -> [(Text,Text)] - aux [] = [(attr,valu)] - aux (p@(a,v) : t) - | attr==a = (a, T.append valu $ cons ' ' v) : t - | otherwise = p : aux t + +-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs } diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet index 46bf50fd1..0928779b9 100644 --- a/templates/table/cell/body.hamlet +++ b/templates/table/cell/body.hamlet @@ -1,4 +1,4 @@ $newline never - +
^{widget} From 06df42e43b8d6abc9d4692903687b889383b7ddb Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 May 2019 14:53:48 +0200 Subject: [PATCH 03/44] Better UI for submission users & submission user invitations --- messages/uniworx/de.msg | 14 +- routes | 1 + src/Foundation.hs | 27 +- src/Handler/Admin.hs | 6 +- src/Handler/Course.hs | 6 +- src/Handler/Sheet.hs | 6 +- src/Handler/Submission.hs | 327 ++++++++++++++---- src/Handler/Tutorial.hs | 4 +- src/Handler/Utils/Communication.hs | 2 +- src/Handler/Utils/Form/MassInput.hs | 32 +- src/Handler/Utils/Invitations.hs | 4 +- src/Handler/Utils/Tokens.hs | 4 +- src/Import/NoFoundation.hs | 2 +- src/Model/Types.hs | 5 +- src/Utils.hs | 8 +- src/Utils/Form.hs | 4 + src/Utils/Lens.hs | 7 + static/js/utils/massInput.js | 10 +- templates/submission.hamlet | 10 +- .../massinput/submissionUsers/add.hamlet | 6 + .../submissionUsers/cellInvitation.hamlet | 10 + .../submissionUsers/cellKnown.hamlet | 4 + .../massinput/submissionUsers/layout.hamlet | 13 + test/FoundationSpec.hs | 58 ++++ test/Model/TypesSpec.hs | 6 + test/Test/QuickCheck/Classes/Binary.hs | 17 + test/TestImport.hs | 1 + 27 files changed, 485 insertions(+), 109 deletions(-) create mode 100644 templates/widgets/massinput/submissionUsers/add.hamlet create mode 100644 templates/widgets/massinput/submissionUsers/cellInvitation.hamlet create mode 100644 templates/widgets/massinput/submissionUsers/cellKnown.hamlet create mode 100644 templates/widgets/massinput/submissionUsers/layout.hamlet create mode 100644 test/FoundationSpec.hs create mode 100644 test/Test/QuickCheck/Classes/Binary.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7030d0c15..ed32f7571 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/routes b/routes index 747207cc0..68a910db0 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 9161ef86a..d9ec45191 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 3e5306383..b727e912e 100644 --- a/src/Handler/Admin.hs +++ b/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 - | 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 + deleteCell = miDeleteList -- | 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) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 003fdfcdc..24fe8fb2a 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 5a9448177..308cb95b4 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 99149b23c..080ac9667 100644 --- a/src/Handler/Submission.hs +++ b/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) -makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FIDsubmission $ \html -> do - let - 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 - flip (renderAForm FormStandard) html $ (,) - <$> fileUploadForm - <*> ( (:|) - -- #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) +instance IsInvitableJunction SubmissionUser where + type InvitationFor SubmissionUser = Submission + data InvitableJunction SubmissionUser = JunctionSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData SubmissionUser = InvDBDataSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData SubmissionUser = InvTokenDataSubmissionUser + deriving (Eq, Ord, Read, Show, Generic, Typeable) - aforced' f fs (Just (Just v)) = Just <$> aforced f fs v - aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" + _InvitableJunction = iso + (\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 - maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc. + Just actionUrl <- getCurrentRoute - (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 (csheet, map E.unValue buddies, []) + return $ user E.^. UserId + 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) - let breakUserFromBuddies (E.Value userID, E.Value email) - | uid == userID = (Any True , []) - | otherwise = (Any False, [email]) - return $ foldMap breakUserFromBuddies submitters + return $ user E.^. UserId + let breakUserFromBuddies (E.Value userID) + | uid == userID = (Any True , mempty ) + | otherwise = (mempty , Set.singleton $ Right userID) + + 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) - ((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies) + return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner) + ((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 (mFiles,_submitter:|gEMails@(_:_))) -- Validate AdHoc Group Members - | Arbitrary{..} <- sheetGrouping -> do + (FormSuccess res'@(_, groupMembers)) + | Set.null groupMembers -> return $ FormSuccess res' + | 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.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do + hasSubmitted = E.exists . 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 - groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup - E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid - E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse - return $ submissionGroupUser' E.^. SubmissionGroupUserUser - -- SubmissionUser for all group members (pre-registered & ad-hoc) - let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds - -- remove obsolete old entries - deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers] - -- maybe add current users - forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid + subUsers <- if + | isLecturer -> return adhocMembers + | otherwise -> do + -- Determine members of pre-registered group + groupUids <- fmap (setFromList . map (Right . E.unValue)) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup + E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + E.&&. submissionGroup E.^. SubmissionGroupCourse E.==. E.val sheetCourse + return $ submissionGroupUser' E.^. SubmissionGroupUserUser + -- SubmissionUser for all group members (pre-registered & ad-hoc) + return $ groupUids `Set.union` adhocMembers + 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 diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 255f26aea..b3b12fad3 100644 --- a/src/Handler/Tutorial.hs +++ b/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 diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index c82c574ee..31a8cbb89 100644 --- a/src/Handler/Utils/Communication.hs +++ b/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 diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index 2c6560876..9119b031a 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/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 l pos +miDeleteList :: Applicative m => Map ListPosition a -> ListPosition -> m (Map ListPosition ListPosition) +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 diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index a256a7a99..a8d0223ae 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/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) diff --git a/src/Handler/Utils/Tokens.hs b/src/Handler/Utils/Tokens.hs index 8ca5ad400..736bb929a 100644 --- a/src/Handler/Utils/Tokens.hs +++ b/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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 73e1dbe8d..7006bd5e5 100644 --- a/src/Import/NoFoundation.hs +++ b/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(..)) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 0791bb218..1086b40ec 100644 --- a/src/Model/Types.hs +++ b/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 - , unwrapUnaryRecords = True + , sumEncoding = TaggedObject "val" "var" } ''PredLiteral instance PathPiece a => PathPiece (PredLiteral a) where diff --git a/src/Utils.hs b/src/Utils.hs index 4ca14e49c..1cad95098 100644 --- a/src/Utils.hs +++ b/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 -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 862c204fb..3d63b4f4a 100644 --- a/src/Utils/Form.hs +++ b/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@, ... -- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 7a7c6a4db..d52b852c8 100644 --- a/src/Utils/Lens.hs +++ b/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 diff --git a/static/js/utils/massInput.js b/static/js/utils/massInput.js index d77a4b942..5d75a7c6c 100644 --- a/static/js/utils/massInput.js +++ b/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, - { - 'Content-Type': enctype, - 'Mass-Input-Shortcircuit': massInputId, - }, + headers, requestBody, ).then(function(response) { return response.text(); diff --git a/templates/submission.hamlet b/templates/submission.hamlet index b64a9a41c..c48654517 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -22,7 +22,9 @@ $maybe cID <- mcid $nothing
  • #{display time} - -$if maySubmit -
    - ^{formWidget} + $if maySubmit +
    +

    _{MsgSubmissionReplace} + ^{formWidget} +$nothing + ^{formWidget} diff --git a/templates/widgets/massinput/submissionUsers/add.hamlet b/templates/widgets/massinput/submissionUsers/add.hamlet new file mode 100644 index 000000000..7986b68e3 --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput btn} diff --git a/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet b/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet new file mode 100644 index 000000000..6050ac678 --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/cellInvitation.hamlet @@ -0,0 +1,10 @@ + $newline never + + #{csrf} + + #{email} + +
    +
    +
    + _{MsgEmailInvitationWarning} diff --git a/templates/widgets/massinput/submissionUsers/cellKnown.hamlet b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet new file mode 100644 index 000000000..f6d3beaef --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/cellKnown.hamlet @@ -0,0 +1,4 @@ +$newline never + + #{csrf} + ^{nameEmailWidget userEmail userDisplayName userSurname} diff --git a/templates/widgets/massinput/submissionUsers/layout.hamlet b/templates/widgets/massinput/submissionUsers/layout.hamlet new file mode 100644 index 000000000..f1842a72f --- /dev/null +++ b/templates/widgets/massinput/submissionUsers/layout.hamlet @@ -0,0 +1,13 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgt} diff --git a/test/FoundationSpec.hs b/test/FoundationSpec.hs new file mode 100644 index 000000000..04081f1b9 --- /dev/null +++ b/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 ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index b042b2aa6..7e725c166 100644 --- a/test/Model/TypesSpec.hs +++ b/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 $ diff --git a/test/Test/QuickCheck/Classes/Binary.hs b/test/Test/QuickCheck/Classes/Binary.hs new file mode 100644 index 000000000..1261ce44b --- /dev/null +++ b/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)) + ] diff --git a/test/TestImport.hs b/test/TestImport.hs index 4ba8082bd..522201f4c 100644 --- a/test/TestImport.hs +++ b/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) From 1981c3b9d07b8811337a20147fbbaad23c71226f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 May 2019 14:55:19 +0200 Subject: [PATCH 04/44] grant tutors at least timed sheet access --- routes | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/routes b/routes index 228583752..5ecd799a0 100644 --- a/routes +++ b/routes @@ -95,7 +95,7 @@ /ex/current SheetCurrentR GET !course-registered !materials !corrector /ex/unassigned SheetOldUnassigned GET /ex/#SheetName SheetR: - /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector + /show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /edit SEditR GET POST /delete SDelR GET POST /subs SSubsR GET POST -- for lecturer only @@ -112,7 +112,7 @@ /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/ SCorrInviteR GET POST - !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector + !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor /file MaterialListR GET !course-registered !materials !corrector !tutor /file/new MaterialNewR GET POST /file/#MaterialName MaterialR: From 5123ca27497c35c316a76d85a2242a6470eaaa81 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 May 2019 14:59:45 +0200 Subject: [PATCH 05/44] #357 corrections upload limit noted --- templates/corrections-upload-instructions/de.hamlet | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/templates/corrections-upload-instructions/de.hamlet b/templates/corrections-upload-instructions/de.hamlet index 0a04c6c4f..f21254519 100644 --- a/templates/corrections-upload-instructions/de.hamlet +++ b/templates/corrections-upload-instructions/de.hamlet @@ -20,3 +20,8 @@ Temporäre Dateien einer eventuellen Vorkorrektur müssen also durch das Hochladen der Korrekturen des letzten Korrektors gelöscht werden, falls diese den Abgabenden nicht zur Verfügung gestellt werden sollen. + +
    +

    + Achtung: + Das Limit für die Dateigröße beträgt momentan ungefähr 52MB \ No newline at end of file From b0d23bca7991dbdb7bdf4d4401a586d5ceb74167 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 May 2019 15:54:32 +0200 Subject: [PATCH 06/44] Fixes #357 --- config/settings.yml | 2 +- src/Handler/Corrections.hs | 1 + src/Utils.hs | 23 +++++++++++++++++++ .../corrections-upload-instructions/de.hamlet | 7 +++--- 4 files changed, 28 insertions(+), 5 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 974b2e7e2..aba8f93c3 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -29,7 +29,7 @@ notification-expiration: 259201 session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 -maximum-content-length: 52428800 +maximum-content-length: 134217728 health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller health-check-http: "_env:HEALTHCHECK_HTTP:true" health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 4ef07e77d..01af2b880 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -721,6 +721,7 @@ postCorrectionsUploadR = do , formEncoding = uploadEncoding } + maxUploadMB <- appMaximumContentLength <$> getsYesod appSettings' defaultLayout $ do let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions") diff --git a/src/Utils.hs b/src/Utils.hs index 4fee6e818..9b764fc12 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -262,6 +262,22 @@ textPercent x = lz <> pack (show rx) <> "%" textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead? textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole +-- | Convert number of bytes to human readable format +textBytes :: Integral a => a -> Text +textBytes x + | v < kb = rshow v <> "B" + | v < mb = rshow (v/kb) <> "KB" + | v < gb = rshow (v/mb) <> "MB" + | otherwise = rshow (v/gb) <> "GB" + where + v = fromIntegral x + kb = 1024 + mb = 1024 * kb + gb = 1024 * mb + rshow :: Double -> Text + rshow = tshow . floorToDigits 1 + + stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter @@ -294,6 +310,13 @@ notUsedT = notUsed roundToNearestMultiple :: Int -> Int -> Int roundToNearestMultiple m n = (n `div` m + 1) * m +roundToDigits :: (RealFrac a, Integral b) => b -> a -> a +roundToDigits d x = fromInteger (round $ x * prec) / prec + where prec = 10^d + +floorToDigits :: (RealFrac a, Integral b) => b -> a -> a +floorToDigits d x = fromInteger (floor $ x * prec) / prec + where prec = 10^d diff --git a/templates/corrections-upload-instructions/de.hamlet b/templates/corrections-upload-instructions/de.hamlet index f21254519..44e5deb4d 100644 --- a/templates/corrections-upload-instructions/de.hamlet +++ b/templates/corrections-upload-instructions/de.hamlet @@ -21,7 +21,6 @@ Korrekturen des letzten Korrektors gelöscht werden, falls diese den Abgabenden nicht zur Verfügung gestellt werden sollen. -

    -

    - Achtung: - Das Limit für die Dateigröße beträgt momentan ungefähr 52MB \ No newline at end of file + $maybe maxUpload <- maxUploadMB +

    + Das Limit für die Dateigröße beträgt momentan #{textBytes maxUpload} \ No newline at end of file From caef74e95541b2d6900e609778d9deb50fc5c551 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 9 May 2019 16:17:43 +0200 Subject: [PATCH 07/44] Make maximum-content-length easier configurable at runtime See #357 --- config/settings.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config/settings.yml b/config/settings.yml index aba8f93c3..592b09ca1 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -29,7 +29,7 @@ notification-expiration: 259201 session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 -maximum-content-length: 134217728 +maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller health-check-http: "_env:HEALTHCHECK_HTTP:true" health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true" From a0de628d9bca3b625602f97b61fb410da6cc6c42 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 May 2019 17:00:01 +0200 Subject: [PATCH 08/44] display tutors on course page --- src/Handler/Course.hs | 14 ++++++++++---- templates/course.hamlet | 10 ++++++++++ 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 1def7e552..ef52f3c9a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -280,7 +280,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -312,7 +312,13 @@ getCShowR tid ssh csh = do E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) - return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors) + tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do + E.on $ tutor E.^. TutorUser E.==. user E.^. UserId + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] + return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname ) + return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course @@ -338,14 +344,14 @@ getCShowR tid ssh csh = do [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> textCell (CI.original tutorialName) , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do - tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do + tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) return [whamlet| $newline never

    + $maybe delButton <- delButtons !? coord + ^{fvInput delButton} + $maybe addWdgt <- addWdgts !? (0, 0) +
    _{MsgStudyFeatureUpdate} $forall ((Entity _ StudyFeatures{..}), (Entity _ degree), (Entity _ field)) <- studies $with _ <- notUsedT studyFeaturesUser - +
    _{field}#{notUsedT studyFeaturesField} _{degree}#{notUsedT studyFeaturesDegree} _{studyFeaturesType} #{display studyFeaturesSemester} #{hasTickmark studyFeaturesValid} ^{formatTimeW SelFormatDate studyFeaturesUpdated} + $maybe _ <- mRegistration +
    _{MsgCourseStudyFeature} +
    ^{regFieldWidget}
    - - - ^{noteView} + ^{noteWidget} diff --git a/templates/course.hamlet b/templates/course.hamlet index 29eac6294..93d788a26 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -83,7 +83,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $# regForm is defined through templates/widgets/registerForm ^{regForm} $maybe date <- mRegAt - _{MsgRegisteredSince date} + _{MsgRegisteredSince} #{date}
    Material
    From 801b92bccf5442c1415d641e725947d664287861 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 10 May 2019 21:43:47 +0200 Subject: [PATCH 28/44] Loosen tutorial-communication-recipient restrictions --- routes | 2 +- src/Handler/Tutorial.hs | 10 ++++++++-- src/Handler/Utils/Communication.hs | 2 +- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/routes b/routes index dfbc06ace..16c16692e 100644 --- a/routes +++ b/routes @@ -88,7 +88,7 @@ /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST - /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! + /notes CNotesR GET POST !corrector !tutor -- THIS route is used to check for overall course corrector access! /subs CCorrectionsR GET POST /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 47d71ec86..b5743fb2c 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -197,8 +197,14 @@ postTCommR tid ssh csh tutn = do ) ] , crRecipientAuth = Just $ \uid -> do - cID <- encrypt uid - evalAccessDB (CourseR tid ssh csh $ CUserR cID) False + [E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser -> + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid + E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid + + isAssociated <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False + return $ if + | isTutorialUser -> Authorized + | otherwise -> isAssociated } diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 31a8cbb89..d56dc8fd1 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -75,7 +75,7 @@ instance RenderMessage UniWorX RecipientCategory where data CommunicationRoute = CommunicationRoute { crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User))) - , crRecipientAuth :: Maybe (UserId -> DB AuthResult) + , crRecipientAuth :: Maybe (UserId -> DB AuthResult) -- ^ Only resolve userids given as GET-Parameter if they fulfil this criterion , crJobs :: Communication -> Source (YesodDB UniWorX) Job , crHeading :: SomeMessage UniWorX , crUltDest :: SomeRoute UniWorX From 4270e0a3477976fba9db10cfafbb39af2657afb5 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 10 May 2019 21:49:52 +0200 Subject: [PATCH 29/44] Re-tighten permissions on CNotesR --- routes | 4 ++-- src/Handler/Tutorial.hs | 7 +++++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/routes b/routes index 16c16692e..711599b14 100644 --- a/routes +++ b/routes @@ -88,7 +88,7 @@ /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST - /notes CNotesR GET POST !corrector !tutor -- THIS route is used to check for overall course corrector access! + /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /subs CCorrectionsR GET POST /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST @@ -124,7 +124,7 @@ /load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor /download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor /zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor - /tuts CTutorialListR GET !tutor + /tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access! /tuts/new CTutorialNewR GET POST /tuts/#TutorialName TutorialR: /edit TEditR GET POST diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index b5743fb2c..140743ce8 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -201,10 +201,13 @@ postTCommR tid ssh csh tutn = do E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid - isAssociated <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False + isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False + isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False + + mr <- getMsgRenderer return $ if | isTutorialUser -> Authorized - | otherwise -> isAssociated + | otherwise -> orAR mr isAssociatedCorrector isAssociatedTutor } From 78de0ee5bb2e305e924e1ecbf45148031f5769bb Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Fri, 10 May 2019 23:22:45 +0200 Subject: [PATCH 30/44] debounce auto-submit ajax calls --- static/js/utils/form.js | 31 +++++++++++++++++++++++++------ 1 file changed, 25 insertions(+), 6 deletions(-) diff --git a/static/js/utils/form.js b/static/js/utils/form.js index f19b27f52..da02abd5d 100644 --- a/static/js/utils/form.js +++ b/static/js/utils/form.js @@ -304,7 +304,8 @@ var autoSubmitInputUtil = function(element) { var form; - + var debouncedHandler; + function autoSubmit() { form.submit(); } @@ -319,15 +320,17 @@ throw new Error('Could not determine associated form for auto submit input'); } - element.addEventListener('change', autoSubmit); - + debouncedHandler = debounce(autoSubmit, 500); + + element.addEventListener('input', debouncedHandler); + element.classList.add(AUTO_SUBMIT_INPUT_INITIALIZED_CLASS); return { name: AUTO_SUBMIT_INPUT_UTIL_NAME, element: element, - destroy: function() { - element.removeEventListener('change', autoSubmit); + destroy: function() { + element.removeEventListener('input', debouncedHandler); }, }; } @@ -471,7 +474,7 @@ }; } - return init(); + return init(); }; formUtilities.push({ @@ -480,6 +483,22 @@ setup: datepickerUtil, }); + // debounce function, taken from Underscore.js + function debounce(func, wait, immediate) { + var timeout; + return function() { + var context = this, args = arguments; + var later = function() { + timeout = null; + if (!immediate) func.apply(context, args); + }; + var callNow = immediate && !timeout; + clearTimeout(timeout); + timeout = setTimeout(later, wait); + if (callNow) func.apply(context, args); + }; + } + // register the collected form utilities if (UtilRegistry) { formUtilities.forEach(UtilRegistry.register); From 2874d7a8477b8cabc72b970d3b28c0112704b2b2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 11 May 2019 20:14:59 +0200 Subject: [PATCH 31/44] Deployment tweaks (working socket activation) --- config/settings.yml | 2 ++ models/courses | 2 +- models/tutorials | 2 +- models/users | 4 ++-- package.yaml | 2 +- src/Application.hs | 22 +++++++++++++----- src/Jobs.hs | 23 ++++++++++--------- src/Model/Migration.hs | 52 +++++++++++++++++++++++++++++++++++------- src/Settings.hs | 2 ++ stack.yaml | 6 +++-- test/Database.hs | 8 +++---- 11 files changed, 89 insertions(+), 36 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 592b09ca1..049692e5b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -64,6 +64,8 @@ database: database: "_env:PGDATABASE:uniworx" poolsize: "_env:PGPOOLSIZE:10" +auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' + ldap: host: "_env:LDAPHOST:" tls: "_env:LDAPTLS:" diff --git a/models/courses b/models/courses index 4fcf67d65..5be19103a 100644 --- a/models/courses +++ b/models/courses @@ -33,7 +33,7 @@ CourseFavourite -- which user accessed which course when, only display Lecturer -- course ownership user UserId course CourseId - type LecturerType default='"lecturer"' + type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table CourseParticipant -- course enrolement course CourseId diff --git a/models/tutorials b/models/tutorials index 78571389c..444d988cd 100644 --- a/models/tutorials +++ b/models/tutorials @@ -9,7 +9,7 @@ Tutorial json registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe - lastChanged UTCTime default='NOW()' + lastChanged UTCTime default=now() UniqueTutorial course name Tutor tutorial TutorialId diff --git a/models/users b/models/users index cd08164d1..f0b3e683e 100644 --- a/models/users +++ b/models/users @@ -22,7 +22,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined timeFormat DateTimeFormat "default='%R'" -- preferred Time-only display format for user; user-defined downloadFiles Bool default=false -- Should files be opened in browser or downloaded? (users often oblivious that their browser has a setting for this) - mailLanguages MailLanguages default='[]' -- Preferred language for eMail; i18n not yet implemented; user-defined + mailLanguages MailLanguages "default='[]'::jsonb" -- Preferred language for eMail; i18n not yet implemented; user-defined notificationSettings NotificationSettings -- Bit-array for which events email notifications are requested by user; user-defined UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table @@ -41,7 +41,7 @@ StudyFeatures -- multiple entries possible for students pursuing several degree field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach semester Int - updated UTCTime default='NOW()' -- last update from LDAP + updated UTCTime default=now() -- last update from LDAP valid Bool default=true -- marked as active in LDAP (students may switch, but LDAP never forgets) UniqueStudyFeatures user degree field type semester -- UniqueUserSubject ubuser degree field -- There exists a counterexample diff --git a/package.yaml b/package.yaml index 4edc4d864..5dd414b33 100644 --- a/package.yaml +++ b/package.yaml @@ -197,7 +197,7 @@ when: library: source-dirs: src when: - - condition: (flag(dev)) || (flag(library-only)) + - condition: flag(dev) then: ghc-options: - -O0 diff --git a/src/Application.hs b/src/Application.hs index cc8843303..675c11d92 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -70,7 +70,7 @@ import Data.Proxy import qualified Data.Aeson as Aeson -import System.Exit (exitFailure) +import System.Exit import qualified Database.Memcached.Binary.IO as Memcached @@ -81,6 +81,8 @@ import System.Posix.Process (getProcessID) import Control.Monad.Trans.State (execStateT) +import Network (socketPort) + -- Import all relevant handler modules here. -- (HPack takes care to add new modules to our cabal file nowadays.) import Handler.Common @@ -192,8 +194,13 @@ makeFoundation appSettings'@AppSettings{..} = do createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) -- Perform database migration using our application's logging settings. - $logDebugS "setup" "Migration" - migrateAll `runSqlPool` sqlPool + if + | appAutoDbMigrate -> do + $logDebugS "setup" "Migration" + migrateAll `runSqlPool` sqlPool + | otherwise -> whenM (requiresMigration `runSqlPool` sqlPool) $ do + $logErrorS "setup" "Migration required" + liftIO . exitWith $ ExitFailure 2 $logDebugS "setup" "Cluster-Config" appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool @@ -385,9 +392,10 @@ appMain = runResourceT $ do -- Run the application with Warp activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames sockets <- case activatedSockets of - Just socks@(_ : _) -> do - $logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|] - return $ fst <$> socks + Just socks + | not $ null socks -> do + $logInfoS "bind" [st|Ignoring configuration and listening on #{intercalate ", " (fmap (tshow . snd) socks)}|] + return $ fst <$> socks _other -> do let host = foundation ^. _appHost @@ -395,6 +403,8 @@ appMain = runResourceT $ do $logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|] liftIO $ pure <$> bindPortTCP port host + $logDebugS "bind" . tshow =<< mapM (liftIO . socketPort) sockets + let runWarp socket = runSettingsSocket (warpSettings foundation) socket app case sockets of [] -> $logErrorS "bind" "No sockets to listen on" diff --git a/src/Jobs.hs b/src/Jobs.hs index 641d3e100..efbe126b6 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -99,17 +99,18 @@ handleJobs foundation@UniWorX{..} = do atomically . modifyTVar' appJobCtl $ Map.insert tId bChan -- Start cron operation - registeredCron <- liftIO newEmptyTMVarIO - let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ - unsafeHandler foundation $ runReaderT execCrontab JobContext{..} - unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread - cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) - registeredCron' <- atomically $ do - registeredCron' <- tryPutTMVar appCronThread cData - registeredCron' <$ putTMVar registeredCron registeredCron' - when registeredCron' $ - liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ - writeJobCtlBlock JobCtlDetermineCrontab + when (num > 0) $ do + registeredCron <- liftIO newEmptyTMVarIO + let execCrontab' = whenM (atomically $ readTMVar registeredCron) $ + unsafeHandler foundation $ runReaderT execCrontab JobContext{..} + unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread + cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab) + registeredCron' <- atomically $ do + registeredCron' <- tryPutTMVar appCronThread cData + registeredCron' <$ putTMVar registeredCron registeredCron' + when registeredCron' $ + liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $ + writeJobCtlBlock JobCtlDetermineCrontab stopJobCtl :: MonadIO m => UniWorX -> m () -- ^ Stop all worker threads currently running diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 6f6970ac3..f55638835 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -1,5 +1,6 @@ module Model.Migration ( migrateAll + , requiresMigration ) where import ClassyPrelude.Yesod @@ -23,6 +24,10 @@ import Data.CaseInsensitive (CI) import Text.Shakespeare.Text (st) +import Control.Monad.Trans.Reader (mapReaderT) +import Control.Monad.Except (MonadError(..)) +import Utils (exceptT) + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -55,16 +60,10 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () migrateAll = do $logDebugS "Migration" "Initial migration" - mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do - -- Manual migrations to go to InitialVersion below: - migrateEnableExtension "citext" + mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration - migrateDBVersioning - - $logDebugS "Migration" "Retrieve applied migrations" - appliedMigrations <- selectKeysList [] [] + missingMigrations <- getMissingMigrations let - missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations doCustomMigration acc desc migration = acc <* do let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc $logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|] @@ -78,6 +77,43 @@ migrateAll = do $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' +requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool +requiresMigration = mapReaderT (exceptT return return) $ do + initial <- getMigration initialMigration + when (not $ null initial) $ do + $logInfoS "Migration" $ intercalate "; " initial + throwError True + + customs <- getMissingMigrations @_ @m + when (not $ Map.null customs) $ do + $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs + throwError True + + automatic <- getMigration migrateAll' + when (not $ null automatic) $ do + $logInfoS "Migration" $ intercalate "; " automatic + throwError True + + return False + +initialMigration :: Migration +-- ^ Manual migrations to go to InitialVersion below: +initialMigration = do + migrateEnableExtension "citext" + migrateDBVersioning + +getMissingMigrations :: forall m m'. + ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + , MonadIO m' + ) + => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ())) +getMissingMigrations = do + $logDebugS "Migration" "Retrieve applied migrations" + appliedMigrations <- selectKeysList [] [] + return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations + {- Confusion about quotes, from the PostgreSQL Manual: Single quotes for string constants, double quotes for table/column names. diff --git a/src/Settings.hs b/src/Settings.hs index d9798caea..06b2fa836 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -77,6 +77,7 @@ data AppSettings = AppSettings -- ^ Directory from which to serve static files. , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. + , appAutoDbMigrate :: Bool , appLdapConf :: Maybe LdapConf -- ^ Configuration settings for accessing the LDAP-directory , appSmtpConf :: Maybe SmtpConf @@ -345,6 +346,7 @@ instance FromJSON AppSettings where #endif appStaticDir <- o .: "static-dir" appDatabaseConf <- o .: "database" + appAutoDbMigrate <- o .: "auto-db-migrate" let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls host _ -> not $ null host Ldap.Plain host -> not $ null host diff --git a/stack.yaml b/stack.yaml index df8eb7fb3..b6c31fd66 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,6 +21,10 @@ packages: git: https://github.com/pngwjpgh/memcached-binary.git commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad extra-dep: true + - location: + git: https://github.com/pngwjpgh/systemd.git + commit: 53d7ce6bd241ed4bedd25f1ae9383fd1856f9b77 + extra-dep: true extra-deps: - colonnade-1.2.0 @@ -49,6 +53,4 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 - - systemd-1.1.2 - resolver: lts-10.5 diff --git a/test/Database.hs b/test/Database.hs index 7281036f3..5f9140cb0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -33,10 +33,10 @@ data DBAction = DBClear argsDescr :: [OptDescr DBAction] argsDescr = - [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" - , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" - , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" - , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" + , Option ['t'] ["truncate"] (NoArg DBTruncate) "Truncate all tables mentioned in the current schema (This cannot be run concurrently with any other activity accessing the database)" + , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" + , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" ] From e6e92ad42e62816a6e2aaab3b5a5c3198049fdca Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 12 May 2019 13:59:08 +0200 Subject: [PATCH 32/44] Fix #361 --- src/Handler/Submission.hs | 2 ++ src/Handler/Utils/Submission.hs | 1 - 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 74e1e92e1..3077a1554 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -485,6 +485,7 @@ submissionHelper tid ssh csh shn mcid = do E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True) E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate)) + E.&&. (sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.||. E.isNothing (sf2 E.?. SubmissionFileIsDeletion)) E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid)) return ((sf1, f1), (sf2, f2)) @@ -546,6 +547,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat return f case results of + [] -> notFound [Entity _ File{ fileContent = Just c, fileTitle }] -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index c65ae308b..b8d158f06 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -510,7 +510,6 @@ sinkSubmission userId mExists isUpdate = do -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing - , SubmissionRatingBy =. Nothing , SubmissionRatingComment =. Nothing ] | isUpdate From 38e32b56fb53f7ae8fd70bd93017c07b5cae9bd7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 12 May 2019 15:02:06 +0200 Subject: [PATCH 33/44] Don't hide submission files that have no corrected version --- src/Handler/Submission.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3077a1554..2f7d5404d 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -481,6 +481,7 @@ submissionHelper tid ssh csh shn mcid = do E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId + E.&&. sf2 E.?. SubmissionFileIsDeletion E.==. E.val (Just False) E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate)) From 4468519808b5d07461d2463fd5765d278fb54ebf Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 12 May 2019 18:03:05 +0200 Subject: [PATCH 34/44] Debug output for sourceFiles --- src/Handler/Utils/Zip.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 5df1d3ba7..1bacbda1e 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -95,10 +95,14 @@ modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle } -- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo -sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File +sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File sourceFiles fInfo - | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip - | otherwise = yieldM $ acceptFile fInfo + | mimeType == "application/zip" = do + $logInfoS "sourceFiles" "Unpacking ZIP" + fileSource fInfo =$= void consumeZip + | otherwise = do + $logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|] + yieldM $ acceptFile fInfo where mimeType = defaultMimeLookup (fileName fInfo) From a50c31dd88f6bebb3eb81bf815f451774070c5a4 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 12 May 2019 19:43:57 +0200 Subject: [PATCH 35/44] Allow customisation of file extension -> mimetype mapping --- config/mimetypes | 788 ++++++++++++++++++++++++++++++++ src/Handler/Submission.hs | 4 +- src/Handler/Utils.hs | 6 +- src/Handler/Utils/Mail.hs | 3 +- src/Handler/Utils/Submission.hs | 4 - src/Handler/Utils/Zip.hs | 4 +- src/Network/Mime/TH.hs | 46 ++ src/Settings.hs | 12 + 8 files changed, 851 insertions(+), 16 deletions(-) create mode 100644 config/mimetypes create mode 100644 src/Network/Mime/TH.hs diff --git a/config/mimetypes b/config/mimetypes new file mode 100644 index 000000000..dd3fe4224 --- /dev/null +++ b/config/mimetypes @@ -0,0 +1,788 @@ +# Mapping of mime-types to file extensions +# +# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’ +# +# Format is a single mime-type per line (may not contain whitespace) followed by a whitespace separated list of zero or more file extension (without leading ‘.’) +# Any file extension may occur at most once within this file +# +# Extensions are compared case-insensitive (see `Data.Text.toLower`) + +application/andrew-inset ez +application/applixware aw +application/atom+xml atom +application/atomcat+xml atomcat +application/atomsvc+xml atomsvc +application/ccxml+xml ccxml +application/cdmi-capability cdmia +application/cdmi-container cdmic +application/cdmi-domain cdmid +application/cdmi-object cdmio +application/cdmi-queue cdmiq +application/cu-seeme cu +application/davmount+xml davmount +application/docbook+xml dbk +application/dssc+der dssc +application/dssc+xml xdssc +application/ecmascript ecma +application/emma+xml emma +application/epub+zip epub +application/exi exi +application/font-tdpfr pfr +application/font-woff woff +application/font-woff2 woff2 +application/futuresplash spl +application/gml+xml gml +application/gpx+xml gpx +application/gxf gxf +application/hyperstudio stk +application/inkml+xml inkml ink +application/ipfix ipfix +application/java-archive war jar ear +application/java-serialized-object ser +application/java-vm class +application/javascript js +application/json json +application/jsonml+json jsonml +application/lost+xml lostxml +application/mac-binhex40 hqx +application/mac-compactpro cpt +application/mads+xml mads +application/marc mrc +application/marcxml+xml mrcx +application/mathematica nb mb ma +application/mathml+xml mathml +application/mbox mbox +application/mediaservercontrol+xml mscml +application/metalink+xml metalink +application/metalink4+xml meta4 +application/mets+xml mets +application/mods+xml mods +application/mp21 mp21 m21 +application/mp4 mp4s +application/msword dot doc +application/mxf mxf +application/octet-stream so pkg msp msm mar lrf img elc dump dms distz dist deploy bpk bin +application/oda oda +application/oebps-package+xml opf +application/ogg ogx +application/omdoc+xml omdoc +application/onenote onetoc2 onetoc onetmp onepkg +application/oxps oxps +application/patch-ops-error+xml xer +application/pdf pdf +application/pgp-encrypted pgp +application/pgp-signature sig +application/pics-rules prf +application/pkcs10 p10 +application/pkcs7-mime p7m p7c +application/pkcs7-signature p7s +application/pkcs8 p8 +application/pkix-attr-cert ac +application/pkix-cert cer +application/pkix-crl crl +application/pkix-pkipath pkipath +application/pkixcmp pki +application/pls+xml pls +application/postscript ps eps ai +application/prs.cww cww +application/pskc+xml pskcxml +application/rdf+xml rdf +application/reginfo+xml rif +application/relax-ng-compact-syntax rnc +application/resource-lists+xml rl +application/resource-lists-diff+xml rld +application/rls-services+xml rs +application/rpki-ghostbusters gbr +application/rpki-manifest mft +application/rpki-roa roa +application/rsd+xml rsd +application/rss+xml rss +application/rtf rtf +application/sbml+xml sbml +application/scvp-cv-request scq +application/scvp-cv-response scs +application/scvp-vp-request spq +application/scvp-vp-response spp +application/sdp sdp +application/set-payment-initiation setpay +application/set-registration-initiation setreg +application/shf+xml shf +application/smil+xml smil smi +application/sparql-query rq +application/sparql-results+xml srx +application/srgs gram +application/srgs+xml grxml +application/sru+xml sru +application/ssdl+xml ssdl +application/ssml+xml ssml +application/tei+xml teicorpus tei +application/thraud+xml tfi +application/timestamped-data tsd +application/vnd.3gpp.pic-bw-large plb +application/vnd.3gpp.pic-bw-small psb +application/vnd.3gpp.pic-bw-var pvb +application/vnd.3gpp2.tcap tcap +application/vnd.3m.post-it-notes pwn +application/vnd.accpac.simply.aso aso +application/vnd.accpac.simply.imp imp +application/vnd.acucobol acu +application/vnd.acucorp atc acutc +application/vnd.adobe.air-application-installer-package+zip air +application/vnd.adobe.formscentral.fcdt fcdt +application/vnd.adobe.fxp fxpl fxp +application/vnd.adobe.xdp+xml xdp +application/vnd.adobe.xfdf xfdf +application/vnd.ahead.space ahead +application/vnd.airzip.filesecure.azf azf +application/vnd.airzip.filesecure.azs azs +application/vnd.amazon.ebook azw +application/vnd.americandynamics.acc acc +application/vnd.amiga.ami ami +application/vnd.android.package-archive apk +application/vnd.anser-web-certificate-issue-initiation cii +application/vnd.anser-web-funds-transfer-initiation fti +application/vnd.antix.game-component atx +application/vnd.apple.installer+xml mpkg +application/vnd.apple.mpegurl m3u8 +application/vnd.aristanetworks.swi swi +application/vnd.astraea-software.iota iota +application/vnd.audiograph aep +application/vnd.blueice.multipass mpm +application/vnd.bmi bmi +application/vnd.businessobjects rep +application/vnd.chemdraw+xml cdxml +application/vnd.chipnuts.karaoke-mmd mmd +application/vnd.cinderella cdy +application/vnd.claymore cla +application/vnd.cloanto.rp9 rp9 +application/vnd.clonk.c4group c4u c4p c4g c4f c4d +application/vnd.cluetrust.cartomobile-config c11amc +application/vnd.cluetrust.cartomobile-config-pkg c11amz +application/vnd.commonspace csp +application/vnd.contact.cmsg cdbcmsg +application/vnd.cosmocaller cmc +application/vnd.crick.clicker clkx +application/vnd.crick.clicker.keyboard clkk +application/vnd.crick.clicker.palette clkp +application/vnd.crick.clicker.template clkt +application/vnd.crick.clicker.wordbank clkw +application/vnd.criticaltools.wbs+xml wbs +application/vnd.ctc-posml pml +application/vnd.cups-ppd ppd +application/vnd.curl.car car +application/vnd.curl.pcurl pcurl +application/vnd.dart dart +application/vnd.data-vision.rdz rdz +application/vnd.dece.data uvvf uvvd uvf uvd +application/vnd.dece.ttml+xml uvvt uvt +application/vnd.dece.unspecified uvx uvvx +application/vnd.dece.zip uvz uvvz +application/vnd.denovo.fcselayout-link fe_launch +application/vnd.dna dna +application/vnd.dolby.mlp mlp +application/vnd.dpgraph dpg +application/vnd.dreamfactory dfac +application/vnd.ds-keypoint kpxx +application/vnd.dvb.ait ait +application/vnd.dvb.service svc +application/vnd.dynageo geo +application/vnd.ecowin.chart mag +application/vnd.enliven nml +application/vnd.epson.esf esf +application/vnd.epson.msf msf +application/vnd.epson.quickanime qam +application/vnd.epson.salt slt +application/vnd.epson.ssf ssf +application/vnd.eszigno3+xml et3 es3 +application/vnd.ezpix-album ez2 +application/vnd.ezpix-package ez3 +application/vnd.fdf fdf +application/vnd.fdsn.mseed mseed +application/vnd.fdsn.seed seed dataless +application/vnd.flographit gph +application/vnd.fluxtime.clip ftc +application/vnd.framemaker maker frame fm book +application/vnd.frogans.fnc fnc +application/vnd.frogans.ltf ltf +application/vnd.fsc.weblaunch fsc +application/vnd.fujitsu.oasys oas +application/vnd.fujitsu.oasys2 oa2 +application/vnd.fujitsu.oasys3 oa3 +application/vnd.fujitsu.oasysgp fg5 +application/vnd.fujitsu.oasysprs bh2 +application/vnd.fujixerox.ddd ddd +application/vnd.fujixerox.docuworks xdw +application/vnd.fujixerox.docuworks.binder xbd +application/vnd.fuzzysheet fzs +application/vnd.genomatix.tuxedo txd +application/vnd.geogebra.file ggb +application/vnd.geogebra.tool ggt +application/vnd.geometry-explorer gre gex +application/vnd.geonext gxt +application/vnd.geoplan g2w +application/vnd.geospace g3w +application/vnd.gmx gmx +application/vnd.google-earth.kml+xml kml +application/vnd.google-earth.kmz kmz +application/vnd.grafeq gqs gqf +application/vnd.groove-account gac +application/vnd.groove-help ghf +application/vnd.groove-identity-message gim +application/vnd.groove-injector grv +application/vnd.groove-tool-message gtm +application/vnd.groove-tool-template tpl +application/vnd.groove-vcard vcg +application/vnd.hal+xml hal +application/vnd.handheld-entertainment+xml zmm +application/vnd.hbci hbci +application/vnd.hhe.lesson-player les +application/vnd.hp-hpgl hpgl +application/vnd.hp-hpid hpid +application/vnd.hp-hps hps +application/vnd.hp-jlyt jlt +application/vnd.hp-pcl pcl +application/vnd.hp-pclxl pclxl +application/vnd.hydrostatix.sof-data sfd-hdstx +application/vnd.ibm.minipay mpy +application/vnd.ibm.modcap listafp list3820 afp +application/vnd.ibm.rights-management irm +application/vnd.ibm.secure-container sc +application/vnd.iccprofile icm icc +application/vnd.igloader igl +application/vnd.immervision-ivp ivp +application/vnd.immervision-ivu ivu +application/vnd.insors.igm igm +application/vnd.intercon.formnet xpx xpw +application/vnd.intergeo i2g +application/vnd.intu.qbo qbo +application/vnd.intu.qfx qfx +application/vnd.ipunplugged.rcprofile rcprofile +application/vnd.irepository.package+xml irp +application/vnd.is-xpr xpr +application/vnd.isac.fcs fcs +application/vnd.jam jam +application/vnd.jcp.javame.midlet-rms rms +application/vnd.jisp jisp +application/vnd.joost.joda-archive joda +application/vnd.kahootz ktz ktr +application/vnd.kde.karbon karbon +application/vnd.kde.kchart chrt +application/vnd.kde.kformula kfo +application/vnd.kde.kivio flw +application/vnd.kde.kontour kon +application/vnd.kde.kpresenter kpt kpr +application/vnd.kde.kspread ksp +application/vnd.kde.kword kwt kwd +application/vnd.kenameaapp htke +application/vnd.kidspiration kia +application/vnd.kinar knp kne +application/vnd.koan skt skp skm skd +application/vnd.kodak-descriptor sse +application/vnd.las.las+xml lasxml +application/vnd.llamagraphics.life-balance.desktop lbd +application/vnd.llamagraphics.life-balance.exchange+xml lbe +application/vnd.lotus-1-2-3 123 +application/vnd.lotus-approach apr +application/vnd.lotus-freelance pre +application/vnd.lotus-notes nsf +application/vnd.lotus-organizer org +application/vnd.lotus-screencam scm +application/vnd.lotus-wordpro lwp +application/vnd.macports.portpkg portpkg +application/vnd.mcd mcd +application/vnd.medcalcdata mc1 +application/vnd.mediastation.cdkey cdkey +application/vnd.mfer mwf +application/vnd.mfmp mfm +application/vnd.micrografx.flo flo +application/vnd.micrografx.igx igx +application/vnd.mif mif +application/vnd.mobius.daf daf +application/vnd.mobius.dis dis +application/vnd.mobius.mbk mbk +application/vnd.mobius.mqy mqy +application/vnd.mobius.msl msl +application/vnd.mobius.plc plc +application/vnd.mobius.txf txf +application/vnd.mophun.application mpn +application/vnd.mophun.certificate mpc +application/vnd.mozilla.xul+xml xul +application/vnd.ms-artgalry cil +application/vnd.ms-cab-compressed cab +application/vnd.ms-excel xlw xlt xls xlm xlc xla +application/vnd.ms-excel.addin.macroenabled.12 xlam +application/vnd.ms-excel.sheet.binary.macroenabled.12 xlsb +application/vnd.ms-excel.sheet.macroenabled.12 xlsm +application/vnd.ms-excel.template.macroenabled.12 xltm +application/vnd.ms-fontobject eot +application/vnd.ms-htmlhelp chm +application/vnd.ms-ims ims +application/vnd.ms-lrm lrm +application/vnd.ms-officetheme thmx +application/vnd.ms-pki.seccat cat +application/vnd.ms-pki.stl stl +application/vnd.ms-powerpoint ppt pps pot +application/vnd.ms-powerpoint.addin.macroenabled.12 ppam +application/vnd.ms-powerpoint.presentation.macroenabled.12 pptm +application/vnd.ms-powerpoint.slide.macroenabled.12 sldm +application/vnd.ms-powerpoint.slideshow.macroenabled.12 ppsm +application/vnd.ms-powerpoint.template.macroenabled.12 potm +application/vnd.ms-project mpt mpp +application/vnd.ms-word.document.macroenabled.12 docm +application/vnd.ms-word.template.macroenabled.12 dotm +application/vnd.ms-works wps wks wdb wcm +application/vnd.ms-wpl wpl +application/vnd.ms-xpsdocument xps +application/vnd.mseq mseq +application/vnd.musician mus +application/vnd.muvee.style msty +application/vnd.mynfc taglet +application/vnd.neurolanguage.nlu nlu +application/vnd.nitf ntf nitf +application/vnd.noblenet-directory nnd +application/vnd.noblenet-sealer nns +application/vnd.noblenet-web nnw +application/vnd.nokia.n-gage.data ngdat +application/vnd.nokia.n-gage.symbian.install n-gage +application/vnd.nokia.radio-preset rpst +application/vnd.nokia.radio-presets rpss +application/vnd.novadigm.edm edm +application/vnd.novadigm.edx edx +application/vnd.novadigm.ext ext +application/vnd.oasis.opendocument.chart odc +application/vnd.oasis.opendocument.chart-template otc +application/vnd.oasis.opendocument.database odb +application/vnd.oasis.opendocument.formula odf +application/vnd.oasis.opendocument.formula-template odft +application/vnd.oasis.opendocument.graphics odg +application/vnd.oasis.opendocument.graphics-template otg +application/vnd.oasis.opendocument.image odi +application/vnd.oasis.opendocument.image-template oti +application/vnd.oasis.opendocument.presentation odp +application/vnd.oasis.opendocument.presentation-template otp +application/vnd.oasis.opendocument.spreadsheet ods +application/vnd.oasis.opendocument.spreadsheet-template ots +application/vnd.oasis.opendocument.text odt +application/vnd.oasis.opendocument.text-master odm +application/vnd.oasis.opendocument.text-template ott +application/vnd.oasis.opendocument.text-web oth +application/vnd.olpc-sugar xo +application/vnd.oma.dd2+xml dd2 +application/vnd.openofficeorg.extension oxt +application/vnd.openxmlformats-officedocument.presentationml.presentation pptx +application/vnd.openxmlformats-officedocument.presentationml.slide sldx +application/vnd.openxmlformats-officedocument.presentationml.slideshow ppsx +application/vnd.openxmlformats-officedocument.presentationml.template potx +application/vnd.openxmlformats-officedocument.spreadsheetml.sheet xlsx +application/vnd.openxmlformats-officedocument.spreadsheetml.template xltx +application/vnd.openxmlformats-officedocument.wordprocessingml.document docx +application/vnd.openxmlformats-officedocument.wordprocessingml.template dotx +application/vnd.osgeo.mapguide.package mgp +application/vnd.osgi.dp dp +application/vnd.osgi.subsystem esa +application/vnd.palm pqa pdb oprc +application/vnd.pawaafile paw +application/vnd.pg.format str +application/vnd.pg.osasli ei6 +application/vnd.picsel efif +application/vnd.pmi.widget wg +application/vnd.pocketlearn plf +application/vnd.powerbuilder6 pbd +application/vnd.previewsystems.box box +application/vnd.proteus.magazine mgz +application/vnd.publishare-delta-tree qps +application/vnd.pvi.ptid1 ptid +application/vnd.quark.quarkxpress qxt qxl qxd qxb qwt qwd +application/vnd.realvnc.bed bed +application/vnd.recordare.musicxml mxl +application/vnd.recordare.musicxml+xml musicxml +application/vnd.rig.cryptonote cryptonote +application/vnd.rim.cod cod +application/vnd.rn-realmedia rm +application/vnd.rn-realmedia-vbr rmvb +application/vnd.route66.link66+xml link66 +application/vnd.sailingtracker.track st +application/vnd.seemail see +application/vnd.sema sema +application/vnd.semd semd +application/vnd.semf semf +application/vnd.shana.informed.formdata ifm +application/vnd.shana.informed.formtemplate itp +application/vnd.shana.informed.interchange iif +application/vnd.shana.informed.package ipk +application/vnd.simtech-mindmapper twds twd +application/vnd.smaf mmf +application/vnd.smart.teacher teacher +application/vnd.solent.sdkm+xml sdkm sdkd +application/vnd.spotfire.dxp dxp +application/vnd.spotfire.sfs sfs +application/vnd.stardivision.calc sdc +application/vnd.stardivision.draw sda +application/vnd.stardivision.impress sdd +application/vnd.stardivision.math smf +application/vnd.stardivision.writer vor sdw +application/vnd.stardivision.writer-global sgl +application/vnd.stepmania.package smzip +application/vnd.stepmania.stepchart sm +application/vnd.sun.xml.calc sxc +application/vnd.sun.xml.calc.template stc +application/vnd.sun.xml.draw sxd +application/vnd.sun.xml.draw.template std +application/vnd.sun.xml.impress sxi +application/vnd.sun.xml.impress.template sti +application/vnd.sun.xml.math sxm +application/vnd.sun.xml.writer sxw +application/vnd.sun.xml.writer.global sxg +application/vnd.sun.xml.writer.template stw +application/vnd.sus-calendar susp sus +application/vnd.svd svd +application/vnd.symbian.install sisx sis +application/vnd.syncml+xml xsm +application/vnd.syncml.dm+wbxml bdm +application/vnd.syncml.dm+xml xdm +application/vnd.tao.intent-module-archive tao +application/vnd.tcpdump.pcap pcap dmp cap +application/vnd.tmobile-livetv tmo +application/vnd.trid.tpt tpt +application/vnd.triscape.mxs mxs +application/vnd.trueapp tra +application/vnd.ufdl ufdl ufd +application/vnd.uiq.theme utz +application/vnd.umajin umj +application/vnd.unity unityweb +application/vnd.uoml+xml uoml +application/vnd.vcx vcx +application/vnd.visio vsw vst vss vsd +application/vnd.visionary vis +application/vnd.vsf vsf +application/vnd.wap.wbxml wbxml +application/vnd.wap.wmlc wmlc +application/vnd.wap.wmlscriptc wmlsc +application/vnd.webturbo wtb +application/vnd.wolfram.player nbp +application/vnd.wordperfect wpd +application/vnd.wqd wqd +application/vnd.wt.stf stf +application/vnd.xara xar +application/vnd.xfdl xfdl +application/vnd.yamaha.hv-dic hvd +application/vnd.yamaha.hv-script hvs +application/vnd.yamaha.hv-voice hvp +application/vnd.yamaha.openscoreformat osf +application/vnd.yamaha.openscoreformat.osfpvg+xml osfpvg +application/vnd.yamaha.smaf-audio saf +application/vnd.yamaha.smaf-phrase spf +application/vnd.yellowriver-custom-menu cmp +application/vnd.zul zirz zir +application/vnd.zzazz.deck+xml zaz +application/voicexml+xml vxml +application/widget wgt +application/winhlp hlp +application/wsdl+xml wsdl +application/wspolicy+xml wspolicy +application/x-7z-compressed 7z +application/x-abiword abw +application/x-ace-compressed ace +application/x-apple-diskimage dmg +application/x-authorware-bin x32 vox u32 aab +application/x-authorware-map aam +application/x-authorware-seg aas +application/x-bcpio bcpio +application/x-bittorrent torrent +application/x-blorb blorb blb +application/x-bzip bz2 bz +application/x-bzip-compressed-tar tbz tar.bz2 +application/x-bzip2 boz +application/x-cbr cbz cbt cbr cba cb7 +application/x-cdlink vcd +application/x-cfs-compressed cfs +application/x-chat chat +application/x-chess-pgn pgn +application/x-cocoa cco +application/x-conference nsc +application/x-cpio cpio +application/x-csh csh +application/x-debian-package udeb deb +application/x-dgc-compressed dgc +application/x-director w3d swa fgd dxr dir dcr cxt cst cct +application/x-doom wad +application/x-dtbncx+xml ncx +application/x-dtbook+xml dtb +application/x-dtbresource+xml res +application/x-dvi dvi +application/x-envoy evy +application/x-eva eva +application/x-font-bdf bdf +application/x-font-ghostscript gsf +application/x-font-linux-psf psf +application/x-font-otf otf +application/x-font-pcf pcf +application/x-font-snf snf +application/x-font-ttf ttf ttc +application/x-font-type1 pfm pfb pfa afm +application/x-freearc arc +application/x-gca-compressed gca +application/x-glulx ulx +application/x-gnumeric gnumeric +application/x-gramps-xml gramps +application/x-gtar gtar +application/x-gzip gz +application/x-hdf hdf +application/x-install-instructions install +application/x-iso9660-image iso +application/x-java-archive-diff jardiff +application/x-java-jnlp-file jnlp +application/x-latex latex +application/x-lzh-compressed lzh lha +application/x-makeself run +application/x-mie mie +application/x-mobipocket-ebook prc mobi +application/x-ms-application application +application/x-ms-shortcut lnk +application/x-ms-wmd wmd +application/x-ms-xbap xbap +application/x-msaccess mdb +application/x-msbinder obd +application/x-mscardfile crd +application/x-msclip clp +application/x-msdownload msi exe dll com bat +application/x-msmediaview mvb m14 m13 +application/x-msmetafile wmz wmf emz emf +application/x-msmoney mny +application/x-mspublisher pub +application/x-msschedule scd +application/x-msterminal trm +application/x-mswrite wri +application/x-netcdf nc cdf +application/x-ns-proxy-autoconfig pac +application/x-nzb nzb +application/x-perl pm pl +application/x-pkcs12 pfx p12 +application/x-pkcs7-certificates spc p7b +application/x-pkcs7-certreqresp p7r +application/x-rar-compressed rar +application/x-redhat-package-manager rpm +application/x-research-info-systems ris +application/x-sea sea +application/x-sh sh +application/x-shar shar +application/x-shockwave-flash swf +application/x-silverlight-app xap +application/x-sql sql +application/x-stuffit sit +application/x-stuffitx sitx +application/x-subrip srt +application/x-sv4cpio sv4cpio +application/x-sv4crc sv4crc +application/x-t3vm-image t3 +application/x-tads gam +application/x-tar tar +application/x-tcl tk tcl +application/x-tex tex +application/x-tex-tfm tfm +application/x-texinfo texinfo texi +application/x-tgif obj +application/x-tgz tgz tar.gz +application/x-ustar ustar +application/x-wais-source src +application/x-x509-ca-cert pem der crt +application/x-xfig fig +application/x-xliff+xml xlf +application/x-xpinstall xpi +application/x-xz xz +application/x-zmachine z8 z7 z6 z5 z4 z3 z2 z1 +application/xaml+xml xaml +application/xcap-diff+xml xdf +application/xenc+xml xenc +application/xhtml+xml xhtml xht +application/xml xsl +application/xml-dtd dtd +application/xop+xml xop +application/xproc+xml xpl +application/xslt+xml xslt +application/xspf+xml xspf +application/xv+xml xvml xvm xhvml mxml +application/yang yang +application/yin+xml yin +application/zip zip +audio/adpcm adp +audio/basic snd au +audio/midi rmi midi mid kar +audio/mp4 mp4a +audio/mpeg mpga mp3 mp2a mp2 m3a m2a +audio/ogg spx ogg oga +audio/s3m s3m +audio/silk sil +audio/vnd.dece.audio uvva uva +audio/vnd.digital-winds eol +audio/vnd.dra dra +audio/vnd.dts dts +audio/vnd.dts.hd dtshd +audio/vnd.lucent.voice lvp +audio/vnd.ms-playready.media.pya pya +audio/vnd.nuera.ecelp4800 ecelp4800 +audio/vnd.nuera.ecelp7470 ecelp7470 +audio/vnd.nuera.ecelp9600 ecelp9600 +audio/vnd.rip rip +audio/webm weba +audio/x-aac aac +audio/x-aiff aiff aifc aif +audio/x-caf caf +audio/x-flac flac +audio/x-m4a m4a +audio/x-matroska mka +audio/x-mpegurl m3u +audio/x-ms-wax wax +audio/x-ms-wma wma +audio/x-pn-realaudio ram ra +audio/x-pn-realaudio-plugin rmp +audio/x-wav wav +audio/xm xm +chemical/x-cdx cdx +chemical/x-cif cif +chemical/x-cmdf cmdf +chemical/x-cml cml +chemical/x-csml csml +chemical/x-xyz xyz +image/bmp bmp +image/cgm cgm +image/g3fax g3 +image/gif gif +image/ief ief +image/jpeg jpg jpeg jpe +image/ktx ktx +image/png png +image/prs.btif btif +image/sgi sgi +image/svg+xml svgz svg +image/tiff tiff tif +image/vnd.adobe.photoshop psd +image/vnd.dece.graphic uvvi uvvg uvi uvg +image/vnd.djvu djvu djv +image/vnd.dwg dwg +image/vnd.dxf dxf +image/vnd.fastbidsheet fbs +image/vnd.fpx fpx +image/vnd.fst fst +image/vnd.fujixerox.edmics-mmr mmr +image/vnd.fujixerox.edmics-rlc rlc +image/vnd.microsoft.icon ico +image/vnd.ms-modi mdi +image/vnd.ms-photo wdp +image/vnd.net-fpx npx +image/vnd.wap.wbmp wbmp +image/vnd.xiff xif +image/webp webp +image/x-3ds 3ds +image/x-cmu-raster ras +image/x-cmx cmx +image/x-freehand fhc fh7 fh5 fh4 fh +image/x-jng jng +image/x-mrsid-image sid +image/x-pcx pcx +image/x-pict pic pct +image/x-portable-anymap pnm +image/x-portable-bitmap pbm +image/x-portable-graymap pgm +image/x-portable-pixmap ppm +image/x-rgb rgb +image/x-tga tga +image/x-xbitmap xbm +image/x-xpixmap xpm +image/x-xwindowdump xwd +message/rfc822 mime eml +model/iges igs iges +model/mesh silo msh mesh +model/vnd.collada+xml dae +model/vnd.dwf dwf +model/vnd.gdl gdl +model/vnd.gtw gtw +model/vnd.mts mts +model/vnd.vtu vtu +model/vrml wrl vrml +model/x3d+binary x3dbz x3db +model/x3d+vrml x3dvz x3dv +model/x3d+xml x3dz x3d +text/cache-manifest manifest appcache +text/calendar ifb ics +text/css less css +text/csv csv +text/html shtml html htm +text/mathml mml +text/n3 n3 +text/plain txt text log list in hs def cxx cpp conf c asc +text/prs.lines.tag dsc +text/richtext rtx +text/sgml sgml sgm +text/tab-separated-values tsv +text/troff tr t roff ms me man +text/turtle ttl +text/uri-list urls uris uri +text/vcard vcard +text/vnd.curl curl +text/vnd.curl.dcurl dcurl +text/vnd.curl.mcurl mcurl +text/vnd.curl.scurl scurl +text/vnd.dvb.subtitle sub +text/vnd.fly fly +text/vnd.fmi.flexstor flx +text/vnd.graphviz gv +text/vnd.in3d.3dml 3dml +text/vnd.in3d.spot spot +text/vnd.sun.j2me.app-descriptor jad +text/vnd.wap.wml wml +text/vnd.wap.wmlscript wmls +text/x-asm s asm +text/x-c hh h dic cc +text/x-component htc +text/x-fortran for f90 f77 f +text/x-java-source java +text/x-nfo nfo +text/x-opml opml +text/x-pascal pas p +text/x-setext etx +text/x-sfv sfv +text/x-uuencode uu +text/x-vcalendar vcs +text/x-vcard vcf +text/xml xml +video/3gpp 3gpp 3gp +video/3gpp2 3g2 +video/h261 h261 +video/h263 h263 +video/h264 h264 +video/jpeg jpgv +video/jpm jpm jpgm +video/mj2 mjp2 mj2 +video/mp4 mpg4 mp4v mp4 +video/mpeg mpg mpeg mpe m2v m1v +video/ogg ogv +video/quicktime qt mov +video/vnd.dece.hd uvvh uvh +video/vnd.dece.mobile uvvm uvm +video/vnd.dece.pd uvvp uvp +video/vnd.dece.sd uvvs uvs +video/vnd.dece.video uvvv uvv +video/vnd.dvb.file dvb +video/vnd.fvt fvt +video/vnd.mpegurl mxu m4u +video/vnd.ms-playready.media.pyv pyv +video/vnd.uvvu.mp4 uvvu uvu +video/vnd.vivo viv +video/webm webm +video/x-f4v f4v +video/x-fli fli +video/x-flv flv +video/x-m4v m4v +video/x-matroska mkv mks mk3d +video/x-mng mng +video/x-ms-asf asx asf +video/x-ms-vob vob +video/x-ms-wm wm +video/x-ms-wmv wmv +video/x-ms-wmx wmx +video/x-ms-wvx wvx +video/x-msvideo avi +video/x-sgi-movie movie +video/x-smv smv +x-conference/x-cooltalk ice diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 2f7d5404d..d5f5961cd 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -17,8 +17,6 @@ import Handler.Utils.Table.Cells import Handler.Utils.Form.MassInput import Handler.Utils.Invitations -import Network.Mime - -- import Control.Monad.Trans.Maybe -- import Control.Monad.State.Class -- import Control.Monad.Trans.State.Strict (StateT) @@ -552,7 +550,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat [Entity _ File{ fileContent = Just c, fileTitle }] -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) + return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () other -> do $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index e7cf7dabb..ed2334d5c 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -34,8 +34,6 @@ import Handler.Utils.Mail as Handler.Utils import System.Directory (listDirectory) import System.FilePath.Posix (takeBaseName, takeFileName) -import Network.Mime - import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty @@ -58,7 +56,7 @@ serveOneFile query = do | Just fileContent' <- fileContent -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () [] -> notFound other -> do @@ -76,7 +74,7 @@ serveSomeFiles archiveName query = do | Just fileContent' <- fileContent -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] - return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') + return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () files -> do addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|] diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 211923159..0548d341c 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -16,7 +16,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit.List as C import System.FilePath (takeBaseName) -import Network.Mime (defaultMimeLookup) import Control.Monad.Trans.State (StateT) @@ -66,7 +65,7 @@ addFileDB :: ( MonadMail m addFileDB fId = do File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId addPart $ do - _partType .= decodeUtf8 (defaultMimeLookup fileName) + _partType .= decodeUtf8 (mimeLookup fileName) _partEncoding .= Base64 _partFilename .= Just fileName _partContent .= LBS.fromStrict fileContent diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index b8d158f06..33168da0e 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -40,7 +40,6 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Handler.Utils import qualified Handler.Utils.Rating as Rating (extractRatings) -import Handler.Utils.Submission.TH import Handler.Utils.Delete import qualified Database.Esqueleto as E @@ -271,9 +270,6 @@ instance Monoid SubmissionSinkState where mempty = memptydefault mappend = mappenddefault -submissionBlacklist :: [Pattern] -submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") - filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath) -- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s filterSubmission = do diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index 1bacbda1e..c1fd25524 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -27,8 +27,6 @@ import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime) import Data.List (dropWhileEnd) -import Network.Mime - instance Default ZipInfo where def = ZipInfo @@ -104,7 +102,7 @@ sourceFiles fInfo $logDebugS "sourceFiles" [st|Not unpacking file of type #{decodeUtf8 mimeType}|] yieldM $ acceptFile fInfo where - mimeType = defaultMimeLookup (fileName fInfo) + mimeType = mimeLookup $ fileName fInfo acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File acceptFile fInfo = do diff --git a/src/Network/Mime/TH.hs b/src/Network/Mime/TH.hs new file mode 100644 index 000000000..0fd1c2beb --- /dev/null +++ b/src/Network/Mime/TH.hs @@ -0,0 +1,46 @@ +module Network.Mime.TH + ( mimeMapFile + ) where + +import ClassyPrelude.Yesod hiding (lift) +import Language.Haskell.TH hiding (Extension) +import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..)) + +import qualified Data.Map as Map + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as Text + +import Network.Mime + +import Instances.TH.Lift () + + +mimeMapFile :: FilePath -> ExpQ +mimeMapFile file = do + qAddDependentFile file + + mappings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file + let + coMappings :: [(Extension, MimeType)] + coMappings = do + (mimeType : extensions) <- filter (not . Text.null) . Text.words <$> mappings + ext <- extensions + return (ext, Text.encodeUtf8 mimeType) + + mimeMap = Map.fromListWithKey duplicateError coMappings + + duplicateError ext t1 t2 = error . Text.unpack $ "Duplicate mimeMap-entries for extension " <> ext <> ": " <> Text.decodeUtf8 t1 <> ", " <> Text.decodeUtf8 t2 + + + lift mimeMap + +isComment :: Text -> Bool +isComment line = or + [ commentSymbol `Text.isPrefixOf` Text.stripStart line + , Text.null $ Text.strip line + ] + where + commentSymbol = "#" diff --git a/src/Settings.hs b/src/Settings.hs index 06b2fa836..739ac5554 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -68,6 +68,11 @@ import qualified System.FilePath as FilePath import Jose.Jwt (JwtEncoding(..)) +import System.FilePath.Glob +import Handler.Utils.Submission.TH +import Network.Mime +import Network.Mime.TH + -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, @@ -422,6 +427,13 @@ makeClassy_ ''AppSettings widgetFileSettings :: WidgetFileSettings widgetFileSettings = def + +submissionBlacklist :: [Pattern] +submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") + +mimeLookup :: FileName -> MimeType +mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType + -- The rest of this file contains settings which rarely need changing by a -- user. From 487c46a1cec5769b09bb54840fe28de4d63cfd5a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 May 2019 00:17:12 +0200 Subject: [PATCH 36/44] Finish implementation of course participant invitations Fixes #250 --- messages/uniworx/de.msg | 9 ++ src/Foundation.hs | 14 ++- src/Handler/Course.hs | 103 +++++++++++++----- src/Utils/Frontend/Modal.hs | 17 ++- .../courseInvitationAlreadyRegistered.hamlet | 5 + ...rseInvitationRegisteredWithoutField.hamlet | 5 + 6 files changed, 126 insertions(+), 27 deletions(-) create mode 100644 templates/messages/courseInvitationAlreadyRegistered.hamlet create mode 100644 templates/messages/courseInvitationRegisteredWithoutField.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index f35f195af..a4762c0b5 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -745,6 +745,7 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseAddMembers: Kursteilnehmer hinzufügen MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen @@ -860,6 +861,8 @@ CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzun CourseParticipantEnlistDirectly: bekannte Teilnehmer sofort als Teilnehmer eintragen CourseParticipantInviteField: einzuladende EMail Adressen +CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen + CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt @@ -951,3 +954,9 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können HealthSMTPConnect: SMTP-Server kann erreicht werden HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus + +CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt +CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet +CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet +CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 9161ef86a..e71ac2611 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1248,7 +1248,7 @@ siteLayout' headingOverride widget = do applySystemMessages authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags forM_ authTagPivots $ - \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) + \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) getMessages let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority @@ -1417,6 +1417,8 @@ instance YesodBreadcrumbs UniWorX where -- (CourseR tid ssh csh CRegisterR) -- is POST only breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CUsersR) = return ("Anmeldungen", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CAddUserR) = return ("Kursteilnehmer hinzufügen", Just $ CourseR tid ssh csh CUsersR) + breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) @@ -1955,6 +1957,16 @@ pageActions (CourseR tid ssh csh SheetListR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CUsersR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuCourseAddMembers + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CAddUserR + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (CourseR tid ssh csh MaterialListR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 9cdd21810..7091cb0b5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -41,6 +41,11 @@ import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) +import Control.Monad.Trans.Writer (WriterT, execWriterT) +import Control.Monad.Except (MonadError(..)) + +import Generics.Deriving.Monoid (memptydefault, mappenddefault) + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -704,7 +709,7 @@ lecturerInvitationConfig = InvitationConfig{..} itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of + invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where @@ -1408,52 +1413,100 @@ participantInvitationConfig = InvitationConfig{..} getKeyBy404 $ TermSchoolCourseShort tid csh ssh invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgParticipantInviteExplanation}|] + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] -- Keine besonderen Einschränkungen beim Einlösen der Token -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden! invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized - invitationForm Course{..} _ uid = wFormToAForm $ do + invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesPrimaryFieldFor [ ] (Just uid)) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing return $ JunctionParticipant <$> pure now <*> studyFeatures -  invitationSuccessMsg Course{..} _ = - return . SomeMessage $ MsgParticipantInvitationAccepted courseTerm courseSchool courseShorthand + invitationSuccessMsg Course{..} _ = + return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR +data AddRecipientsResult = AddRecipientsResult + { aurAlreadyRegistered + , aurNoUniquePrimaryField + , aurSuccess :: [UserEmail] + } deriving (Read, Show, Generic, Typeable) + +instance Monoid AddRecipientsResult where + mempty = memptydefault + mappend = mappenddefault + getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - ((usersToEnlist,formWgt),formEcnoding) <- runFormPost . renderWForm FormStandard $ do - enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) - areq (multiUserField (fromMaybe False $ formResultToMaybe enlist) Nothing) + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do + enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False) + wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing) (fslI MsgCourseParticipantInviteField) Nothing - formResult usersToEnlist processUsers + + formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid + + let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading + + siteLayoutMsg heading $ do + setTitleI heading + wrapForm formWgt def + { formEncoding + , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR + } where - processUsers :: Set (Either UserEmail UserId) -> Handler () - processUsers users = do - error "TODO" - {-} - let (emails,uids) = partionEithers $ Set.toList users - runDB $ do + processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler () + processUsers cid users = do + let (emails,uids) = partitionEithers $ Set.toList users + AddRecipientsResult alreadyRegistered registeredNoField registeredOneField <- lift . runDBJobs $ do -- send Invitation eMails to unkown users sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails] -- register known users - (alreadyRegistered,registeredNoField,registeredOneField) <- execWriterT $ mapM registerUser uids - let statusMsg = modal _linkText (Right _widgetmessage) - statusTy = Info -- Success -- TODO - addMessageWidget statusTy statusMsg - redirect $ CourseR tid ssh csh CUsersR + execWriterT $ mapM (registerUser cid) uids - registerUser :: UserId -> WriterT ([UserEmail],[UserEmail],[UserEmail]) (YesodDB UniWorX) () - registerUser uid = do + when (not $ null emails) $ + tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - tell ([],[],[]) - -} + when (not $ null alreadyRegistered) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|] + modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") + tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredNoField) $ do + let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|] + modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") + tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) + + when (not $ null registeredOneField) $ + tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField + + registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) () + registerUser cid uid = exceptT tell tell $ do + User{..} <- lift . lift $ getJust uid + + whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ + throwError $ mempty { aurAlreadyRegistered = pure userEmail } + + features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] [] + + let courseParticipantField + | [f] <- features = Just f + | otherwise = Nothing + + courseParticipantRegistration <- liftIO getCurrentTime + void . lift . lift . insert $ CourseParticipant + { courseParticipantCourse = cid + , courseParticipantUser = uid + , .. + } + + return $ case courseParticipantField of + Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail } + Just _ -> mempty { aurSuccess = pure userEmail } getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Utils/Frontend/Modal.hs b/src/Utils/Frontend/Modal.hs index 79142ae4b..dd83497ea 100644 --- a/src/Utils/Frontend/Modal.hs +++ b/src/Utils/Frontend/Modal.hs @@ -1,7 +1,7 @@ module Utils.Frontend.Modal ( Modal(..) , customModal - , modal + , modal, msgModal ) where import ClassyPrelude.Yesod @@ -11,6 +11,9 @@ import Utils.Route import Settings (widgetFile) +import Control.Monad.Random.Class (MonadRandom(..)) +import qualified Data.UUID as UUID + data Modal site = Modal { modalTriggerId @@ -37,3 +40,15 @@ modal modalTrigger' modalContent = customModal Modal{..} modalTriggerId = Nothing modalId = Nothing modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") + + +-- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions) +msgModal :: WidgetT site IO () + -> Either (SomeRoute site) (WidgetT site IO ()) + -> WidgetT site IO () +msgModal modalTrigger' modalContent = do + modalTriggerId <- Just . UUID.toText <$> liftIO getRandom + modalId <- Just . UUID.toText <$> liftIO getRandom + customModal Modal{..} + where + modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") diff --git a/templates/messages/courseInvitationAlreadyRegistered.hamlet b/templates/messages/courseInvitationAlreadyRegistered.hamlet new file mode 100644 index 000000000..e6102976b --- /dev/null +++ b/templates/messages/courseInvitationAlreadyRegistered.hamlet @@ -0,0 +1,5 @@ +

    + _{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)} +
      + $forall email <- alreadyRegistered +
    • #{email} diff --git a/templates/messages/courseInvitationRegisteredWithoutField.hamlet b/templates/messages/courseInvitationRegisteredWithoutField.hamlet new file mode 100644 index 000000000..e623aab3b --- /dev/null +++ b/templates/messages/courseInvitationRegisteredWithoutField.hamlet @@ -0,0 +1,5 @@ +

      + _{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)} +
        + $forall email <- registeredNoField +
      • #{email} From 059e735d431777f9f86345366b3f08402d029605 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 May 2019 14:23:49 +0200 Subject: [PATCH 37/44] Use new version of systemd --- stack.yaml | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/stack.yaml b/stack.yaml index b6c31fd66..7fadc6e4e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,10 +21,6 @@ packages: git: https://github.com/pngwjpgh/memcached-binary.git commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad extra-dep: true - - location: - git: https://github.com/pngwjpgh/systemd.git - commit: 53d7ce6bd241ed4bedd25f1ae9383fd1856f9b77 - extra-dep: true extra-deps: - colonnade-1.2.0 @@ -53,4 +49,6 @@ extra-deps: - quickcheck-classes-0.4.14 - semirings-0.2.1.1 + - systemd-1.2.0 + resolver: lts-10.5 From 4a17a33b85d7e62c2cb9e43cfefcb474fc8f24b1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 May 2019 14:25:08 +0200 Subject: [PATCH 38/44] Bump ChangeLog --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index e45c75736..9f07bd783 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 13.05.2019 + + Kursverwalter können Teilnehmer hinzufügen + * Version 10.05.2019 Besseres Interface zum Einstellen von Abgebenden From 0cc1d7689f18f00b91e73b930a17b227b6f0a71e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 May 2019 15:34:45 +0200 Subject: [PATCH 39/44] UX Hilfe Online Korrektur --- messages/uniworx/de.msg | 3 +++ src/Handler/Corrections.hs | 5 +++-- templates/submission-assign.hamlet | 2 ++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2f846eadd..a243e5297 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -7,6 +7,7 @@ BtnRegister: Anmelden BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen BtnSave: Speichern +PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert. BtnCandidatesInfer: Studienfachzuordnung automatisch lernen BtnCandidatesDeleteConflicts: Konflikte löschen BtnCandidatesDeleteAll: Alle Beobachtungen löschen @@ -16,6 +17,8 @@ BtnLecInvDecline: Ablehnen BtnCorrInvAccept: Annehmen BtnCorrInvDecline: Ablehnen + + Aborted: Abgebrochen Remarks: Hinweise Registered: Angemeldet diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 01af2b880..0cf975867 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -617,7 +617,7 @@ postCorrectionR tid ssh csh shn cid = do <$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..}) <*> pointsForm <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) - let corrForm = wrapForm corrForm' def + let corrForm = wrapForm' BtnSave corrForm' def { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR , formEncoding = corrEncoding } @@ -948,9 +948,10 @@ postSAssignR tid ssh csh shn cID = do ] addMessageI Success MsgCorrectorUpdated redirect actionUrl - let corrForm = wrapForm corrForm' def + let corrForm = wrapForm' BtnSave corrForm' def { formAction = Just $ SomeRoute actionUrl , formEncoding = corrEncoding + , formSubmit = FormDualSubmit } defaultLayout $ do setTitleI MsgCorrectorAssignTitle diff --git a/templates/submission-assign.hamlet b/templates/submission-assign.hamlet index 9b3911766..2caf92979 100644 --- a/templates/submission-assign.hamlet +++ b/templates/submission-assign.hamlet @@ -1 +1,3 @@ +

        + _{MsgPressSaveToSave} ^{corrForm} From c17588912f6714970432b05371dee629ce79d526 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 13 May 2019 15:48:38 +0200 Subject: [PATCH 40/44] Fix data leak in CCommR --- src/Handler/Course.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5d2762eb2..dabc8c9d3 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1408,6 +1408,7 @@ postCCommR tid ssh csh = do E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser return user ) , ( RGCourseTutors @@ -1415,6 +1416,7 @@ postCCommR tid ssh csh = do E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + E.&&. user E.^. UserId E.==. tutor E.^. TutorUser return user ) ] From 028c0eab3230fdedef91b8e1c730fae8cd3f185a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 May 2019 16:29:00 +0200 Subject: [PATCH 41/44] Attempt filter UI subs --- src/Handler/Corrections.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 0cf975867..520f21c6d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -196,7 +196,7 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for ) colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData))) -colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id +colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id (\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId) (\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) @@ -268,6 +268,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d E.limit 1 return (user E.^. UserSurname) ) + , ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done + , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment + ) ] , dbtFilter = Map.fromList [ ( "term" @@ -515,7 +518,7 @@ postCorrectionsR = do , prismAForm (singletonFilter "term" ) mPrev $ aopt (lift `hoistField` selectField termOptions) (fslI MsgTerm) , prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectField schoolOptions) (fslI MsgCourseSchool) , Map.singleton "sheet-search" . maybeToList <$> aopt (lift `hoistField` searchField False) (fslI MsgSheet) (Just <$> listToMaybe =<< ((Map.lookup "sheet-search" =<< mPrev) <|> (Map.lookup "sheet" =<< mPrev))) - , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) + , prismAForm (singletonFilter "israted" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgRatingTime) ] courseOptions = runDB $ do courses <- selectList [] [Asc CourseShorthand] >>= filterM (\(Entity _ Course{..}) -> (== Authorized) <$> evalAccessCorrector courseTerm courseSchool courseShorthand) @@ -531,6 +534,7 @@ postCorrectionsR = do & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information & restrictSorting (\name _ -> name /= "corrector") & defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ] + & defaultFilter (Map.fromList [("israted",["no","Nein","No","False","Just False"]), ("sheet-search",["foo"])]) -- this does not work. "no" is the form value that we wanted correctionsR whereClause colonnade filterUI psValidator $ Map.fromList [ downloadAction ] @@ -879,8 +883,8 @@ postCorrectionsGradeR = do uid <- requireAuthId let whereClause = ratedBy uid displayColumns = mconcat -- should match getSSubsR for consistent UX - [ dbRow - , colSchool + [ -- dbRow, + colSchool , colTerm , colCourse , colSheet From ae96c6269c4da406eb267d51ef4b896916a04a12 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 May 2019 17:30:49 +0200 Subject: [PATCH 42/44] Surpress MsgMassInputTip for common case of single submission sheets --- messages/uniworx/de.msg | 4 +++- src/Handler/Submission.hs | 32 ++++++++++++++++++-------------- src/Handler/Utils/Form.hs | 27 ++++++++++++++++++++------- 3 files changed, 41 insertions(+), 22 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a243e5297..c20d2af83 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -8,6 +8,7 @@ BtnDeregister: Abmelden BtnHijack: Sitzung übernehmen BtnSave: Speichern PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert. +BtnHandIn: Abgeben BtnCandidatesInfer: Studienfachzuordnung automatisch lernen BtnCandidatesDeleteConflicts: Konflikte löschen BtnCandidatesDeleteAll: Alle Beobachtungen löschen @@ -203,6 +204,7 @@ 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 SubmissionMembers: Abgebende +SubmissionMember: Abgebende(r) SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien @@ -957,7 +959,7 @@ TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten -MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden. +MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Alle Änderungen müssen noch durch Drücken des Forumular-Knopfes bestätigt werden. HealthReport: Instanz-Zustand InstanceIdentification: Instanz-Identifikation diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 15c228664..c843f7e1e 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -162,14 +162,23 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident 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 + addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX + addFieldSettings = fslI MsgSubmissionMembers submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip + singleSubSettings = fslI MsgSubmissionMember + + maxSize | Arbitrary{..} <- grouping = Just maxParticipants + | otherwise = Nothing + mayEdit = is _Arbitrary grouping + + submittorSettings' + | maxSize > Just 1 = submittorSettings + | otherwise = singleSubSettings miButtonAction' :: forall p. PathPiece p => Maybe (Route UniWorX) -> p -> Maybe (SomeRoute UniWorX) miButtonAction' mCurrent frag = mCurrent <&> \current -> SomeRoute (current :#: frag) - submittorsForm + 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]) @@ -183,7 +192,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | 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 @@ -193,13 +202,8 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident | otherwise = do uid <- liftHandlerT requireAuthId mRoute <- getCurrentRoute - - let - maxSize - | Arbitrary{..} <- grouping = Just maxParticipants - | otherwise = Nothing - mayEdit = is _Arbitrary grouping + let miAdd :: ListPosition -> Natural -> (Text -> Text) @@ -231,7 +235,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident 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 + guard $ maybe True (/= Right uid) (dat !? delPos) || isJust msmid miDeleteList dat delPos @@ -248,8 +252,8 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident 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) - + 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 @@ -335,7 +339,7 @@ submissionHelper tid ssh csh shn mcid = do | otherwise = (mempty , Set.singleton $ Right userID) invites <- sourceInvitationsList smid <&> Set.fromList . map (\(email, InvDBDataSubmissionUser) -> Left email) - + return . over _2 (Set.union invites) $ foldMap breakUserFromBuddies submittors lastEdits <- do diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index aa3828422..92fbccf72 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -75,14 +75,27 @@ instance Finite ButtonSave saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m () saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) "" - - nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''ButtonSave id instance Button UniWorX ButtonSave where btnClasses BtnSave = [BCIsButton, BCPrimary] + + +data ButtonHandIn = BtnHandIn + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonHandIn +instance Finite ButtonHandIn + +nullaryPathPiece ''ButtonHandIn $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonHandIn id +instance Button UniWorX ButtonHandIn where + btnClasses BtnHandIn = [BCIsButton, BCPrimary] + + + data ButtonRegister = BtnRegister | BtnDeregister deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonRegister @@ -190,7 +203,7 @@ multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq -> (Html -> MForm Handler (FormResult a, Widget)) multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction - + ------------ -- Fields -- ------------ @@ -549,7 +562,7 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel LTUUnique{_ltuResult} -> Right _ltuResult LTUNone{} -> Left MsgIllDefinedUTCTime LTUAmbiguous{} -> Left MsgAmbiguousUTCTime - + langField :: Bool -- ^ Only allow values from `appLanguages` -> Field (HandlerT UniWorX IO) Lang @@ -703,7 +716,7 @@ multiUserField onlySuggested suggestions = Field{..} lookupExpr | onlySuggested = suggestions | otherwise = Just $ E.from return - + fieldEnctype = UrlEncoded fieldView theId name attrs val isReq = do val' <- case val of @@ -723,7 +736,7 @@ multiUserField onlySuggested suggestions = Field{..} return $ emails ++ rEmails datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions - + [whamlet| $newline never @@ -739,7 +752,7 @@ multiUserField onlySuggested suggestions = Field{..} $forall email <- suggestedEmails