aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
-rw-r--r--server/src/Thermoprint/Server.hs14
1 files changed, 7 insertions, 7 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