diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index a13812838..1f391452a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -142,8 +142,8 @@ SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt 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}. +SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wurde gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +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? 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. SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}! @@ -220,8 +220,10 @@ MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist MaterialFiles: Dateien MaterialNewHeading: Neues Material veröffentlichen MaterialNewTitle: Neues Material -MaterialEditHeading name@Text: Material "#{name}" editieren -MaterialEditTitle name@Text: Material "#{name}" editieren +MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren +MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren +MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{display tid}-#{display ssh}-#{csh} +MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{display tid}-#{display ssh}-#{csh} Unauthorized: Sie haben hierfür keine explizite Berechtigung. diff --git a/models/materials b/models/materials index d715abc63..062ab3232 100644 --- a/models/materials +++ b/models/materials @@ -6,6 +6,7 @@ Material -- course material for disemination to course participants visibleFrom UTCTime Maybe -- Invisible to enrolled participants before lastEdit UTCTime UniqueMaterial course name + deriving Generic MaterialFile -- a file that is part of a material distribution material MaterialId file FileId \ No newline at end of file diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 754672053..fd484d8ec 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -5,7 +5,7 @@ import Import import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Conduit.List as C -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E @@ -86,9 +86,9 @@ postMEditR tid ssh csh mnm = do , mfVisibleFrom = materialVisibleFrom , mfFiles = Just $ yieldMany files } - editWidget <- handleMaterialEdit tid ssh csh template - let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading $ CI.original mnm - headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle $ CI.original mnm + editWidget <- handleMaterialEdit tid ssh csh cid template $ uniqueReplace mid + let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm + headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm siteLayoutMsg headingLong $ do setTitleI headingShort editWidget @@ -97,23 +97,50 @@ postMEditR tid ssh csh mnm = do getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialNewR = postMaterialNewR postMaterialNewR tid ssh csh = do - editWidget <- handleMaterialEdit tid ssh csh Nothing + Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle siteLayoutMsg headingLong $ do setTitleI headingShort editWidget -handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe MaterialForm -> Handler Widget -handleMaterialEdit tid ssh csh template = do - aid <- requireAuthId - Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template - actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute - return $ wrapForm formWidget def - { formAction = Just $ SomeRoute actionUrl - , formEncoding = formEnctype - } +handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget +handleMaterialEdit tid ssh csh cid template dbMaterial = do + ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template + formResult res saveMaterial + -- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute + return $ wrapForm formWidget def + { formAction = Nothing -- Just $ SomeRoute actionUrl + , formEncoding = formEnctype + } + where + saveMaterial :: MaterialForm -> Handler () + saveMaterial MaterialForm{..} = do + _aid <- requireAuthId + now <- liftIO getCurrentTime + let newMaterial = Material + { materialCourse = cid + , materialName = mfName + , materialType = mfType + , materialDescription = mfDescription + , materialVisibleFrom = mfVisibleFrom + , materialLastEdit = now + } + saveOk <- runDB $ do + mbmid <- dbMaterial newMaterial + case mbmid of + Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName) + (Just mid) -> do -- save files in DB + whenIsJust mfFiles $ insertMaterialFile' mid + addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName + -- more info/warnings could go here + return True + when saveOk $ redirect -- redirect must happen outside of runDB + $ CourseR tid ssh csh (MaterialR mfName MShowR) + + insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB () + insertMaterialFile' = error "TODO" getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index bd65e4d09..5f5dfe896 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -503,11 +503,7 @@ getSEditR tid ssh csh shn = do , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingText = sheetMarkingText } - let action newSheet = do - replaceRes <- myReplaceUnique sid $ newSheet - case replaceRes of - Nothing -> return $ Just sid - (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here + let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead handleSheetEdit tid ssh csh (Just sid) template action postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html diff --git a/src/Model.hs b/src/Model.hs index 7de0d7c1e..6198a2724 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,8 +33,9 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll $(persistDirectoryWith lowerCaseSettings "models") -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only -deriving instance Eq (Unique Course) -deriving instance Eq (Unique Sheet) +deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName +deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet +deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial -- Primary keys mentioned in dbtable row-keys must be Binary -- Automatically generated (i.e. numeric) ids are already taken care of diff --git a/src/Utils.hs b/src/Utils.hs index 3ac062bcf..2db129c24 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -405,6 +405,12 @@ toNothing = const Nothing toNothingS :: String -> Maybe b toNothingS = const Nothing +-- MOVED TO UTILS.DB due to cyclic dependency +-- Swap 'Nothing' for 'Just' and vice versa +-- flipMaybe :: b -> Maybe b -> Maybe b +-- flipMaybe x Nothing = Just x +-- flipMaybe _ (Just _) = Nothing + maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap maybeAdd (Just x) (Just y) = Just (x + y) maybeAdd Nothing y = y diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 9700dd88f..fbfcd7e8c 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -10,6 +10,16 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here + +-- | Swap 'Nothing' for 'Just' and vice versa +-- This belongs into Module 'Utils' but we have a weird cyclic +-- dependency +flipMaybe :: b -> Maybe a -> Maybe b +flipMaybe x Nothing = Just x +flipMaybe _ (Just _) = Nothing + + + emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) emptyOrIn criterion testSet @@ -41,7 +51,16 @@ updateBy uniq updates = do key <- getKeyBy uniq for_ key $ flip update updates -myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway) +-- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible, +-- and 'Just key' for the successfully replaced record +uniqueReplace :: (MonadIO m + ,Eq (Unique record) + ,PersistRecordBackend record backend + ,PersistUniqueWrite backend) + => Key record -> record -> ReaderT backend m (Maybe (Key record)) +uniqueReplace key datumNew = flipMaybe key <$> myReplaceUnique key datumNew + +myReplaceUnique -- | Identical to 'Database.Persist.Class', except for the better type signature (original requires Eq record which is not needed anyway) :: (MonadIO m ,Eq (Unique record) ,PersistRecordBackend record backend diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 0cd5d0335..082a90b33 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -572,7 +572,7 @@ formFailure errs' = do mr <- getMessageRender return . FormFailure $ map mr errs' - +-- | Turns errors into alerts, ignores missing forms and applies processing function formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m () formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x