From 022a5a69dfcfc7b62a940d9c3070e6ae37cc993e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 26 Feb 2016 19:11:56 +0000 Subject: Switched to bulk deletion/abortion --- webgui/src/Main.hs | 121 +++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 86 insertions(+), 35 deletions(-) (limited to 'webgui/src') diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index 018e59b..a295fd9 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -21,6 +21,7 @@ import System.Environment import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy.Char8 as CLBS import Data.Text (Text) import qualified Data.Text as T @@ -102,6 +103,13 @@ config = do hostEnv = "ADDR" portEnv = "PORT" +fatal :: String -> UI a +fatal str = do + window <- askWindow + (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"] + liftIO (throwIO $ ErrorCall str) + return undefined + setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI () setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do onEvent socketErr handleSocketErr @@ -130,11 +138,6 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do errors #+ [UI.li # set TP.text str] errorsTab # set style [("display", "inline-block")] runFunction $ switchTab "errors" - fatal :: String -> UI a - fatal str = do - (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"] - liftIO (throwIO $ ErrorCall str) - return undefined maybeM = maybe $ return () @@ -147,7 +150,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do status <- stepper init statusEvent return (status, triggerStatusChange) - Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server + Client{..} = mkClient (hoistNat $ Nat liftIO) server + withFatal :: EitherT ServantError UI a -> UI a + withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runEitherT a handleEditor selectedPrinter (_, modifyFocusedJobs) = do title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" @@ -189,8 +194,8 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do return False Right p -> do draftId <- case associatedDraft of - Nothing -> draftCreate (T.pack <$> eTitle) p - Just i -> i <$ when (different s) (draftReplace i (T.pack <$> eTitle) p) + Nothing -> withFatal $ draftCreate (T.pack <$> eTitle) p + Just i -> i <$ when (different s) (withFatal $ draftReplace i (T.pack <$> eTitle) p) time <- liftIO getCurrentTime modifyStatus (\x -> x { associatedDraft = Just draftId, lastSaved = Just (time, s) }) return True @@ -217,9 +222,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do Right po -> case associatedDraft of Just dId -> do saved <- saveAction False - when saved $ reFocusJob =<< draftPrint dId =<< currentValue selectedPrinter + when saved $ reFocusJob =<< withFatal . draftPrint dId =<< currentValue selectedPrinter Nothing -> do - reFocusJob =<< flip jobCreate po =<< currentValue selectedPrinter + reFocusJob =<< withFatal . flip jobCreate po =<< currentValue selectedPrinter Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err onEvent (whenE saveDraft $ tick autoSaveTimer) (const . void $ saveAction True) @@ -243,28 +248,52 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do discardable EditorState{..} = not (maybe True null eTitle && null eText) handleDraftTable changeEditorState = do - allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" - deletion' <- allowDeletion # get UI.checked + -- allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion" + -- deletion' <- allowDeletion # get UI.checked + + -- deletion <- stepper deletion' $ UI.checkedChange allowDeletion + (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty - deletion <- stepper deletion' $ UI.checkedChange allowDeletion + + enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion" + on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runEitherT . draftDelete) >> updateMarking Set.empty + -- deletion' <- allowDeletion # get UI.checked let + updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking + where mangle = Set.fromList . map DraftId . fromMaybe [] . parse + getChecked = "$.makeArray($('input[name=draftMark]:checked').map(function() {return $(this).val()}))" + parse str + | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs + | r@([_]) <- [ i | (i, "") <- reads str ] = Just r + | otherwise = Nothing + toTable :: Map DraftId (Maybe DraftTitle) -> UI [Element] toTable = mapM toLine . Map.toList toLine (id@(DraftId (show -> tId)), fromMaybe "" . fmap T.unpack -> title) = do id' <- UI.td # set TP.text tId title' <- UI.td # set TP.text title - delete <- UI.button - # set TP.text "Delete" - # sink UI.enabled deletion - on UI.click delete . const $ draftDelete id >> changeEditorState (\s@(EditorState{..}) -> if associatedDraft == Just id then def else s) + mark <- UI.input + # set UI.type_ "checkbox" + # set UI.name "draftMark" + # set UI.id_ ("draftMark" ++ tId) + # set UI.value tId + # sink UI.checked (Set.member id <$> marking) + on UI.checkedChange mark . const $ updateMarking' + mark' <- UI.span #+ [ return mark + , UI.label # set UI.for ("draftMark" ++ tId) # set UI.text "Mark" + ] # set UI.class_ "mark" + -- delete <- UI.button + -- # set TP.text "Delete" + -- # sink UI.enabled deletion + -- on UI.click delete . const $ draftDelete id >> changeEditorState (\s@(EditorState{..}) -> if associatedDraft == Just id then def else s) load <- UI.button # set TP.text "Load" on UI.click load . const $ loadDraft id - actions <- UI.td # set children [load, delete] + actions <- UI.td # set children [mark', load] UI.tr # set children [id', title', actions] loadDraft id = do - (title, po) <- draft id + (title, po) <- withFatal $ draft id let t = cobbcode po case t of @@ -281,7 +310,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do changeEditorState (const newState) runFunction $ switchTab "editor" table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody" - initialContent <- toTable =<< drafts + initialContent <- toTable =<< withFatal drafts return table # set children initialContent update <- do @@ -292,7 +321,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do -- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer) return $ filterE concernsDrafts dataUpdate - onEvent update . const $ drafts >>= toTable >>= (\c -> return table # set children c) + onEvent update . const $ withFatal drafts >>= toTable >>= (\c -> return table # set children c) concernsDrafts :: URI -> Bool concernsDrafts (uriPath -> p) @@ -307,10 +336,14 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | otherwise = False handleJobTable (focusedJobs, _) = do - allowAbortion <- do - allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" - flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) - + -- allowAbortion <- do + -- allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" + -- flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) + (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty + + enactAbortion <- fatal' "Could not find deletion button" =<< getElementById window "enactAbortion" + on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runEitherT . jobDelete) >> updateMarking Set.empty + (selectedPrinter, updatePrinter) <- do autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter" (selectedPrinter, printerSelect) <- stepper' Nothing @@ -323,14 +356,22 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do return (selectedPrinter, updatePrinterSelect) let + updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking + where mangle = Set.fromList . map JobId . fromMaybe [] . parse + getChecked = "$.makeArray($('input[name=jobMark]:checked').map(function() {return $(this).val()}))" + parse str + | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs + | r@([_]) <- [ i | (i, "") <- reads str ] = Just r + | otherwise = Nothing + -- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] - getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< printers) + getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< withFatal printers) -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)] - getJobState pId = toList <$> jobs (Just pId) Nothing Nothing + getJobState pId = toList <$> withFatal (jobs (Just pId) Nothing Nothing) mangleTuple (a, (b, c)) = (a, b, c) -- jobSort :: (JobId, UTCTime, JobStatus) -> (JobId, UTCTime, JobStatus) -> Ordering - jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id' id + jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id id' where compare' :: Ord a => a -> a -> Ordering compare' @@ -356,15 +397,25 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do jId' <- UI.td # set UI.text (show jId) jStatus' <- UI.td # set UI.text (show status) time' <- UI.td # set UI.text (formatTime defaultTimeLocale "%F %X" time) - abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort" - on UI.click abortButton . const $ jobDelete rJId - let abortButton' = case status of - Queued _ -> [abortButton] + mark <- UI.input + # set UI.type_ "checkbox" + # set UI.name "jobMark" + # set UI.id_ ("jobMark" ++ show jId) + # set UI.value (show jId) + # sink UI.checked (Set.member rJId <$> marking) + on UI.checkedChange mark . const $ updateMarking' + mark' <- UI.span #+ [ return mark + , UI.label # set UI.for ("jobMark" ++ show jId) # set UI.text "Mark" + ] # set UI.class_ "mark" + -- abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort" + -- on UI.click abortButton . const $ jobDelete rJId + let mark'' = case status of + (Queued _) -> [mark'] _ -> [] viewJob = do tabLinkList <- fatal' "Could not find tab link list" =<< getElementById window "tabLinks" tabContainer <- fatal' "Could not find tab container" =<< getElementById window "tabContent" - content <- job rJId + content <- withFatal $ job rJId let text = cobbcode content case text of @@ -381,9 +432,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do runFunction . switchTab $ "viewJob" ++ show jId viewButton <- UI.button # set UI.text "View" on UI.click viewButton . const $ viewJob - actions <- UI.td # set children (viewButton : abortButton') + actions <- UI.td # set children (mark'' ++ [viewButton]) UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', time', jStatus', actions] # sink UI.class_ (bool "" "focused" . Set.member rJId <$> focusedJobs) - (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs + (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] # set UI.class_ "printer" <*> mapM toLine jobs update <- do -- recheckTimer <- timer -- cgit v1.2.3