From 6831491b904403beb7fd3899b28e0deaa86d767d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 17 Jul 2016 21:19:52 +0200 Subject: safer deletion --- server/src/Thermoprint/Server/API.hs | 2 +- server/thermoprint-server.cabal | 2 +- webgui/src/Main.hs | 15 ++++++++++----- webgui/thermoprint-webgui.cabal | 2 +- 4 files changed, 13 insertions(+), 8 deletions(-) diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 8e17eb4..f7a8576 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -192,7 +192,7 @@ addDraft title content = do updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do - runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool + void . runSqlPool (updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer)) notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 37cf065..afb62db 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-server -version: 2.0.0 +version: 2.0.1 synopsis: Server for thermoprint-spec -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index 252e933..e4b25e6 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -123,9 +123,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do selectedPrinter <- handleJobTable fJobs - changeEditorStatus <- handleEditor selectedPrinter fJobs + (editorStatus, changeEditorStatus) <- handleEditor selectedPrinter fJobs - handleDraftTable changeEditorStatus + handleDraftTable (editorStatus, changeEditorStatus) where handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket" @@ -242,13 +242,13 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do on (whenE (not <$> saveDraft) . UI.click) discardButton $ const discardAction on (whenE saveDraft . UI.click) discardButton $ const clearAction - return modifyStatus + return (editorStatus, modifyStatus) saveable s@EditorState{..} = isRight ePrintout && discardable s printable EditorState{..} = isRight ePrintout && not (null eText) discardable EditorState{..} = not (maybe True null eTitle && null eText) - handleDraftTable changeEditorState = do + handleDraftTable (editorState, changeEditorState) = do -- allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" -- deletion' <- allowDeletion # get UI.checked @@ -257,7 +257,12 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" - on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runExceptT . draftDelete) >> updateMarking Set.empty + on UI.click enactDeletion . const $ do + cMarking <- currentValue marking + mapM_ (runExceptT . draftDelete) cMarking + cDraft <- associatedDraft <$> currentValue editorState + when (Set.member cDraft $ Set.map Just cMarking) $ changeEditorState (\s -> s { associatedDraft = Nothing } ) + updateMarking Set.empty -- deletion' <- allowDeletion # get UI.checked let updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking diff --git a/webgui/thermoprint-webgui.cabal b/webgui/thermoprint-webgui.cabal index 03aa9b2..25af096 100644 --- a/webgui/thermoprint-webgui.cabal +++ b/webgui/thermoprint-webgui.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: thermoprint-webgui -version: 1.0.0 +version: 1.0.1 synopsis: Threepenny interface for thermoprint-spec compliant servers -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html -- cgit v1.2.3