Saving material mostly implemented

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.
+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}.
+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
+MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren
-MaterialEditTitle name@Text: Material "#{name}" 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.

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

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
+  editWidget <- handleMaterialEdit tid ssh csh cid template $ uniqueReplace mid
-  let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading $ CI.original mnm
+  let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
-      headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle   $ CI.original 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 :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
-handleMaterialEdit tid ssh csh template = do
+handleMaterialEdit tid ssh csh cid template dbMaterial = do
-  aid  <- requireAuthId
+    ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
-  Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+    formResult res saveMaterial
-  ((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
+    -- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
-  actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
+    return $ wrapForm formWidget def
-  return $ wrapForm formWidget def
+        { formAction   = Nothing -- Just $ SomeRoute actionUrl
-      { formAction = Just $ SomeRoute actionUrl
+        , formEncoding = formEnctype
-      , 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

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
+  let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
-        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
   handleSheetEdit tid ssh csh (Just sid) template action
 
 postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html

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 Course)    -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName
-deriving instance Eq (Unique Sheet)
+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

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

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

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