From 64dbfe39057bf354240a76cbb2495179ed790dac Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 11:18:35 +0100 Subject: [PATCH 1/8] Identify auxiliary dbtable forms to prevent collisions --- src/Handler/Utils/Table/Pagination.hs | 8 ++++---- src/Utils/Form.hs | 2 ++ 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 964323b83..7ddba89b3 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -533,14 +533,14 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = def - ((filterRes, filterWdgt), filterEnc) <- runFormGet . renderAForm FormDBTableFilter $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing) + ((filterRes, filterWdgt), filterEnc) <- runFormGet . identForm FIDDBTableFilter . renderAForm FormDBTableFilter $ (,) + <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing) <*> dbtFilterUI let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi - ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . renderAForm FormDBTablePagesize $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing) + ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . identForm FIDDBTablePagesize . renderAForm FormDBTablePagesize $ (,) + <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing) <*> areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) <* autosubmitButton diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1c2bf385e..db9fa039e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -170,6 +170,8 @@ data FormIdentifier | FIDSystemMessageModify | FIDSystemMessageModifyTranslation UUID | FIDSystemMessageAddTranslation + | FIDDBTableFilter + | FIDDBTablePagesize deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where From 45bfe771ad3725c911d5da5cf68f2f16412b84e1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 16:24:23 +0100 Subject: [PATCH 2/8] Embrace collisions in dbtable auxiliary tables --- package.yaml | 1 + src/Handler/Course.hs | 6 +-- src/Handler/Utils/Table/Pagination.hs | 63 +++++++++++++++++---------- src/Import/NoFoundation.hs | 1 + src/Utils/Form.hs | 5 +++ src/Yesod/Core/Types/Instances.hs | 16 +++++++ templates/table/layout.julius | 4 +- 7 files changed, 68 insertions(+), 28 deletions(-) create mode 100644 src/Yesod/Core/Types/Instances.hs diff --git a/package.yaml b/package.yaml index 4bc841965..e480feb22 100644 --- a/package.yaml +++ b/package.yaml @@ -162,6 +162,7 @@ default-extensions: - PolyKinds - PackageImports - TypeApplications + - RecursiveDo ghc-options: - -Wall diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 116a54487..cb0a05f25 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -175,9 +175,9 @@ makeCourseTable whereClause colChoices psValidator = do E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) ] - , dbtFilterUI = mconcat - [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) Nothing - , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) Nothing + , dbtFilterUI = \mPrev -> mconcat + [ Map.singleton "search" . maybeToList <$> aopt textField (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev) + , Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev) ] , dbtStyle = def , dbtParams = def diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 7ddba89b3..14a613f59 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -343,7 +343,7 @@ data DBTable m x = forall a r r' h i t k k'. , dbtColonnade :: Colonnade h r' (DBCell m x) , dbtSorting :: Map SortingKey (SortColumn t) , dbtFilter :: Map FilterKey (FilterColumn t) - , dbtFilterUI :: AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) + , dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text]) , dbtStyle :: DBStyle , dbtParams :: DBParams m x , dbtIdent :: i @@ -452,7 +452,7 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype) -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget)) - runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenFields dbtable pi pKeys . withFragment + runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where def = DBParamsForm @@ -475,18 +475,37 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype $(widgetFile "table/form-wrap") -addPIHiddenFields :: ToJSON k' => DBTable m x -> PaginationInput -> [k'] -> Form a -> Form a -addPIHiddenFields DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi pKeys form fragment = do +data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x } + +instance PathPiece x => PathPiece (WithIdent x) where + toPathPiece (WithIdent ident x) + | not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x + | otherwise = toPathPiece x + fromPathPiece txt = do + let sep = "-" + (ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt + WithIdent <$> pure ident <*> fromPathPiece rest + +addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a) +addPIHiddenField DBTable{ dbtIdent } pi form fragment + = form $ fragment <> [shamlet| + $newline never + + |] + where + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent + +addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a) +addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do encrypted <- encodedSecretBox SecretBoxShort pKeys form $ fragment <> [shamlet| $newline never - |] where - wIdent n - | not $ null dbtIdent = dbtIdent <> "-" <> n - | otherwise = n + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where mempty = FormCell mempty (return mempty) @@ -505,9 +524,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , d <- [SortAsc, SortDesc] , let t' = toPathPiece $ SortingSetting t d ] - wIdent n - | not $ null dbtIdent = dbtIdent <> "-" <> n - | otherwise = n + wIdent :: Text -> Text + wIdent = toPathPiece . WithIdent dbtIdent dbsAttrs' | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs | otherwise = dbsAttrs @@ -517,7 +535,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , fieldEnctype = UrlEncoded } - piPrevious <- lift . runInputPostMaybe $ ireq (jsonField True) (wIdent "pagination") + piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination") let piPreviousRes = maybe FormMissing FormSuccess piPrevious previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous") @@ -533,21 +551,20 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = def - ((filterRes, filterWdgt), filterEnc) <- runFormGet . identForm FIDDBTableFilter . renderAForm FormDBTableFilter $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piFilter .~ Nothing & _piPage .~ Nothing) - <*> dbtFilterUI + (((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo + (filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi) - let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi + let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi - ((pagesizeRes, pagesizeWdgt), pagesizeEnc) <- lift . runFormGet . identForm FIDDBTablePagesize . renderAForm FormDBTablePagesize $ (,) - <$> areq (jsonField True) ("" & addName (wIdent "pagination-base")) (Just $ prevPi & _piPage .~ Nothing & _piLimit .~ Nothing) - <*> areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) - <* autosubmitButton + (pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $ + areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize) + <* autosubmitButton + return (filterRes', pagesizeRes') let - piResult = piPreviousRes - <|> (\(prev, fSettings) -> prev & _piFilter .~ Just fSettings) <$> filterRes - <|> (\(prev, ps) -> prev & _piLimit .~ Just ps) <$> pagesizeRes + piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes + <|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes + <|> piPreviousRes <|> piInput psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 2e668a8fd..3240920b8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -16,6 +16,7 @@ import Yesod.Core.Types as Import (loggerSet) import Yesod.Default.Config2 as Import import Utils as Import import Yesod.Core.Json as Import (provideJson) +import Yesod.Core.Types.Instances as Import () import Data.Fixed as Import diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index db9fa039e..921c82ec5 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -321,6 +321,11 @@ formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . formResultMaybe FormMissing _ = return Nothing formResultMaybe (FormSuccess res) f = f res +formResult' :: FormResult a -> Maybe a +formResult' FormMissing = Nothing +formResult' (FormFailure _) = Nothing +formResult' (FormSuccess x) = Just x + runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a) runInputGetMaybe form = do res <- runInputGetResult form diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs new file mode 100644 index 000000000..e296d0c52 --- /dev/null +++ b/src/Yesod/Core/Types/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Types.Instances + ( + ) where + +import ClassyPrelude +import Yesod.Core.Types + +import Control.Monad.Fix + +instance MonadFix m => MonadFix (HandlerT site m) where + mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r + +instance MonadFix m => MonadFix (WidgetT site m) where + mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r diff --git a/templates/table/layout.julius b/templates/table/layout.julius index 72a4586fe..38feadbbc 100644 --- a/templates/table/layout.julius +++ b/templates/table/layout.julius @@ -10,12 +10,12 @@ function setupAsync(wrapper) { - var table = wrapper.querySelector('#' + #{String $ dbtIdent}); + var table = wrapper.querySelector('#' + #{String dbtIdent}); if (!table) return; var ths = Array.from(table.querySelectorAll('th.sortable')); - var pagination = wrapper.querySelector('#' + #{String $ dbtIdent} + '-pagination'); + var pagination = wrapper.querySelector('#' + #{String dbtIdent} + '-pagination'); ths.forEach(function(th) { th.addEventListener('click', clickHandler); From 2eb09d0de78e5c47de291ecd6434a53c6f2618d0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 17:37:42 +0100 Subject: [PATCH 3/8] Split models --- models | 262 --------------------------- models/config | 4 + models/courses | 40 ++++ models/exams | 22 +++ models/files | 5 + models/jobs | 12 ++ models/rooms | 26 +++ models/schools | 7 + models/sheets | 37 ++++ models/submissions | 34 ++++ models/system-messages | 14 ++ models/terms | 10 + models/tutorials | 8 + models/users | 43 +++++ package.yaml | 1 + src/Database/Persist/TH/Directory.hs | 27 +++ src/Model.hs | 3 +- 17 files changed, 292 insertions(+), 263 deletions(-) delete mode 100644 models create mode 100644 models/config create mode 100644 models/courses create mode 100644 models/exams create mode 100644 models/files create mode 100644 models/jobs create mode 100644 models/rooms create mode 100644 models/schools create mode 100644 models/sheets create mode 100644 models/submissions create mode 100644 models/system-messages create mode 100644 models/terms create mode 100644 models/tutorials create mode 100644 models/users create mode 100644 src/Database/Persist/TH/Directory.hs diff --git a/models b/models deleted file mode 100644 index 47e95f579..000000000 --- a/models +++ /dev/null @@ -1,262 +0,0 @@ -User json - ident (CI Text) - authentication AuthenticationMode - matrikelnummer Text Maybe - email (CI Text) - displayName Text - surname Text -- always use: nameWidget displayName surname - maxFavourites Int default=12 - theme Theme default='Default' - dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" - dateFormat DateTimeFormat "default='%d.%m.%Y'" - timeFormat DateTimeFormat "default='%R'" - downloadFiles Bool default=false - mailLanguages MailLanguages default='[]' - notificationSettings NotificationSettings - UniqueAuthentication ident - UniqueEmail email - deriving Show Eq -UserAdmin - user UserId - school SchoolId - UniqueUserAdmin user school -UserLecturer - user UserId - school SchoolId - UniqueSchoolLecturer user school -StudyFeatures - user UserId - degree StudyDegreeId - field StudyTermsId - type StudyFieldType - semester Int - -- UniqueUserSubject user degree field -- There exists a counterexample -StudyDegree - key Int - shorthand Text Maybe - name Text Maybe - Primary key -StudyTerms - key Int - shorthand Text Maybe - name Text Maybe - Primary key -Term json - name TermIdentifier -- unTermKey :: TermId -> TermIdentifier - start Day -- TermKey :: TermIdentifier -> TermId - end Day - holidays [Day] - lectureStart Day - lectureEnd Day - active Bool - Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } - deriving Show -- type TermId = Key Term -School json - name (CI Text) - shorthand (CI Text) - UniqueSchool name - UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text - Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } - deriving Eq -DegreeCourse json - course CourseId - degree StudyDegreeId - terms StudyTermsId - UniqueDegreeCourse course degree terms -Course - name (CI Text) - description Html Maybe - linkExternal Text Maybe - shorthand (CI Text) - term TermId - school SchoolId - capacity Int64 Maybe - -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo - registerFrom UTCTime Maybe - registerTo UTCTime Maybe - deregisterUntil UTCTime Maybe - registerSecret Text Maybe -- Falls ein Passwort erforderlich ist - materialFree Bool - TermSchoolCourseShort term school shorthand - TermSchoolCourseName term school name -CourseEdit - user UserId - time UTCTime - course CourseId -CourseFavourite - user UserId - time UTCTime - course CourseId - UniqueCourseFavourite user course - deriving Show -Lecturer - user UserId - course CourseId - UniqueLecturer user course -CourseParticipant - course CourseId - user UserId - registration UTCTime - UniqueParticipant user course -Sheet - course CourseId - name (CI Text) - description Html Maybe - type SheetType - grouping SheetGroup - markingText Html Maybe - visibleFrom UTCTime Maybe - activeFrom UTCTime - activeTo UTCTime - hintFrom UTCTime Maybe - solutionFrom UTCTime Maybe - uploadMode UploadMode - submissionMode SheetSubmissionMode default='UserSubmissions' - CourseSheet course name -SheetEdit - user UserId - time UTCTime - sheet SheetId -SheetPseudonym - sheet SheetId - pseudonym Pseudonym - user UserId - UniqueSheetPseudonym sheet pseudonym - UniqueSheetPseudonymUser sheet user -SheetCorrector - user UserId - sheet SheetId - load Load - state CorrectorState default='CorrectorNormal' - UniqueSheetCorrector user sheet - deriving Show Eq Ord -SheetFile - sheet SheetId - file FileId - type SheetFileType - UniqueSheetFile file sheet type -File - title FilePath - content ByteString Maybe -- Nothing iff this is a directory - modified UTCTime - deriving Show Eq Generic -Submission - sheet SheetId - ratingPoints Points Maybe -- "Just" does not mean done - ratingComment Text Maybe -- "Just" does not mean done - ratingBy UserId Maybe -- assigned corrector - ratingAssigned UTCTime Maybe -- time assigned corrector - ratingTime UTCTime Maybe -- "Just" here indicates done! - deriving Show -SubmissionEdit - user UserId - time UTCTime - submission SubmissionId -SubmissionFile - submission SubmissionId - file FileId - isUpdate Bool -- is this the file updated by a corrector (original will always be retained) - isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector - UniqueSubmissionFile file submission isUpdate - deriving Show -SubmissionUser -- Actual submission participant - user UserId - submission SubmissionId - UniqueSubmissionUser user submission -SubmissionGroup - course CourseId - name Text Maybe -SubmissionGroupEdit - user UserId - time UTCTime - submissionGroup SubmissionGroupId -SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser - submissionGroup SubmissionGroupId - user UserId - UniqueSubmissionGroupUser submissionGroup user -Tutorial json - name Text - tutor UserId - course CourseId -TutorialUser - user UserId - tutorial TutorialId - UniqueTutorialUser user tutorial -Booking - term TermId - begin UTCTime - end UTCTime - weekly Bool - exceptions [Day] -- only if weekly, begin in exception - bookedFor RoomForId - room RoomId -BookingEdit - user UserId - time UTCTime - boooking BookingId -Room - name Text - capacity Int Maybe - building Text Maybe --- BookingRoom --- subject RoomForId --- room RoomId --- booking BookingId --- UniqueRoomCourse subject room booking -+RoomFor - course CourseId - tutorial TutorialId - exam ExamId --- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... --- EXAMS ARE TODO: -Exam - course CourseId - name Text - description Text - begin UTCTime - end UTCTime - registrationBegin UTCTime - registrationEnd UTCTime - deregistrationEnd UTCTime - ratingVisible Bool - statisticsVisible Bool ---ExamEdit --- user UserId --- time UTCTime --- exam ExamId ---ExamUser --- user UserId --- examId ExamId --- -- CONTINUE HERE: Include rating in this table or separately? --- UniqueExamUser user examId --- By default this file is used in Model.hs (which is imported by Foundation.hs) -QueuedJob - content Value - creationInstance InstanceId - creationTime UTCTime - lockInstance InstanceId Maybe - lockTime UTCTime Maybe - deriving Eq Read Show Generic Typeable -CronLastExec - job Value - time UTCTime - instance InstanceId - UniqueCronLastExec job -SystemMessage - from UTCTime Maybe - to UTCTime Maybe - authenticatedOnly Bool - severity MessageClass - defaultLanguage Lang - content Html - summary Html Maybe -SystemMessageTranslation - message SystemMessageId - language Lang - content Html - summary Html Maybe - UniqueSystemMessageTranslation message language -ClusterConfig - setting ClusterSettingsKey - value Value - Primary setting \ No newline at end of file diff --git a/models/config b/models/config new file mode 100644 index 000000000..33bcaf8d6 --- /dev/null +++ b/models/config @@ -0,0 +1,4 @@ +ClusterConfig + setting ClusterSettingsKey + value Value + Primary setting \ No newline at end of file diff --git a/models/courses b/models/courses new file mode 100644 index 000000000..9ecc31abe --- /dev/null +++ b/models/courses @@ -0,0 +1,40 @@ +DegreeCourse json + course CourseId + degree StudyDegreeId + terms StudyTermsId + UniqueDegreeCourse course degree terms +Course + name (CI Text) + description Html Maybe + linkExternal Text Maybe + shorthand (CI Text) + term TermId + school SchoolId + capacity Int64 Maybe + -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + registerSecret Text Maybe -- Falls ein Passwort erforderlich ist + materialFree Bool + TermSchoolCourseShort term school shorthand + TermSchoolCourseName term school name +CourseEdit + user UserId + time UTCTime + course CourseId +CourseFavourite + user UserId + time UTCTime + course CourseId + UniqueCourseFavourite user course + deriving Show +Lecturer + user UserId + course CourseId + UniqueLecturer user course +CourseParticipant + course CourseId + user UserId + registration UTCTime + UniqueParticipant user course diff --git a/models/exams b/models/exams new file mode 100644 index 000000000..e356e4221 --- /dev/null +++ b/models/exams @@ -0,0 +1,22 @@ +-- EXAMS ARE TODO: +Exam + course CourseId + name Text + description Text + begin UTCTime + end UTCTime + registrationBegin UTCTime + registrationEnd UTCTime + deregistrationEnd UTCTime + ratingVisible Bool + statisticsVisible Bool +--ExamEdit +-- user UserId +-- time UTCTime +-- exam ExamId +--ExamUser +-- user UserId +-- examId ExamId +-- -- CONTINUE HERE: Include rating in this table or separately? +-- UniqueExamUser user examId +-- By default this file is used in Model.hs (which is imported by Foundation.hs) \ No newline at end of file diff --git a/models/files b/models/files new file mode 100644 index 000000000..62a5ffe72 --- /dev/null +++ b/models/files @@ -0,0 +1,5 @@ +File + title FilePath + content ByteString Maybe -- Nothing iff this is a directory + modified UTCTime + deriving Show Eq Generic diff --git a/models/jobs b/models/jobs new file mode 100644 index 000000000..15f7bb7dc --- /dev/null +++ b/models/jobs @@ -0,0 +1,12 @@ +QueuedJob + content Value + creationInstance InstanceId + creationTime UTCTime + lockInstance InstanceId Maybe + lockTime UTCTime Maybe + deriving Eq Read Show Generic Typeable +CronLastExec + job Value + time UTCTime + instance InstanceId + UniqueCronLastExec job diff --git a/models/rooms b/models/rooms new file mode 100644 index 000000000..7b62d41f5 --- /dev/null +++ b/models/rooms @@ -0,0 +1,26 @@ +Booking + term TermId + begin UTCTime + end UTCTime + weekly Bool + exceptions [Day] -- only if weekly, begin in exception + bookedFor RoomForId + room RoomId +BookingEdit + user UserId + time UTCTime + boooking BookingId +Room + name Text + capacity Int Maybe + building Text Maybe +-- BookingRoom +-- subject RoomForId +-- room RoomId +-- booking BookingId +-- UniqueRoomCourse subject room booking ++RoomFor + course CourseId + tutorial TutorialId + exam ExamId +-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ... diff --git a/models/schools b/models/schools new file mode 100644 index 000000000..b253c7390 --- /dev/null +++ b/models/schools @@ -0,0 +1,7 @@ +School json + name (CI Text) + shorthand (CI Text) + UniqueSchool name + UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text + Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } + deriving Eq diff --git a/models/sheets b/models/sheets new file mode 100644 index 000000000..e6e7c1051 --- /dev/null +++ b/models/sheets @@ -0,0 +1,37 @@ +Sheet + course CourseId + name (CI Text) + description Html Maybe + type SheetType + grouping SheetGroup + markingText Html Maybe + visibleFrom UTCTime Maybe + activeFrom UTCTime + activeTo UTCTime + hintFrom UTCTime Maybe + solutionFrom UTCTime Maybe + uploadMode UploadMode + submissionMode SheetSubmissionMode default='UserSubmissions' + CourseSheet course name +SheetEdit + user UserId + time UTCTime + sheet SheetId +SheetPseudonym + sheet SheetId + pseudonym Pseudonym + user UserId + UniqueSheetPseudonym sheet pseudonym + UniqueSheetPseudonymUser sheet user +SheetCorrector + user UserId + sheet SheetId + load Load + state CorrectorState default='CorrectorNormal' + UniqueSheetCorrector user sheet + deriving Show Eq Ord +SheetFile + sheet SheetId + file FileId + type SheetFileType + UniqueSheetFile file sheet type diff --git a/models/submissions b/models/submissions new file mode 100644 index 000000000..db7e543a6 --- /dev/null +++ b/models/submissions @@ -0,0 +1,34 @@ +Submission + sheet SheetId + ratingPoints Points Maybe -- "Just" does not mean done + ratingComment Text Maybe -- "Just" does not mean done + ratingBy UserId Maybe -- assigned corrector + ratingAssigned UTCTime Maybe -- time assigned corrector + ratingTime UTCTime Maybe -- "Just" here indicates done! + deriving Show +SubmissionEdit + user UserId + time UTCTime + submission SubmissionId +SubmissionFile + submission SubmissionId + file FileId + isUpdate Bool -- is this the file updated by a corrector (original will always be retained) + isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector + UniqueSubmissionFile file submission isUpdate + deriving Show +SubmissionUser -- Actual submission participant + user UserId + submission SubmissionId + UniqueSubmissionUser user submission +SubmissionGroup + course CourseId + name Text Maybe +SubmissionGroupEdit + user UserId + time UTCTime + submissionGroup SubmissionGroupId +SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser + submissionGroup SubmissionGroupId + user UserId + UniqueSubmissionGroupUser submissionGroup user diff --git a/models/system-messages b/models/system-messages new file mode 100644 index 000000000..0547718ae --- /dev/null +++ b/models/system-messages @@ -0,0 +1,14 @@ +SystemMessage + from UTCTime Maybe + to UTCTime Maybe + authenticatedOnly Bool + severity MessageClass + defaultLanguage Lang + content Html + summary Html Maybe +SystemMessageTranslation + message SystemMessageId + language Lang + content Html + summary Html Maybe + UniqueSystemMessageTranslation message language diff --git a/models/terms b/models/terms new file mode 100644 index 000000000..ba6cafd73 --- /dev/null +++ b/models/terms @@ -0,0 +1,10 @@ +Term json + name TermIdentifier -- unTermKey :: TermId -> TermIdentifier + start Day -- TermKey :: TermIdentifier -> TermId + end Day + holidays [Day] + lectureStart Day + lectureEnd Day + active Bool + Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } + deriving Show -- type TermId = Key Term diff --git a/models/tutorials b/models/tutorials new file mode 100644 index 000000000..51e20b195 --- /dev/null +++ b/models/tutorials @@ -0,0 +1,8 @@ +Tutorial json + name Text + tutor UserId + course CourseId +TutorialUser + user UserId + tutorial TutorialId + UniqueTutorialUser user tutorial diff --git a/models/users b/models/users new file mode 100644 index 000000000..0cd2d682a --- /dev/null +++ b/models/users @@ -0,0 +1,43 @@ +User json + ident (CI Text) + authentication AuthenticationMode + matrikelnummer Text Maybe + email (CI Text) + displayName Text + surname Text -- always use: nameWidget displayName surname + maxFavourites Int default=12 + theme Theme default='Default' + dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" + dateFormat DateTimeFormat "default='%d.%m.%Y'" + timeFormat DateTimeFormat "default='%R'" + downloadFiles Bool default=false + mailLanguages MailLanguages default='[]' + notificationSettings NotificationSettings + UniqueAuthentication ident + UniqueEmail email + deriving Show Eq +UserAdmin + user UserId + school SchoolId + UniqueUserAdmin user school +UserLecturer + user UserId + school SchoolId + UniqueSchoolLecturer user school +StudyFeatures + user UserId + degree StudyDegreeId + field StudyTermsId + type StudyFieldType + semester Int + -- UniqueUserSubject user degree field -- There exists a counterexample +StudyDegree + key Int + shorthand Text Maybe + name Text Maybe + Primary key +StudyTerms + key Int + shorthand Text Maybe + name Text Maybe + Primary key diff --git a/package.yaml b/package.yaml index e480feb22..1bd402afd 100644 --- a/package.yaml +++ b/package.yaml @@ -112,6 +112,7 @@ dependencies: - text-metrics - pkcs7 - memcached-binary + - directory-tree other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs new file mode 100644 index 000000000..770b71d71 --- /dev/null +++ b/src/Database/Persist/TH/Directory.hs @@ -0,0 +1,27 @@ +module Database.Persist.TH.Directory + ( persistDirectoryWith + ) where + +import ClassyPrelude hiding (mapM_, toList) + +import Database.Persist.TH (parseReferences) +import Database.Persist.Quasi (PersistSettings) +import Language.Haskell.TH.Syntax + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified System.IO as SIO + +import qualified System.Directory.Tree as DirTree + +import Data.Foldable (Foldable(..), mapM_) + +persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp +persistDirectoryWith settings dir = do + files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + Text.hGetContents h + mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files + + parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files diff --git a/src/Model.hs b/src/Model.hs index 91de5c48c..417c551fb 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -8,6 +8,7 @@ module Model import ClassyPrelude.Yesod import Database.Persist.Quasi +import Database.Persist.TH.Directory -- import Data.Time -- import Data.ByteString import Model.Types @@ -26,7 +27,7 @@ import Settings.Cluster (ClusterSettingsKey) -- at: -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] - $(persistFileWith lowerCaseSettings "models") + $(persistDirectoryWith lowerCaseSettings "models") -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) From aa325f7fa947fdc76467ae6c3002d0f3b7659956 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 17:51:00 +0100 Subject: [PATCH 4/8] Due to HasRoute-refactor CourseNewTemplateR is no longer needed --- routes | 1 - src/Foundation.hs | 2 +- src/Handler/Course.hs | 9 --------- 3 files changed, 1 insertion(+), 11 deletions(-) diff --git a/routes b/routes index 25d5bb346..c2a320731 100644 --- a/routes +++ b/routes @@ -60,7 +60,6 @@ -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer -!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free /register CRegisterR POST !timeANDcapacity diff --git a/src/Foundation.hs b/src/Foundation.hs index 76af3794e..a84e7fb7a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1190,7 +1190,7 @@ pageActions (CourseR tid ssh csh CShowR) = { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseNewTemplate , menuItemIcon = Nothing - , menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh) + , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)]) , menuItemModal = False , menuItemAccessCallback' = return True } diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index cb0a05f25..0db760fe3 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -18,8 +18,6 @@ import Data.Maybe import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.CaseInsensitive as CI - import qualified Database.Esqueleto as E @@ -316,13 +314,6 @@ postCRegisterR tid ssh csh = do redirect $ CourseR tid ssh csh CShowR -getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html -getCourseNewTemplateR mbTid mbSsh mbCsh = - redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid - , ("ssh",).CI.original.unSchoolKey <$> mbSsh - , ("csh",).CI.original <$> mbCsh - ]) - getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId From 842d7d85e3f6005c8b884732b4c2c395db2ab0e6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 17:58:50 +0100 Subject: [PATCH 5/8] quiet hlint --- src/Handler/Course.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0db760fe3..45cfcaa35 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,6 +1,6 @@ module Handler.Course where -import Import hiding (catMaybes) +import Import import Utils.Lens -- import Utils.DB From 45182e5074b91698794faaf7c42b31591b52526e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 18:28:53 +0100 Subject: [PATCH 6/8] Tighten check for empty course --- src/Foundation.hs | 7 +++++-- src/Utils.hs | 3 +++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index a84e7fb7a..080d9e2d5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -491,8 +491,11 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] - guard $ registered <= 0 + assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return E.countRows return Authorized r -> $unsupportedAuthPredicate AuthEmpty r tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of diff --git a/src/Utils.hs b/src/Utils.hs index 4bc4c1c9f..7c99ca13c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -448,6 +448,9 @@ guardM f = guard =<< f assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM f x = x >>= assertM' f +assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m () +assertM_ f x = guard . f =<< x + assertM' :: MonadPlus m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) From c6b7ad0580bcd2dc1e0dca8cdb22ccd0c4deb9cd Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 21:55:42 +0100 Subject: [PATCH 7/8] Generic and "safe" deletion widget --- messages/uniworx/de.msg | 18 +++-- src/Data/CaseInsensitive/Instances.hs | 4 ++ src/Foundation.hs | 25 +++++++ src/Handler/Course.hs | 23 ++++-- src/Handler/Sheet.hs | 45 ++++++------ src/Handler/SystemMessage.hs | 2 +- src/Handler/Utils/Delete.hs | 73 ++++++++++++++++++++ src/Handler/Utils/Form.hs | 3 + src/Utils.hs | 6 ++ src/Utils/Form.hs | 28 ++++++-- templates/widgets/delete-confirmation.hamlet | 13 ++++ templates/widgets/delete-confirmation.lucius | 5 ++ 12 files changed, 207 insertions(+), 38 deletions(-) create mode 100644 src/Handler/Utils/Delete.hs create mode 100644 templates/widgets/delete-confirmation.hamlet create mode 100644 templates/widgets/delete-confirmation.lucius diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 78f999ee3..fd07e0ad8 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -74,6 +74,8 @@ CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein CourseFilterSearch: Volltext-Suche CourseFilterRegistered: Registriert +CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen? +CourseDeleted: Kurs gelöscht NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht. NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht. @@ -89,10 +91,12 @@ SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert. SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}. -SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? -SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. +SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren! SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht. +SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen? +SheetDeleted: Übungsblatt gelöscht + SheetUploadMode: Abgabe von Dateien SheetSubmissionMode: Abgabe-Modus SheetExercise: Aufgabenstellung @@ -545,17 +549,19 @@ MenuCorrections: Abgaben MenuSheetNew: Neues Übungsblatt anlegen MenuCourseEdit: Kurs editieren MenuCourseNewTemplate: Als neuen Kurs klonen +MenuCourseDelete: Kurs löschen MenuSubmissionNew: Abgabe anlegen MenuSubmissionOwn: Abgabe MenuCorrectors: Korrektoren MenuSheetEdit: Übungsblatt editieren +MenuSheetDelete: Übungsblatt löschen MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsGrade: Abgaben bewerten AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert -AuthTagFree: Seite ist generell zugänglich +AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert AuthTagDeprecated: Seite ist nicht überholt @@ -573,4 +579,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren AuthTagAuthentication: Authentifizierung erfüllt Anforderungen AuthTagRead: Zugriff ist nur lesend -AuthTagWrite: Zugriff ist i.A. schreibend \ No newline at end of file +AuthTagWrite: Zugriff ist i.A. schreibend + +DeleteCopyStringIfSure count@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE count "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab. +DeleteConfirmation: Bestätigung +DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. \ No newline at end of file diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index c9e7f0c5d..bfc2790ff 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -13,6 +13,7 @@ import qualified Data.CaseInsensitive as CI import Database.Persist.Sql import Text.Blaze (ToMarkup(..)) +import Text.Shakespeare.Text (ToText(..)) import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -63,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where toMarkup = toMarkup . CI.original preEscapedToMarkup = preEscapedToMarkup . CI.original +instance ToText a => ToText (CI a) where + toText = toText . CI.original + instance ToWidget site a => ToWidget site (CI a) where toWidget = toWidget . CI.original diff --git a/src/Foundation.hs b/src/Foundation.hs index 080d9e2d5..9ec2efe26 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -146,6 +146,15 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) + +pluralDE :: Int -- ^ Count + -> Text -- ^ Singular + -> Text -- ^ Plural + -> Text +pluralDE num singularForm pluralForm + | num == 1 = singularForm + | otherwise = pluralForm + -- Messages creates type UniWorXMessage and RenderMessage UniWorX instance mkMessage "UniWorX" "messages/uniworx" "de" mkMessageVariant "UniWorX" "Campus" "messages/campus" "de" @@ -1197,6 +1206,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CourseR tid ssh csh SheetListR) = [ MenuItem @@ -1257,6 +1274,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSheetDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SSubsR) = [ MenuItem diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 45cfcaa35..3ac565d92 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -6,6 +6,7 @@ import Utils.Lens -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells +import Handler.Utils.Delete -- import Data.Time import qualified Data.Text as T @@ -386,10 +387,24 @@ pgCEditR isGetReq tid ssh csh = do courseEditHandler isGetReq $ courseToForm <$> course -getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCDeleteR = error "TODO: implement getCDeleteR" -postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -postCDeleteR = error "TODO: implement getCDeleteR" +getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCDeleteR = postCDeleteR +postCDeleteR tid ssh csh = do + Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + deleteR DeleteRoute + { drRecords = Set.singleton cId + , drRenderRecord = \(Entity _ Course{courseName, courseTerm, courseSchool}) -> do + School{schoolName} <- getJust courseSchool + return [whamlet| + #{courseName} (_{SomeMessage $ ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}) + |] + , drRecordConfirmString = \(Entity _ Course{courseShorthand, courseTerm, courseSchool}) -> + return [st|#{unSchoolKey courseSchool}/#{termToText (unTermKey courseTerm)}/#{courseShorthand}|] + , drCaption = SomeMessage MsgCourseDeleteQuestion + , drSuccessMessage = SomeMessage MsgCourseDeleted + , drAbort = SomeRoute $ CourseR tid ssh csh CShowR + , drSuccess = SomeRoute CourseListR + } {- TODO | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler , Just cid <- cfCourseId res -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 090fefcd5..b14be5e43 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -7,6 +7,7 @@ import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells import Handler.Utils.SheetType +import Handler.Utils.Delete -- import Data.Time -- import qualified Data.Text as T @@ -528,30 +529,26 @@ handleSheetEdit tid ssh csh msId template dbAction = do $(widgetFile "formPageI18n") - -getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -getSDelR tid ssh csh shn = do - ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) - case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR - (FormSuccess BtnDelete) -> do - runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade - -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - addMessageI Info $ MsgSheetDelOk tid ssh csh shn - redirect $ CourseR tid ssh csh SheetListR - _other -> do - submissionno <- runDB $ do - sid <- fetchSheetId tid ssh csh shn - count [SubmissionSheet ==. sid] - let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid ssh csh shn SDelR - defaultLayout $ do - setTitleI $ MsgSheetTitle tid ssh csh shn - $(widgetFile "formPageI18n") - -postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -postSDelR = getSDelR - +getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSDelR = postSDelR +postSDelR tid ssh csh shn = do + sid <- runDB $ fetchSheetId tid ssh csh shn + deleteR DeleteRoute + { drRecords = Set.singleton sid + , drRenderRecord = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseName} <- getJust sheetCourse + School{schoolName} <- getJust courseSchool + return [whamlet| + #{sheetName} (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}) + |] + , drRecordConfirmString = \(Entity _ Sheet{sheetName, sheetCourse}) -> do + Course{courseTerm, courseSchool, courseShorthand} <- getJust sheetCourse + return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}|] + , drCaption = SomeMessage MsgSheetDeleteQuestion + , drSuccessMessage = SomeMessage MsgSheetDeleted + , drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR + , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR + } insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 07c0e919c..2f23745e2 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -59,7 +59,7 @@ postMessageR cID = do <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent) <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary) ) - <*> combinedButtonField (universeF :: [BtnSubmitDelete]) + <*> combinedButtonFieldF "" let modifyTranss = Map.map (view $ _1._1) modifyTranss' diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs new file mode 100644 index 000000000..68cdb13d9 --- /dev/null +++ b/src/Handler/Utils/Delete.hs @@ -0,0 +1,73 @@ +module Handler.Utils.Delete + ( DeleteRoute(..) + , deleteR + ) where + +import Import +import Handler.Utils.Form + +import Utils.Lens + +import qualified Data.Text as Text +import qualified Data.Set as Set + +import qualified Data.CaseInsensitive as CI + +import Control.Monad.Trans.Random +import System.Random (mkStdGen) +import System.Random.Shuffle (shuffleM) +import qualified Crypto.Hash as Crypto (hash) +import Crypto.Hash (Digest, SHAKE128) + +import qualified Data.ByteArray as ByteArray + + +data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute + { drRecords :: Set (Key record) + , drRenderRecord :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget + , drRecordConfirmString :: Entity record -> ReaderT SqlBackend (HandlerT UniWorX IO) Text + , drCaption + , drSuccessMessage :: SomeMessage UniWorX + , drAbort + , drSuccess :: SomeRoute UniWorX + } + + +deleteR :: DeleteRoute -> Handler Html +deleteR DeleteRoute{..} = do + targets <- runDB . mconcatForM drRecords $ \rKey -> do + ent <- Entity rKey <$> get404 rKey + recordWdgt <- drRenderRecord ent + recordConfirmString <- drRecordConfirmString ent + return $ pure (recordWdgt, recordConfirmString) + + cIDKey <- hash . (ByteArray.convert :: Digest (SHAKE128 64) -> ByteString) . Crypto.hash <$> getsYesod appCryptoIDKey + + let sTargets = evalRand (shuffleM targets) . mkStdGen . hashWithSalt cIDKey $ Set.toList drRecords + confirmString = Text.unlines $ map (Text.strip . view _2) sTargets + confirmField + | Set.size drRecords <= 1 = textField + | otherwise = convertField unTextarea Textarea textareaField + + ((deleteFormRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost . identForm FIDDelete . renderAForm FormStandard $ (,) + <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing + <*> combinedButtonFieldF "" + + formResult deleteFormRes $ \case + (_, catMaybes -> [BtnAbort]) -> + redirect drAbort + (inpConfirmStr, catMaybes -> [BtnDelete]) + | ((==) `on` map CI.mk . Text.words) confirmString inpConfirmStr + -> do + runDB $ do + forM_ drRecords deleteCascade + addMessageI Success drSuccessMessage + redirect drSuccess + | otherwise + -> addMessageI Error MsgDeleteConfirmationWrong + _other -> return () + + Just targetRoute <- getCurrentRoute + + defaultLayout + $(widgetFile "widgets/delete-confirmation") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index bbb8d157c..57d0d223a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -56,6 +56,9 @@ import Data.Aeson.Text (encodeToLazyText) data BtnDelete = BtnDelete | BtnAbort deriving (Enum, Eq, Ord, Bounded, Read, Show) +instance Universe BtnDelete +instance Finite BtnDelete + instance PathPiece BtnDelete where -- for displaying the button only, not really for paths toPathPiece = showToPathPiece fromPathPiece = readFromPathPiece diff --git a/src/Utils.hs b/src/Utils.hs index 7c99ca13c..045d4d19c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -498,6 +498,12 @@ partitionM crit = ofoldlM dist mempty | okay -> acc `mappend` (opoint x, mempty) | otherwise -> acc `mappend` (mempty, opoint x) +mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b +mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList + +mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b +mconcatForM = flip mconcatMapM + -------------- -- Sessions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 921c82ec5..6f2b9b078 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -172,6 +172,7 @@ data FormIdentifier | FIDSystemMessageAddTranslation | FIDDBTableFilter | FIDDBTablePagesize + | FIDDelete deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where @@ -230,13 +231,30 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype} | otherwise = return $ Left "Wrong button value" fieldParse _ _ = return $ Left "Multiple button values" -combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a] -combinedButtonField = traverse b2f - where - b2f b = aopt (buttonField b) "" Nothing +combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> FieldSettings site -> AForm (HandlerT site IO) [Maybe a] +combinedButtonField bs FieldSettings{..} = formToAForm $ do + mr <- getMessageRender + fvId <- maybe newIdent return fsId + name <- maybe newIdent return fsName + (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b + , fsName = Just $ name <> "__" <> toPathPiece b + }) Nothing + return ( sequenceA ress + , pure FieldView + { fvLabel = toHtml $ mr fsLabel + , fvTooltip = fmap (toHtml . mr) fsTooltip + , fvId + , fvInput = foldMap fvInput fvs + , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs + , fvRequired = False + } + ) + +combinedButtonFieldF :: forall site a. (Button site a, Show (ButtonCssClass site), Finite a) => FieldSettings site -> AForm (HandlerT site IO) [Maybe a] +combinedButtonFieldF = combinedButtonField (universeF :: [a]) submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () -submitButton = void $ combinedButtonField [BtnSubmit] +submitButton = void $ combinedButtonField [BtnSubmit] "" autosubmitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) () autosubmitButton = void $ aopt (buttonField BtnSubmit) ("" & addAutosubmit) Nothing diff --git a/templates/widgets/delete-confirmation.hamlet b/templates/widgets/delete-confirmation.hamlet new file mode 100644 index 000000000..7f2e070b0 --- /dev/null +++ b/templates/widgets/delete-confirmation.hamlet @@ -0,0 +1,13 @@ +

_{drCaption} +

    + $forall (wdgt, _) <- sTargets +
  • + ^{wdgt} + +

    _{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)} + +

    + #{confirmString} + +

    + ^{deleteFormWdgt} diff --git a/templates/widgets/delete-confirmation.lucius b/templates/widgets/delete-confirmation.lucius new file mode 100644 index 000000000..daf5e5d29 --- /dev/null +++ b/templates/widgets/delete-confirmation.lucius @@ -0,0 +1,5 @@ +.confirmationText { + white-space: pre-wrap; + font-size: 14px; + font-family: monospace; +} From 38dbc0905cbacdbe87ffe40a8c4510606879f4fc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Dec 2018 22:31:09 +0100 Subject: [PATCH 8/8] Single-submission deletion --- messages/uniworx/de.msg | 4 ++++ routes | 3 ++- src/Foundation.hs | 18 +++++++++++++++++ src/Handler/Submission.hs | 34 +++++++++++++++++++++++++++++++++ src/Handler/Utils/Delete.hs | 4 +++- templates/default-layout.lucius | 1 + 6 files changed, 62 insertions(+), 2 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index fd07e0ad8..247b2a780 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -144,6 +144,9 @@ SubmissionFile: Datei zur Abgabe SubmissionFiles: Abgegebene Dateien SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt. +SubmissionsDeleteQuestion count@Int: Wollen Sie #{pluralDE count "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen? +SubmissionsDeleted count@Int: #{pluralDE count "Abgabe gelöscht" "Abgaben gelöscht"} + SubmissionGroupName: Gruppenname CorrectionsTitle: Zugewiesene Korrekturen @@ -536,6 +539,7 @@ MenuLogout: Logout MenuCourseList: Kurse MenuTermShow: Semester MenuCorrection: Korrektur +MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten diff --git a/routes b/routes index c2a320731..f29cc077b 100644 --- a/routes +++ b/routes @@ -79,8 +79,9 @@ !/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions !/subs/own SubmissionOwnR GET !free -- just redirect /subs/#CryptoFileNameSubmission SubmissionR: - / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread + / SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector + /delete SubDelR GET POST !ownerANDtime /assign SAssignR GET POST !lecturerANDtime /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector diff --git a/src/Foundation.hs b/src/Foundation.hs index 9ec2efe26..b63830a54 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1310,6 +1310,24 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = , menuItemModal = True , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSubmissionDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] +pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = + [ MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuSubmissionDelete + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR + , menuItemModal = False + , menuItemAccessCallback' = return True + } ] pageActions (CSheetR tid ssh csh shn SCorrR) = [ MenuItem diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index d3641e34c..8357e4023 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -7,6 +7,7 @@ import Jobs -- import Yesod.Form.Bootstrap3 import Handler.Utils +import Handler.Utils.Delete import Handler.Utils.Submission import Handler.Utils.Table.Cells @@ -19,6 +20,7 @@ import Network.Mime import Data.Monoid (Any(..)) import Data.Maybe (fromJust) -- import qualified Data.Maybe +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.CaseInsensitive (CI) @@ -390,3 +392,35 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do zipComment = Text.encodeUtf8 $ toPathPiece cID fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder + +getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getSubDelR = postSubDelR +postSubDelR tid ssh csh shn cID = do + subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID + deleteR DeleteRoute + { drRecords = Set.singleton subId + , drRenderRecord = \(Entity subId' Submission{submissionSheet}) -> do + Sheet{sheetName, sheetCourse} <- getJust submissionSheet + Course{courseName, courseSchool, courseTerm} <- getJust sheetCourse + School{schoolName} <- getJust courseSchool + subUsers <- selectList [SubmissionUserSubmission ==. subId'] [] + subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser + return [whamlet| + $newline never +
      + $forall (dName, sName) <- subNames +
    • ^{nameWidget dName sName} +  (_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}, #{sheetName}) + |] + , drRecordConfirmString = \(Entity subId' Submission{submissionSheet}) -> do + Sheet{sheetName, sheetCourse} <- getJust submissionSheet + Course{courseShorthand, courseSchool, courseTerm} <- getJust sheetCourse + subUsers <- selectList [SubmissionUserSubmission ==. subId'] [] + subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser + let subNames' = Text.intercalate ", " subNames + return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}/#{subNames'}|] + , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1 + , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1 + , drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR + , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR + } diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 68cdb13d9..756fc5da9 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -21,6 +21,8 @@ import Crypto.Hash (Digest, SHAKE128) import qualified Data.ByteArray as ByteArray +import Data.Char (isAlphaNum) + data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute { drRecords :: Set (Key record) @@ -57,7 +59,7 @@ deleteR DeleteRoute{..} = do (_, catMaybes -> [BtnAbort]) -> redirect drAbort (inpConfirmStr, catMaybes -> [BtnDelete]) - | ((==) `on` map CI.mk . Text.words) confirmString inpConfirmStr + | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr -> do runDB $ do forM_ drRecords deleteCascade diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 8deb58679..8e8568687 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -439,6 +439,7 @@ input[type="button"].btn-info:hover, } .list--inline { + display: inline-block; margin-left: 0; li {