diff options
| -rw-r--r-- | server/src/Thermoprint/Server/API.hs | 2 | ||||
| -rw-r--r-- | server/thermoprint-server.cabal | 2 | ||||
| -rw-r--r-- | webgui/src/Main.hs | 15 | ||||
| -rw-r--r-- | 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 | |||
| 192 | 192 | ||
| 193 | updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () | 193 | updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () |
| 194 | updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do | 194 | updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do |
| 195 | runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool | 195 | void . runSqlPool (updateGet (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool |
| 196 | $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer)) | 196 | $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer)) |
| 197 | notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId | 197 | notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId |
| 198 | 198 | ||
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 @@ | |||
| 2 | -- documentation, see http://haskell.org/cabal/users-guide/ | 2 | -- documentation, see http://haskell.org/cabal/users-guide/ |
| 3 | 3 | ||
| 4 | name: thermoprint-server | 4 | name: thermoprint-server |
| 5 | version: 2.0.0 | 5 | version: 2.0.1 |
| 6 | synopsis: Server for thermoprint-spec | 6 | synopsis: Server for thermoprint-spec |
| 7 | -- description: | 7 | -- description: |
| 8 | homepage: http://dirty-haskell.org/tags/thermoprint.html | 8 | 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 | |||
| 123 | 123 | ||
| 124 | selectedPrinter <- handleJobTable fJobs | 124 | selectedPrinter <- handleJobTable fJobs |
| 125 | 125 | ||
| 126 | changeEditorStatus <- handleEditor selectedPrinter fJobs | 126 | (editorStatus, changeEditorStatus) <- handleEditor selectedPrinter fJobs |
| 127 | 127 | ||
| 128 | handleDraftTable changeEditorStatus | 128 | handleDraftTable (editorStatus, changeEditorStatus) |
| 129 | 129 | ||
| 130 | where | 130 | where |
| 131 | handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket" | 131 | handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket" |
| @@ -242,13 +242,13 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 242 | on (whenE (not <$> saveDraft) . UI.click) discardButton $ const discardAction | 242 | on (whenE (not <$> saveDraft) . UI.click) discardButton $ const discardAction |
| 243 | on (whenE saveDraft . UI.click) discardButton $ const clearAction | 243 | on (whenE saveDraft . UI.click) discardButton $ const clearAction |
| 244 | 244 | ||
| 245 | return modifyStatus | 245 | return (editorStatus, modifyStatus) |
| 246 | 246 | ||
| 247 | saveable s@EditorState{..} = isRight ePrintout && discardable s | 247 | saveable s@EditorState{..} = isRight ePrintout && discardable s |
| 248 | printable EditorState{..} = isRight ePrintout && not (null eText) | 248 | printable EditorState{..} = isRight ePrintout && not (null eText) |
| 249 | discardable EditorState{..} = not (maybe True null eTitle && null eText) | 249 | discardable EditorState{..} = not (maybe True null eTitle && null eText) |
| 250 | 250 | ||
| 251 | handleDraftTable changeEditorState = do | 251 | handleDraftTable (editorState, changeEditorState) = do |
| 252 | -- allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" | 252 | -- allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" |
| 253 | -- deletion' <- allowDeletion # get UI.checked | 253 | -- deletion' <- allowDeletion # get UI.checked |
| 254 | 254 | ||
| @@ -257,7 +257,12 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 257 | 257 | ||
| 258 | 258 | ||
| 259 | enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" | 259 | enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" |
| 260 | on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runExceptT . draftDelete) >> updateMarking Set.empty | 260 | on UI.click enactDeletion . const $ do |
| 261 | cMarking <- currentValue marking | ||
| 262 | mapM_ (runExceptT . draftDelete) cMarking | ||
| 263 | cDraft <- associatedDraft <$> currentValue editorState | ||
| 264 | when (Set.member cDraft $ Set.map Just cMarking) $ changeEditorState (\s -> s { associatedDraft = Nothing } ) | ||
| 265 | updateMarking Set.empty | ||
| 261 | -- deletion' <- allowDeletion # get UI.checked | 266 | -- deletion' <- allowDeletion # get UI.checked |
| 262 | let | 267 | let |
| 263 | updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking | 268 | 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 @@ | |||
| 2 | -- documentation, see http://haskell.org/cabal/users-guide/ | 2 | -- documentation, see http://haskell.org/cabal/users-guide/ |
| 3 | 3 | ||
| 4 | name: thermoprint-webgui | 4 | name: thermoprint-webgui |
| 5 | version: 1.0.0 | 5 | version: 1.0.1 |
| 6 | synopsis: Threepenny interface for thermoprint-spec compliant servers | 6 | synopsis: Threepenny interface for thermoprint-spec compliant servers |
| 7 | -- description: | 7 | -- description: |
| 8 | homepage: http://dirty-haskell.org/tags/thermoprint.html | 8 | homepage: http://dirty-haskell.org/tags/thermoprint.html |
