diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r-- | server/src/Thermoprint/Server.hs | 28 |
1 files changed, 24 insertions, 4 deletions
diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index df2d8e9..446c63e 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs | |||
@@ -6,6 +6,7 @@ | |||
6 | {-# LANGUAGE ImpredicativeTypes #-} | 6 | {-# LANGUAGE ImpredicativeTypes #-} |
7 | {-# LANGUAGE ExistentialQuantification #-} | 7 | {-# LANGUAGE ExistentialQuantification #-} |
8 | {-# LANGUAGE ViewPatterns #-} | 8 | {-# LANGUAGE ViewPatterns #-} |
9 | {-# LANGUAGE DataKinds #-} | ||
9 | 10 | ||
10 | module Thermoprint.Server | 11 | module Thermoprint.Server |
11 | ( thermoprintServer | 12 | ( thermoprintServer |
@@ -25,9 +26,17 @@ import qualified Data.Map as Map | |||
25 | 26 | ||
26 | import Data.Set (Set) | 27 | import Data.Set (Set) |
27 | import qualified Data.Set as Set | 28 | import qualified Data.Set as Set |
29 | |||
30 | import Data.Sequence (Seq) | ||
31 | import qualified Data.Sequence as Seq | ||
32 | |||
33 | import Data.Time (UTCTime) | ||
28 | 34 | ||
29 | import Data.Maybe (maybe) | 35 | import Data.Maybe (maybe) |
30 | import Data.Foldable (mapM_, forM_, foldlM) | 36 | import Data.Foldable (mapM_, forM_, foldlM) |
37 | import Data.Function hiding (id, (.)) | ||
38 | import Data.Bifunctor | ||
39 | import Data.Proxy | ||
31 | 40 | ||
32 | import Control.Monad.Trans.Resource | 41 | import Control.Monad.Trans.Resource |
33 | import Control.Monad.Trans.Control | 42 | import Control.Monad.Trans.Control |
@@ -53,14 +62,20 @@ import Network.Wai (Application) | |||
53 | 62 | ||
54 | import Servant.Server (serve) | 63 | import Servant.Server (serve) |
55 | import Servant.Server.Internal.Enter (enter, (:~>)(..)) | 64 | import Servant.Server.Internal.Enter (enter, (:~>)(..)) |
65 | import Servant.API | ||
66 | import Servant.Utils.Links | ||
67 | import Network.URI | ||
56 | 68 | ||
57 | import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool) | 69 | import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool) |
58 | 70 | ||
59 | 71 | ||
60 | import Thermoprint.API (thermoprintAPI, PrinterId) | 72 | import Thermoprint.API (thermoprintAPI, PrinterStatus, JobStatus) |
73 | import qualified Thermoprint.API as API (PrinterId, JobId) | ||
61 | 74 | ||
62 | import Thermoprint.Server.Fork | 75 | import Thermoprint.Server.Fork |
63 | 76 | ||
77 | import Thermoprint.Server.Push | ||
78 | |||
64 | import Thermoprint.Server.Database | 79 | import Thermoprint.Server.Database |
65 | import Thermoprint.Server.Printer | 80 | import Thermoprint.Server.Printer |
66 | import Thermoprint.Server.Queue | 81 | import Thermoprint.Server.Queue |
@@ -72,8 +87,8 @@ import Debug.Trace | |||
72 | -- | Compile-time configuration for 'thermoprintServer' | 87 | -- | Compile-time configuration for 'thermoprintServer' |
73 | data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error | 88 | data Config m = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error |
74 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour | 89 | , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour |
75 | , printers :: Map PrinterId Printer | 90 | , printers :: Map API.PrinterId Printer |
76 | , queueManagers :: PrinterId -> QMConfig m | 91 | , queueManagers :: API.PrinterId -> QMConfig m |
77 | } | 92 | } |
78 | 93 | ||
79 | data QMConfig m = forall t. ( MonadTrans t | 94 | data QMConfig m = forall t. ( MonadTrans t |
@@ -137,4 +152,9 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams | |||
137 | let | 152 | let |
138 | runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer | 153 | runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer |
139 | mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers | 154 | mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers |
140 | liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers | 155 | nChan <- liftIO $ newBroadcastTChanIO |
156 | let | ||
157 | printerUrl :: API.PrinterId -> URI | ||
158 | printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus)))) | ||
159 | mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers | ||
160 | liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan | ||