diff options
Diffstat (limited to 'server/src/Thermoprint/Server.hs')
| -rw-r--r-- | server/src/Thermoprint/Server.hs | 14 |
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 | |||
| 62 | import Network.Wai (Application) | 62 | import Network.Wai (Application) |
| 63 | 63 | ||
| 64 | import Servant.Server (serve) | 64 | import Servant.Server (serve) |
| 65 | import Servant.Server.Internal.Enter (enter, (:~>)(..)) | 65 | import Servant.Utils.Enter (enter, (:~>)(..)) |
| 66 | import Servant.API | 66 | import Servant.API |
| 67 | import Servant.Utils.Links | 67 | import Servant.Utils.Links |
| 68 | import Network.URI | 68 | import 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 |
| 140 | thermoprintServer dyre io = do | 140 | thermoprintServer 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 |
