From 037c0cce20da51a476354b141b8d7c4f44abec80 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 16 Mar 2018 18:52:32 +0100 Subject: [PATCH] Sheet editing working, except for files --- messages/de.msg | 5 +- src/Handler/Sheet.hs | 79 +++++++++++++++++-- src/Model/Types.hs | 2 +- .../{sheetList.hamlet => sheetShow.hamlet} | 3 +- 4 files changed, 79 insertions(+), 10 deletions(-) rename templates/{sheetList.hamlet => sheetShow.hamlet} (92%) diff --git a/messages/de.msg b/messages/de.msg index 57e1f2f08..85bc563f2 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -8,4 +8,7 @@ CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText ti CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. SheetNewOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt. -SheetNewDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt! +SheetTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName} +SheetEditOk tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{termToText tid}-#{courseShortHand} wurde bearbeitet. +SheetNameDup tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{termToText tid}-#{courseShortHand}. + diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6b3ac63fd..4b7560ac9 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -6,11 +6,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Handler.Sheet where import Import -import System.FilePath +import System.FilePath (takeFileName) import Handler.Utils import Handler.Utils.Zip @@ -30,6 +31,9 @@ import qualified Database.Esqueleto as E import Network.Mime +instance Eq (Unique Sheet) where + (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = + cid1 == cid2 && name1 == name2 {- * Implement Handlers @@ -175,7 +179,7 @@ getSheetShowR tid csh shn = do defaultLayout $ do setTitle $ toHtml $ T.append "Übung " $ sheetName sheet - $(widgetFile "sheetList") + $(widgetFile "sheetShow") [whamlet| Under Construction !!! |] -- TODO @@ -214,7 +218,7 @@ getSheetNewR tid csh = do case res of (FormSuccess SheetForm{..}) -> do actTime <- liftIO getCurrentTime - let sheet = Sheet + let newSheet = Sheet { sheetCourseId = cid , sheetName = sfName , sheetDescription = sfDescription @@ -232,9 +236,9 @@ getSheetNewR tid csh = do , sheetChangedBy = aid } saveOkay <- runDB $ do - insertOkay <- insertUnique sheet + insertOkay <- insertUnique newSheet case insertOkay of - Nothing -> insertOkay <$ addMessageI "danger" (MsgSheetNewDup tident csh sfName) + Nothing -> insertOkay <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName) (Just sid) -> do -- Save Files in DB: whenIsJust sfSheetF $ insertSheetFile sid SheetExercise @@ -249,16 +253,77 @@ getSheetNewR tid csh = do let actionUrl = SheetNewR tid csh -- actionUrl <- getCurrentRoute defaultLayout $ do + setTitleI $ MsgSheetTitle tident csh "NEW" $(widgetFile "formPage") postSheetNewR :: TermId -> Text -> Handler Html postSheetNewR = getSheetNewR getSheetEditR :: TermId -> Text -> SheetId -> Handler Html -getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +getSheetEditR tid csh sid = do + let tident = unTermKey tid + aid <- requireAuthId + sheet@(Sheet {..}) <- runDB $ get404 sid + let template = Just $ SheetForm + { sfName = sheetName + , sfDescription = sheetDescription + , sfType = sheetType + , sfGrouping = sheetGrouping + , sfMarkingText = sheetMarkingText + , sfVisibleFrom = sheetVisibleFrom + , sfActiveFrom = sheetActiveFrom + , sfActiveTo = sheetActiveTo + , sfSheetF = Nothing -- TODO + , sfHintFrom = sheetHintFrom + , sfHintF = Nothing -- TODO + , sfSolutionFrom = sheetSolutionFrom + , sfSolutionF = Nothing -- TODO + } + ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm sheetCourseId template + case res of + (FormSuccess SheetForm{..}) -> do + actTime <- liftIO getCurrentTime + let newSheet = Sheet + { sheetCourseId = sheetCourseId -- Bad puns? + , sheetName = sfName + , sheetDescription = sfDescription + , sheetType = sfType + , sheetGrouping = sfGrouping + , sheetMarkingText = sfMarkingText + , sheetVisibleFrom = sfVisibleFrom + , sheetActiveFrom = sfActiveFrom + , sheetActiveTo = sfActiveTo + , sheetHintFrom = sfHintFrom + , sheetSolutionFrom = sfSolutionFrom + , sheetCreated = sheetCreated -- Bad puns? + , sheetChanged = actTime + , sheetCreatedBy = sheetChangedBy -- Bad puns? + , sheetChangedBy = aid + } + saveOkay <- runDB $ do + addMessage "debug" "Attempting update!" + insertOkay <- myReplaceUnique sid newSheet + case insertOkay of + (Just _) -> insertOkay <$ addMessageI "danger" (MsgSheetNameDup tident csh sfName) + Nothing -> do + -- Save Files in DB: + whenIsJust sfSheetF $ insertSheetFile sid SheetExercise + whenIsJust sfHintF $ insertSheetFile sid SheetHint + whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution + addMessageI "info" $ MsgSheetEditOk tident csh sfName + return insertOkay + when (isJust saveOkay) $ redirect $ SheetShowR tid csh sfName + (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml + _ -> return () + let formTitle = "Übungsblatt bearbeiten" :: Text + let actionUrl = SheetEditR tid csh sid + -- actionUrl <- getCurrentRoute + defaultLayout $ do + setTitleI $ MsgSheetTitle tident csh sheetName + $(widgetFile "formPage") postSheetEditR :: TermId -> Text -> SheetId -> Handler Html -postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +postSheetEditR = getSheetEditR getSheetDelR :: TermId -> Text -> SheetId -> Handler Html diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 68b30d6c9..ba6e72a01 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -43,7 +43,7 @@ toPoints :: Integral a => a -> Points toPoints = MkFixed . fromIntegral fromPoints :: Integral a => Points -> a -fromPoints = error "TODO: Types.fromPoints not yet implemented" +fromPoints (MkFixed c) = fromInteger c data SheetType = Bonus { maxPoints :: Points } diff --git a/templates/sheetList.hamlet b/templates/sheetShow.hamlet similarity index 92% rename from templates/sheetList.hamlet rename to templates/sheetShow.hamlet index b04c1f0c6..ddcb31600 100644 --- a/templates/sheetList.hamlet +++ b/templates/sheetShow.hamlet @@ -30,7 +30,8 @@
  • $case fileLink $of SheetFileR _ _ _ typ name - #{toPathPiece typ} #{name} + #{toPathPiece typ} + #{name} $of other @{fileLink}