aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Thermoprint')
-rw-r--r--server/src/Thermoprint/Server.hs14
-rw-r--r--server/src/Thermoprint/Server/API.hs33
-rw-r--r--server/src/Thermoprint/Server/Printer/Debug.hs2
-rw-r--r--server/src/Thermoprint/Server/Printer/Generic.hs4
-rw-r--r--server/src/Thermoprint/Server/Queue/Utils.hs2
5 files changed, 26 insertions, 29 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index 07462da..15fb651 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -13,7 +13,7 @@ module Thermoprint.Server
13 , Config(..), QMConfig(..) 13 , Config(..), QMConfig(..)
14 , withPrinters 14 , withPrinters
15 , module Data.Default.Class 15 , module Data.Default.Class
16 , module Servant.Server.Internal.Enter 16 , module Servant.Utils.Enter
17 , module Thermoprint.Server.Printer 17 , module Thermoprint.Server.Printer
18 , module Thermoprint.Server.Queue 18 , module Thermoprint.Server.Queue
19 , module Thermoprint.Server.Queue.Utils 19 , module Thermoprint.Server.Queue.Utils
@@ -62,7 +62,7 @@ import qualified Network.Wai.Handler.Warp as Warp
62import Network.Wai (Application) 62import Network.Wai (Application)
63 63
64import Servant.Server (serve) 64import Servant.Server (serve)
65import Servant.Server.Internal.Enter (enter, (:~>)(..)) 65import Servant.Utils.Enter (enter, (:~>)(..))
66import Servant.API 66import Servant.API
67import Servant.Utils.Links 67import Servant.Utils.Links
68import Network.URI 68import Network.URI
@@ -137,16 +137,16 @@ thermoprintServer :: ( MonadLoggerIO m
137 -> (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack. 137 -> (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify much of the rest of it (we handle 'ResourceT' ourselves, since we need it to fork properly). Therefore we require a specification of how to collapse the stack.
138 -> ResourceT m (Config (ResourceT m)) -> IO () 138 -> ResourceT m (Config (ResourceT m)) -> IO ()
139-- ^ Run the server 139-- ^ Run the server
140thermoprintServer dyre io = do 140thermoprintServer dyre io cfg = do
141 cfgDir <- lookupEnv "THERMOPRINT_CONFIG" 141 cfgDir <- lookupEnv "THERMOPRINT_CONFIG"
142 cacheDir <- lookupEnv "THERMOPRINT_CACHE" 142 cacheDir <- lookupEnv "THERMOPRINT_CACHE"
143 Dyre.wrapMain $ Dyre.defaultParams 143 flip Dyre.wrapMain cfg $ Dyre.defaultParams
144 { Dyre.projectName = "thermoprint-server" 144 { Dyre.projectName = "thermoprint-server"
145 , Dyre.realMain = realMain 145 , Dyre.realMain = realMain
146 , Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg })) 146 , Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
147 , Dyre.configCheck = dyre 147 , Dyre.configCheck = dyre
148 , Dyre.configDir = cfgDir 148 , Dyre.configDir = return <$> cfgDir
149 , Dyre.cacheDir = cacheDir 149 , Dyre.cacheDir = return <$> cacheDir
150 } 150 }
151 where 151 where
152 realMain cfg = unNat (io . Nat runResourceT) $ do 152 realMain cfg = unNat (io . Nat runResourceT) $ do
@@ -164,6 +164,6 @@ thermoprintServer dyre io = do
164 nChan <- liftIO $ newBroadcastTChanIO 164 nChan <- liftIO $ newBroadcastTChanIO
165 let 165 let
166 printerUrl :: API.PrinterId -> URI 166 printerUrl :: API.PrinterId -> URI
167 printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) 167 printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) . Just
168 mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers 168 mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers
169 liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan 169 liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan
diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index cbf727c..8e17eb4 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -27,15 +27,15 @@ import qualified Data.Map as Map
27 27
28import qualified Data.Text as T 28import qualified Data.Text as T
29 29
30import Servant 30import Servant hiding (Handler)
31import Servant.Server 31import Servant.Server hiding (Handler)
32import Servant.Server.Internal.Enter 32import Servant.Utils.Enter
33import Servant.Utils.Links 33import Servant.Utils.Links
34 34
35import Control.Monad.Logger 35import Control.Monad.Logger
36import Control.Monad.Reader 36import Control.Monad.Reader
37import Control.Monad.Trans.Resource 37import Control.Monad.Trans.Resource
38import Control.Monad.Trans.Either 38import Control.Monad.Except
39import Control.Monad.IO.Class 39import Control.Monad.IO.Class
40 40
41import Control.Concurrent.STM 41import Control.Concurrent.STM
@@ -65,7 +65,7 @@ import Control.Monad.Catch (handle, catch)
65import Data.Time 65import Data.Time
66 66
67type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO)) 67type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO))
68type Handler = EitherT ServantErr ProtoHandler 68type Handler = ExceptT ServantErr ProtoHandler
69 69
70-- ^ Runtime configuration of our handlers 70-- ^ Runtime configuration of our handlers
71data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage 71data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage
@@ -73,13 +73,10 @@ data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to intera
73 , nChan :: TChan Notification 73 , nChan :: TChan Notification
74 } 74 }
75 75
76instance MonadLogger m => MonadLogger (EitherT a m) where
77 monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl
78
79handlerNat :: ( MonadReader ConnectionPool m 76handlerNat :: ( MonadReader ConnectionPool m
80 , MonadLoggerIO m 77 , MonadLoggerIO m
81 ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> EitherT ServantErr IO) 78 ) => Map PrinterId Printer -> TChan Notification -> m (Handler :~> ExceptT ServantErr IO)
82-- ^ Servant requires its handlers to be 'EitherT ServantErr IO' 79-- ^ Servant requires its handlers to be 'ExceptT ServantErr IO'
83-- 80--
84-- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants 81-- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants
85handlerNat printerMap nChan = do 82handlerNat printerMap nChan = do
@@ -116,11 +113,11 @@ lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer)
116lookupPrinter pId = asks printers >>= maybePrinter' pId 113lookupPrinter pId = asks printers >>= maybePrinter' pId
117 where 114 where
118 maybePrinter' Nothing printerMap 115 maybePrinter' Nothing printerMap
119 | Map.null printerMap = left $ err501 { errBody = "No printers available" } 116 | Map.null printerMap = throwError $ err501 { errBody = "No printers available" }
120 | otherwise = return $ Map.findMin printerMap 117 | otherwise = return $ Map.findMin printerMap
121 maybePrinter' (Just pId) printerMap 118 maybePrinter' (Just pId) printerMap
122 | Just printer <- Map.lookup pId printerMap = return (pId, printer) 119 | Just printer <- Map.lookup pId printerMap = return (pId, printer)
123 | otherwise = left $ err404 { errBody = "No such printer" } 120 | otherwise = throwError $ err404 { errBody = "No such printer" }
124 121
125queue' :: MonadIO m => Printer -> m Queue 122queue' :: MonadIO m => Printer -> m Queue
126-- ^ Call 'queue' and handle concurrency 123-- ^ Call 'queue' and handle concurrency
@@ -160,10 +157,10 @@ listJobs pId idR timeR = fmap (filterJobs . extractJobs) . (\(a, b) -> (,) a
160 ) 157 )
161 158
162getJob :: API.JobId -> Handler Printout 159getJob :: API.JobId -> Handler Printout
163getJob jobId = fmap jobContent . maybe (left err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool 160getJob jobId = fmap jobContent . maybe (throwError err404) return =<< runSqlPool (get $ castId jobId) =<< asks sqlPool
164 161
165jobStatus :: API.JobId -> Handler JobStatus 162jobStatus :: API.JobId -> Handler JobStatus
166jobStatus jobId = maybe (left err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing 163jobStatus jobId = maybe (throwError err404) return . lookup jobId . map (\(id, _, st) -> (id, st)) . toList =<< listJobs Nothing Nothing Nothing
167 164
168abortJob :: API.JobId -> Handler () 165abortJob :: API.JobId -> Handler ()
169abortJob needle = do 166abortJob needle = do
@@ -179,7 +176,7 @@ abortJob needle = do
179 $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId') 176 $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
180 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) 177 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
181 return found 178 return found
182 when (not found) $ left err404 179 when (not found) $ throwError err404
183 180
184listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle)) 181listDrafts :: Handler (Map API.DraftId (Maybe DraftTitle))
185listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap 182listDrafts = asks sqlPool >>= runSqlPool (selectSourceRes [] []) >>= flip with toMap
@@ -194,13 +191,13 @@ addDraft title content = do
194 return id 191 return id
195 192
196updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler () 193updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
197updateDraft draftId title content = handle (\(KeyNotFound _) -> left $ err404) $ do 194updateDraft draftId title content = handle (\(KeyNotFound _) -> throwError $ err404) $ do
198 runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool 195 runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool
199 $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer)) 196 $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
200 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId 197 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId
201 198
202getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout) 199getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
203getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool 200getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
204 201
205deleteDraft :: API.DraftId -> Handler () 202deleteDraft :: API.DraftId -> Handler ()
206deleteDraft draftId = do 203deleteDraft draftId = do
@@ -209,4 +206,4 @@ deleteDraft draftId = do
209 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle)))) 206 notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
210 207
211printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId 208printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
212printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool 209printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (throwError err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs
index d7ee12a..b8580b8 100644
--- a/server/src/Thermoprint/Server/Printer/Debug.hs
+++ b/server/src/Thermoprint/Server/Printer/Debug.hs
@@ -26,7 +26,7 @@ debugPrint :: PrinterMethod
26debugPrint = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext' 26debugPrint = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext'
27 27
28cotext' :: Printout -> Text 28cotext' :: Printout -> Text
29cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList 29cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList . getChunks) . toList . getParagraphs
30 where 30 where
31 cotext'' (Cooked b) = cotext b 31 cotext'' (Cooked b) = cotext b
32 cotext'' (Raw _) = "[Raw]" 32 cotext'' (Raw _) = "[Raw]"
diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index df84e06..f431e4f 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -114,10 +114,10 @@ intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m ()
114intersperse' b f = sequence_ . intersperse b f 114intersperse' b f = sequence_ . intersperse b f
115 115
116render :: Printout -> Put 116render :: Printout -> Put
117render = intersperse' (newls' 2) renderPar 117render = intersperse' (newls' 2) renderPar . getParagraphs
118 118
119renderPar :: Paragraph -> Put 119renderPar :: Paragraph -> Put
120renderPar = mapM_ renderChunk 120renderPar = mapM_ renderChunk . getChunks
121 where 121 where
122 renderChunk (Raw bs) = mapM_ pushWord8 $ LBS.unpack bs 122 renderChunk (Raw bs) = mapM_ pushWord8 $ LBS.unpack bs
123 renderChunk (Cooked block) = renderDoc $ execState (renderBlock block) (initDoc width) 123 renderChunk (Cooked block) = renderDoc $ execState (renderBlock block) (initDoc width)
diff --git a/server/src/Thermoprint/Server/Queue/Utils.hs b/server/src/Thermoprint/Server/Queue/Utils.hs
index 86b0162..745053e 100644
--- a/server/src/Thermoprint/Server/Queue/Utils.hs
+++ b/server/src/Thermoprint/Server/Queue/Utils.hs
@@ -17,7 +17,7 @@ import Data.Time
17import Control.Monad.State 17import Control.Monad.State
18import Control.Monad.IO.Class 18import Control.Monad.IO.Class
19import Control.Monad.Trans.Identity 19import Control.Monad.Trans.Identity
20import Servant.Server.Internal.Enter 20import Servant.Utils.Enter
21 21
22import Thermoprint.Server.Queue 22import Thermoprint.Server.Queue
23 23