Stubs expanded

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.

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