diff options
Diffstat (limited to 'server/src/Thermoprint/Server/API.hs')
-rw-r--r-- | server/src/Thermoprint/Server/API.hs | 22 |
1 files changed, 9 insertions, 13 deletions
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 9e28d58..66a594b 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs | |||
@@ -106,14 +106,10 @@ queue' = fmap force . liftIO . readTVarIO . queue | |||
106 | 106 | ||
107 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) | 107 | extractJobs :: (PrinterId, Queue) -> Seq (API.JobId, JobStatus) |
108 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' | 108 | -- ^ Get an API-compatible list of all jobs from a 'Printer' 'Queue' |
109 | extractJobs (pId, Queue pending current history) = mconcat [ fmap (, Queued pId) pending' | 109 | extractJobs (pId, Queue pending current history) = mconcat [ fmap ((, Queued pId) . castId) pending |
110 | , maybe Seq.empty Seq.singleton (fmap (, Printing pId) current') | 110 | , maybe Seq.empty Seq.singleton $ fmap ((, Printing pId) . castId) current |
111 | , fmap (second $ maybe Done Failed) history' | 111 | , fmap (bimap castId $ maybe Done Failed) history |
112 | ] | 112 | ] |
113 | where | ||
114 | pending' = fmap (castId' . unJobKey) pending | ||
115 | current' = fmap (castId' . unJobKey) current | ||
116 | history' = fmap (first $ castId' . unJobKey) history | ||
117 | 113 | ||
118 | listPrinters :: Handler (Map PrinterId PrinterStatus) | 114 | listPrinters :: Handler (Map PrinterId PrinterStatus) |
119 | listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) | 115 | listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) |
@@ -122,13 +118,13 @@ listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers | |||
122 | toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id | 118 | toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id |
123 | 119 | ||
124 | queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId | 120 | queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId |
125 | queueJob pId printout = lift . fmap (castId' . unJobKey) . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId | 121 | queueJob pId printout = lift . fmap castId . withReaderT sqlPool . addToQueue printout . snd =<< lookupPrinter pId |
126 | 122 | ||
127 | printerStatus :: PrinterId -> Handler PrinterStatus | 123 | printerStatus :: PrinterId -> Handler PrinterStatus |
128 | printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just | 124 | printerStatus = fmap queueToStatus . queue' . snd <=< lookupPrinter . Just |
129 | where | 125 | where |
130 | queueToStatus (Queue _ Nothing _) = Available | 126 | queueToStatus (Queue _ Nothing _) = Available |
131 | queueToStatus (Queue _ (Just id) _) = Busy . castId' $ unJobKey id | 127 | queueToStatus (Queue _ (Just id) _) = Busy $ castId id |
132 | 128 | ||
133 | listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus)) | 129 | listJobs :: Maybe PrinterId -> Maybe API.JobId -> Maybe API.JobId -> Handler (Seq (API.JobId, JobStatus)) |
134 | listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers) | 130 | listJobs Nothing minId maxId = fmap mconcat . mapM (\pId -> listJobs (Just pId) minId maxId) =<< asks (Map.keys . printers) |
@@ -137,7 +133,7 @@ listJobs pId minId maxId = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) | |||
137 | filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId) | 133 | filterJobs = Seq.filter (\(id, _) -> maybe True (< id) minId && maybe True (> id) maxId) |
138 | 134 | ||
139 | getJob :: API.JobId -> Handler Printout | 135 | getJob :: API.JobId -> Handler Printout |
140 | getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get . JobKey . SqlBackendKey $ castId jobId) =<< asks sqlPool | 136 | getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool |
141 | 137 | ||
142 | jobStatus :: API.JobId -> Handler JobStatus | 138 | jobStatus :: API.JobId -> Handler JobStatus |
143 | jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing | 139 | jobStatus jobId = maybe (left err404) return . lookup jobId . toList =<< listJobs Nothing Nothing Nothing |
@@ -147,10 +143,10 @@ deleteJob jobId = do | |||
147 | printerIds <- asks (Map.keys . printers) | 143 | printerIds <- asks (Map.keys . printers) |
148 | forM_ printerIds $ \pId -> do | 144 | forM_ printerIds $ \pId -> do |
149 | (pId', p) <- lookupPrinter $ Just pId | 145 | (pId', p) <- lookupPrinter $ Just pId |
150 | -- liftIO . atomically . modifyTVar' (queue p) $ force . removeNeedle | 146 | found <- liftIO . atomically $ do |
147 | current <- readTVar $ queue p | ||
148 | modifyTVar' (queue p) $ force . (\q@(Queue pending _ _) -> q { pending = Seq.filter (/= castId jobId) pending }) | ||
151 | undefined | 149 | undefined |
152 | where | ||
153 | needle = JobKey . SqlBackendKey $ castId jobId | ||
154 | 150 | ||
155 | listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle)) | 151 | listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle)) |
156 | listDrafts = return undefined | 152 | listDrafts = return undefined |