diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ca9cab2a8..a13812838 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -218,6 +218,10 @@ MaterialDescription: Beschreibung MaterialVisibleFrom: Sichtbar für Teilnehmer ab MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren MaterialFiles: Dateien +MaterialNewHeading: Neues Material veröffentlichen +MaterialNewTitle: Neues Material +MaterialEditHeading name@Text: Material "#{name}" editieren +MaterialEditTitle name@Text: Material "#{name}" editieren Unauthorized: Sie haben hierfür keine explizite Berechtigung. diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b644fe3f4..754672053 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -5,6 +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 Database.Esqueleto as E @@ -13,8 +14,8 @@ import Utils.Form import Handler.Utils -data MaterialForm = MaterialForm { - mfName :: MaterialName +data MaterialForm = MaterialForm + { mfName :: MaterialName , mfType :: Maybe Text , mfDescription :: Maybe Html , mfVisibleFrom :: Maybe UTCTime @@ -57,16 +58,63 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO -getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getMaterialNewR = postMaterialNewR -postMaterialNewR = error "unimplemented" -- TODO getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR = error "unimplemented" -- TODO -getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html +getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMEditR = postMEditR -postMEditR = error "unimplemented" -- TODO +postMEditR tid ssh csh mnm = do + (cid, Entity mid Material{..}, files) <- runDB $ do + [(E.Value cid, matEnt)] <- E.select . E.from $ -- uniqueness guaranteed + \(course `E.InnerJoin` material) -> do + E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. material E.^. MaterialName E.==. E.val mnm + return (course E.^. CourseId, material) + fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do + E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId + E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) + return $ file E.^. FileId + return (cid, matEnt, (Left . E.unValue) <$> fileIds) + let template = Just $ MaterialForm + { mfName = materialName + , mfType = materialType + , mfDescription = materialDescription + , 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 + siteLayoutMsg headingLong $ do + setTitleI headingShort + editWidget + + +getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getMaterialNewR = postMaterialNewR +postMaterialNewR tid ssh csh = do + editWidget <- handleMaterialEdit tid ssh csh Nothing + 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 + } + getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMDelR = postMDelR