server/src/Thermoprint/Server.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

{-# LANGUAGE RecordWildCards #-}

module Thermoprint.Server
       ( thermoprintServer
       , module Data.Default.Class
       ) where

import Data.Default.Class
import qualified Config.Dyre as Dyre

import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)

import Control.Monad ((<=<))

import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai (Application)

import Servant.Server

import Thermoprint.API

data Config = Config { dyreError    :: Maybe String
                     , warpSettings :: Warp.Settings
                     }

instance Default Config where
  def = Config { dyreError = Nothing
               , warpSettings = Warp.defaultSettings
               }

thermoprintServer :: Config -> IO ()
thermoprintServer = Dyre.wrapMain $ Dyre.defaultParams
  { Dyre.projectName = "thermoprint-server"
  , Dyre.realMain    = realMain <=< handleDyreErrors
  , Dyre.showError   = (\cfg msg -> cfg { dyreError = Just msg })
  }

handleDyreErrors :: Config -> IO Config
handleDyreErrors cfg
  | Just msg <- dyreError cfg = do
      hPutStrLn stderr msg
      exitFailure
      return undefined
  | otherwise = return cfg
      

realMain :: Config -> IO ()
realMain cfg@(Config{..}) = Warp.runSettings warpSettings $ serve thermoprintAPI thermoprintServer' 

thermoprintServer :: Server ThermoprintAPI
thermoprintServer = undefined