From f515803694d7f8430b064f16a5a923b09ba70650 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 25 Feb 2016 18:04:49 +0100 Subject: Job/Printer list --- webgui/src/Main.hs | 114 +++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 98 insertions(+), 16 deletions(-) (limited to 'webgui/src/Main.hs') diff --git a/webgui/src/Main.hs b/webgui/src/Main.hs index cbb1a75..dbf34bc 100644 --- a/webgui/src/Main.hs +++ b/webgui/src/Main.hs @@ -39,14 +39,19 @@ import Control.Exception import Control.Monad.Catch import Control.Applicative -import Control.Monad +import Control.Monad hiding (sequence) import Data.Maybe import Data.Monoid import Text.Read hiding (get) import Data.Either -import Data.List (isPrefixOf) +import Data.List (isPrefixOf, sortBy) +import Data.Ord +import qualified Data.Function as F import Data.Bool +import Data.Traversable (sequence) +import Data.Foldable + import Paths_thermoprint_webgui import Debug.Trace @@ -100,8 +105,10 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do onEvent socketErr handleSocketErr getElementById window "javascriptError" >>= maybeM delete + + selectedPrinter <- handleJobTable - changeEditorStatus <- handleEditor + changeEditorStatus <- handleEditor selectedPrinter handleDraftTable changeEditorStatus @@ -136,7 +143,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 = do + handleEditor selectedPrinter = 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" @@ -202,9 +209,9 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do Right po -> case associatedDraft of Just dId -> do saved <- saveAction False - when saved $ runFunction . focusJob =<< draftPrint dId Nothing -- FIXME + when saved $ runFunction . focusJob =<< draftPrint dId =<< currentValue selectedPrinter Nothing -> do - runFunction . focusJob =<< jobCreate Nothing po -- FIXME + runFunction . focusJob =<< 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) @@ -214,6 +221,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do return discardButton # sink UI.enabled (discardable <$> editorStatus) return discardButton # sink UI.text (bool "Discard" "Save & Clear" <$> saveDraft) + return printButton # sink UI.text (maybe "Print" (\(PrinterId i) -> "Print on " ++ show i) <$> selectedPrinter) on (whenE saveDraft . UI.click) saveButton . const . void $ saveAction False on UI.click printButton $ const printAction @@ -268,17 +276,91 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do initialContent <- toTable =<< drafts return table # set children initialContent - recheckTimer <- timer - return recheckTimer # set interval 5000 - start recheckTimer + update <- do + -- recheckTimer <- timer + -- return recheckTimer # set interval 5000 + -- start recheckTimer + + -- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer) + return $ filterE concernsDrafts dataUpdate - onEvent (unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)) . const $ drafts >>= toTable >>= (\c -> return table # set children c) - where - concernsDrafts :: URI -> Bool - concernsDrafts (uriPath -> p) - | p == "drafts" = True - | "draft/" `isPrefixOf` p = True - | otherwise = False + onEvent update . const $ drafts >>= toTable >>= (\c -> return table # set children c) + + concernsDrafts :: URI -> Bool + concernsDrafts (uriPath -> p) + | p == "drafts" = True + | "draft/" `isPrefixOf` p = True + | otherwise = False + + concernsPrinters :: URI -> Bool + concernsPrinters (uriPath -> p) + | p == "printers" = True + | "jobs/" `isPrefixOf` p = True + | otherwise = False + + handleJobTable = do + allowAbortion <- do + allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" + flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) + + (selectedPrinter, updatePrinter) <- do + autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter" + (selectedPrinter, printerSelect) <- stepper' Nothing + return autoselectPrinter # sink UI.checked (isNothing <$> selectedPrinter) + let + -- getSelectedPrinter :: UI (Maybe PrinterId) + getSelectedPrinter = (fmap PrinterId . join . readMaybe) <$> callFunction (ffi "$('input[name=printer]:checked', '#printers').val()") + updatePrinterSelect = getSelectedPrinter >>= liftIO . printerSelect + on (domEvent "change") autoselectPrinter $ const updatePrinterSelect + return (selectedPrinter, updatePrinterSelect) + + let + -- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] + getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< printers) + -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)] + getJobState pId = toList <$> jobs (Just pId) Nothing Nothing + mangleTuple (a, (b, c)) = (a, b, c) + thrd (_, _, c) = c + + -- 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 + pId' <- UI.td # set UI.text (show pId) + pStatus' <- UI.td # set UI.text (show pStatus) + let selectId = "printer" ++ show pId + checked <- (== Just rPId) <$> currentValue selectedPrinter + pSelect <- UI.input # set UI.type_ "radio" # set UI.name "printer" # set UI.value (show $ Just pId) # set UI.id_ selectId # set UI.checked checked + on (domEvent "change") pSelect $ const updatePrinter + pSelectL <- UI.label # set UI.for selectId # set UI.text "Use for new jobs" + pSelect' <- UI.td # set children [pSelect, pSelectL] + pFiller <- UI.td # set UI.colspan 2 + let + toLine ((JobId jId), time, status) = do + jPId <- UI.td + jId' <- UI.td # set UI.text (show jId) + jStatus' <- UI.td # set UI.text (show status) + 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] + (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs + + update <- do + -- recheckTimer <- timer + -- return recheckTimer # set interval 5000 + -- start recheckTimer + + -- return $ unionWith const (() <$ filterE concernsPrinters dataUpdate) (tick recheckTimer) + return $ filterE concernsPrinters dataUpdate + + table <- fatal' "Could not find printer table" =<< getElementById window "printerListBody" + initialContent <- toTable =<< getServerState + return table # set children initialContent + + onEvent update . const $ getServerState >>= toTable >>= (\c -> return table # set children c) >> updatePrinter + + return selectedPrinter + focusJob :: JobId -> JSFunction () focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME -- cgit v1.2.3