From 5de5c75b65a60faf079e9604807ffc2bc8dd5c44 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Feb 2016 23:03:28 +0000 Subject: Include jobs in printer table --- webgui/src/Main.hs | 48 ++++++++++++++++++++++++++++++++---------------- 1 file changed, 32 insertions(+), 16 deletions(-) (limited to 'webgui/src') diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index dbf34bc..644c4f6 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -29,6 +29,8 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Sequence (Seq) import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set import Data.Default.Class @@ -105,10 +107,14 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do onEvent socketErr handleSocketErr getElementById window "javascriptError" >>= maybeM delete + + (focusedJobs, changeFocusedJobs) <- stepper' Set.empty + let modifyFocusedJobs f = changeFocusedJobs . f =<< currentValue focusedJobs + fJobs = (focusedJobs, liftIO . modifyFocusedJobs) - selectedPrinter <- handleJobTable + selectedPrinter <- handleJobTable fJobs - changeEditorStatus <- handleEditor selectedPrinter + changeEditorStatus <- handleEditor selectedPrinter fJobs handleDraftTable changeEditorStatus @@ -143,7 +149,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server - handleEditor selectedPrinter = do + handleEditor selectedPrinter (_, modifyFocusedJobs) = do title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" text <- fatal' "Could not find editor text field" =<< getElementById window "editorText" status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus" @@ -205,13 +211,15 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do discardAction = modifyStatus $ const def printAction = do EditorState{..} <- currentValue editorStatus + let + reFocusJob jId = modifyFocusedJobs (const $ Set.singleton jId) case ePrintout of Right po -> case associatedDraft of Just dId -> do saved <- saveAction False - when saved $ runFunction . focusJob =<< draftPrint dId =<< currentValue selectedPrinter + when saved $ reFocusJob =<< draftPrint dId =<< currentValue selectedPrinter Nothing -> do - runFunction . focusJob =<< flip jobCreate po =<< currentValue selectedPrinter + reFocusJob =<< 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) @@ -295,10 +303,10 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do concernsPrinters :: URI -> Bool concernsPrinters (uriPath -> p) | p == "printers" = True - | "jobs/" `isPrefixOf` p = True + | p == "jobs" = True | otherwise = False - handleJobTable = do + handleJobTable (focusedJobs, _) = do allowAbortion <- do allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) @@ -320,12 +328,19 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)] getJobState pId = toList <$> jobs (Just pId) Nothing Nothing mangleTuple (a, (b, c)) = (a, b, c) - thrd (_, _, c) = 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 + where + compare' :: Ord a => a -> a -> Ordering + compare' + | (Queued _) <- status = compare + | otherwise = flip compare -- toTable :: [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] -> UI [Element] toTable = fmap concat . mapM toSubTable -- toSubTable :: (PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)]) -> UI [Element] - toSubTable (rPId@(PrinterId pId), pStatus, (sortBy (queueSort `F.on` thrd) -> jobs)) = do + toSubTable (rPId@(PrinterId pId), pStatus, (sortBy jobSort -> jobs)) = do pId' <- UI.td # set UI.text (show pId) pStatus' <- UI.td # set UI.text (show pStatus) let selectId = "printer" ++ show pId @@ -336,13 +351,18 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do pSelect' <- UI.td # set children [pSelect, pSelectL] pFiller <- UI.td # set UI.colspan 2 let - toLine ((JobId jId), time, status) = do + toLine (rJId@(JobId jId), time, status) = do jPId <- UI.td 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" - actions <- UI.td # set children [abortButton] - UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', jStatus', actions] + on UI.click abortButton . const $ jobDelete rJId + let abortButton' = case status of + Queued _ -> [abortButton] + _ -> [] + actions <- UI.td # set children abortButton' + 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 update <- do @@ -361,10 +381,6 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do return selectedPrinter - -focusJob :: JobId -> JSFunction () -focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME - switchTab :: String -> JSFunction () switchTab = ffi "$(%1).first().trigger(\"click\")" . (\p -> "a[href='#" ++ p ++ "']") -- cgit v1.2.3