diff options
| -rw-r--r-- | webgui/src/Main.hs | 48 |
1 files changed, 32 insertions, 16 deletions
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) | |||
| 29 | import qualified Data.Map as Map | 29 | import qualified Data.Map as Map |
| 30 | import Data.Sequence (Seq) | 30 | import Data.Sequence (Seq) |
| 31 | import qualified Data.Sequence as Seq | 31 | import qualified Data.Sequence as Seq |
| 32 | import Data.Set (Set) | ||
| 33 | import qualified Data.Set as Set | ||
| 32 | 34 | ||
| 33 | import Data.Default.Class | 35 | import Data.Default.Class |
| 34 | 36 | ||
| @@ -105,10 +107,14 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 105 | onEvent socketErr handleSocketErr | 107 | onEvent socketErr handleSocketErr |
| 106 | 108 | ||
| 107 | getElementById window "javascriptError" >>= maybeM delete | 109 | getElementById window "javascriptError" >>= maybeM delete |
| 110 | |||
| 111 | (focusedJobs, changeFocusedJobs) <- stepper' Set.empty | ||
| 112 | let modifyFocusedJobs f = changeFocusedJobs . f =<< currentValue focusedJobs | ||
| 113 | fJobs = (focusedJobs, liftIO . modifyFocusedJobs) | ||
| 108 | 114 | ||
| 109 | selectedPrinter <- handleJobTable | 115 | selectedPrinter <- handleJobTable fJobs |
| 110 | 116 | ||
| 111 | changeEditorStatus <- handleEditor selectedPrinter | 117 | changeEditorStatus <- handleEditor selectedPrinter fJobs |
| 112 | 118 | ||
| 113 | handleDraftTable changeEditorStatus | 119 | handleDraftTable changeEditorStatus |
| 114 | 120 | ||
| @@ -143,7 +149,7 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 143 | 149 | ||
| 144 | Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server | 150 | Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server |
| 145 | 151 | ||
| 146 | handleEditor selectedPrinter = do | 152 | handleEditor selectedPrinter (_, modifyFocusedJobs) = do |
| 147 | title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" | 153 | title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle" |
| 148 | text <- fatal' "Could not find editor text field" =<< getElementById window "editorText" | 154 | text <- fatal' "Could not find editor text field" =<< getElementById window "editorText" |
| 149 | status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus" | 155 | status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus" |
| @@ -205,13 +211,15 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 205 | discardAction = modifyStatus $ const def | 211 | discardAction = modifyStatus $ const def |
| 206 | printAction = do | 212 | printAction = do |
| 207 | EditorState{..} <- currentValue editorStatus | 213 | EditorState{..} <- currentValue editorStatus |
| 214 | let | ||
| 215 | reFocusJob jId = modifyFocusedJobs (const $ Set.singleton jId) | ||
| 208 | case ePrintout of | 216 | case ePrintout of |
| 209 | Right po -> case associatedDraft of | 217 | Right po -> case associatedDraft of |
| 210 | Just dId -> do | 218 | Just dId -> do |
| 211 | saved <- saveAction False | 219 | saved <- saveAction False |
| 212 | when saved $ runFunction . focusJob =<< draftPrint dId =<< currentValue selectedPrinter | 220 | when saved $ reFocusJob =<< draftPrint dId =<< currentValue selectedPrinter |
| 213 | Nothing -> do | 221 | Nothing -> do |
| 214 | runFunction . focusJob =<< flip jobCreate po =<< currentValue selectedPrinter | 222 | reFocusJob =<< flip jobCreate po =<< currentValue selectedPrinter |
| 215 | Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err | 223 | Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err |
| 216 | 224 | ||
| 217 | onEvent (whenE saveDraft $ tick autoSaveTimer) (const . void $ saveAction True) | 225 | onEvent (whenE saveDraft $ tick autoSaveTimer) (const . void $ saveAction True) |
| @@ -295,10 +303,10 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 295 | concernsPrinters :: URI -> Bool | 303 | concernsPrinters :: URI -> Bool |
| 296 | concernsPrinters (uriPath -> p) | 304 | concernsPrinters (uriPath -> p) |
| 297 | | p == "printers" = True | 305 | | p == "printers" = True |
| 298 | | "jobs/" `isPrefixOf` p = True | 306 | | p == "jobs" = True |
| 299 | | otherwise = False | 307 | | otherwise = False |
| 300 | 308 | ||
| 301 | handleJobTable = do | 309 | handleJobTable (focusedJobs, _) = do |
| 302 | allowAbortion <- do | 310 | allowAbortion <- do |
| 303 | allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" | 311 | allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion" |
| 304 | flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) | 312 | flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked) |
| @@ -320,12 +328,19 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 320 | -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)] | 328 | -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)] |
| 321 | getJobState pId = toList <$> jobs (Just pId) Nothing Nothing | 329 | getJobState pId = toList <$> jobs (Just pId) Nothing Nothing |
| 322 | mangleTuple (a, (b, c)) = (a, b, c) | 330 | mangleTuple (a, (b, c)) = (a, b, c) |
| 323 | thrd (_, _, c) = c | 331 | |
| 332 | -- jobSort :: (JobId, UTCTime, JobStatus) -> (JobId, UTCTime, JobStatus) -> Ordering | ||
| 333 | jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id' id | ||
| 334 | where | ||
| 335 | compare' :: Ord a => a -> a -> Ordering | ||
| 336 | compare' | ||
| 337 | | (Queued _) <- status = compare | ||
| 338 | | otherwise = flip compare | ||
| 324 | 339 | ||
| 325 | -- toTable :: [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] -> UI [Element] | 340 | -- toTable :: [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] -> UI [Element] |
| 326 | toTable = fmap concat . mapM toSubTable | 341 | toTable = fmap concat . mapM toSubTable |
| 327 | -- toSubTable :: (PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)]) -> UI [Element] | 342 | -- toSubTable :: (PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)]) -> UI [Element] |
| 328 | toSubTable (rPId@(PrinterId pId), pStatus, (sortBy (queueSort `F.on` thrd) -> jobs)) = do | 343 | toSubTable (rPId@(PrinterId pId), pStatus, (sortBy jobSort -> jobs)) = do |
| 329 | pId' <- UI.td # set UI.text (show pId) | 344 | pId' <- UI.td # set UI.text (show pId) |
| 330 | pStatus' <- UI.td # set UI.text (show pStatus) | 345 | pStatus' <- UI.td # set UI.text (show pStatus) |
| 331 | let selectId = "printer" ++ show pId | 346 | let selectId = "printer" ++ show pId |
| @@ -336,13 +351,18 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 336 | pSelect' <- UI.td # set children [pSelect, pSelectL] | 351 | pSelect' <- UI.td # set children [pSelect, pSelectL] |
| 337 | pFiller <- UI.td # set UI.colspan 2 | 352 | pFiller <- UI.td # set UI.colspan 2 |
| 338 | let | 353 | let |
| 339 | toLine ((JobId jId), time, status) = do | 354 | toLine (rJId@(JobId jId), time, status) = do |
| 340 | jPId <- UI.td | 355 | jPId <- UI.td |
| 341 | jId' <- UI.td # set UI.text (show jId) | 356 | jId' <- UI.td # set UI.text (show jId) |
| 342 | jStatus' <- UI.td # set UI.text (show status) | 357 | jStatus' <- UI.td # set UI.text (show status) |
| 358 | time' <- UI.td # set UI.text (formatTime defaultTimeLocale "%F %X" time) | ||
| 343 | abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort" | 359 | abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort" |
| 344 | actions <- UI.td # set children [abortButton] | 360 | on UI.click abortButton . const $ jobDelete rJId |
| 345 | UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', jStatus', actions] | 361 | let abortButton' = case status of |
| 362 | Queued _ -> [abortButton] | ||
| 363 | _ -> [] | ||
| 364 | actions <- UI.td # set children abortButton' | ||
| 365 | UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', time', jStatus', actions] # sink UI.class_ (bool "" "focused" . Set.member rJId <$> focusedJobs) | ||
| 346 | (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs | 366 | (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs |
| 347 | 367 | ||
| 348 | update <- do | 368 | update <- do |
| @@ -361,10 +381,6 @@ setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do | |||
| 361 | 381 | ||
| 362 | return selectedPrinter | 382 | return selectedPrinter |
| 363 | 383 | ||
| 364 | |||
| 365 | focusJob :: JobId -> JSFunction () | ||
| 366 | focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME | ||
| 367 | |||
| 368 | switchTab :: String -> JSFunction () | 384 | switchTab :: String -> JSFunction () |
| 369 | switchTab = ffi "$(%1).first().trigger(\"click\")" . (\p -> "a[href='#" ++ p ++ "']") | 385 | switchTab = ffi "$(%1).first().trigger(\"click\")" . (\p -> "a[href='#" ++ p ++ "']") |
| 370 | 386 | ||
