From ac4cf4a0a494eafe55364f816569c517684fdf32 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <pngwjpgh@users.noreply.github.com>
Date: Sun, 17 Jul 2016 14:23:18 +0200
Subject: override some dyre params via environment

---
 server/src/Thermoprint/Server.hs | 57 ++++++++++++++++++++++------------------
 1 file changed, 32 insertions(+), 25 deletions(-)

(limited to 'server/src/Thermoprint/Server.hs')

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index f73a418..07462da 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -67,6 +67,8 @@ import Servant.API
 import Servant.Utils.Links
 import Network.URI
 
+import System.Environment (lookupEnv)
+
 import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)
 
 
@@ -135,28 +137,33 @@ thermoprintServer :: ( MonadLoggerIO m
                      -> (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.
                      -> ResourceT m (Config (ResourceT m)) -> IO ()
 -- ^ Run the server
-thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
-  { Dyre.projectName = "thermoprint-server"
-  , Dyre.realMain    = realMain
-  , Dyre.showError   = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
-  , Dyre.configCheck = dyre
-  }
-    where
-      realMain cfg = unNat (io . Nat runResourceT) $ do
-        tMgr <- threadManager resourceForkIO
-        flip finally (cleanup tMgr) $ do
-          Config{..} <- cfg
-          maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
-          mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
-          forM_ printers $ fork tMgr . runPrinter
-          gcChan <- liftIO newTChanIO
-          fork tMgr $ jobGC gcChan
-          let
-            runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
-          mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
-          nChan <- liftIO $ newBroadcastTChanIO
-          let
-            printerUrl :: API.PrinterId -> URI
-            printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
-          mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers
-          liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan
+thermoprintServer dyre io = do
+  cfgDir <- lookupEnv "THERMOPRINT_CONFIG"
+  cacheDir <- lookupEnv "THERMOPRINT_CACHE"
+  Dyre.wrapMain $ Dyre.defaultParams
+    { Dyre.projectName = "thermoprint-server"
+    , Dyre.realMain    = realMain
+    , Dyre.showError   = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg }))
+    , Dyre.configCheck = dyre
+    , Dyre.configDir   = cfgDir
+    , Dyre.cacheDir    = cacheDir
+    }
+  where
+    realMain cfg = unNat (io . Nat runResourceT) $ do
+      tMgr <- threadManager resourceForkIO
+      flip finally (cleanup tMgr) $ do
+        Config{..} <- cfg
+        maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError
+        mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask
+        forM_ printers $ fork tMgr . runPrinter
+        gcChan <- liftIO newTChanIO
+        fork tMgr $ jobGC gcChan
+        let
+          runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
+        mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
+        nChan <- liftIO $ newBroadcastTChanIO
+        let
+          printerUrl :: API.PrinterId -> URI
+          printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
+        mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers
+        liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan
-- 
cgit v1.2.3