Haskell-Demo/src/Demo.hs at 4703a365b3d1e82a1fed59f84efcae8d4bf5ef66 · MatrixAI/Haskell-Demo · GitHub

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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}

module Demo where

import qualified Control.Exception.Safe        as E
import           Control.Exception.Safe         ( MonadCatch
                                                , MonadThrow
                                                )
import           Control.Monad.IO.Class         ( MonadIO
                                                , liftIO
                                                )
import qualified Control.Monad.Logger          as L
import           Control.Monad.Logger           ( LoggingT
                                                , MonadLogger
                                                )
import           Control.Monad.Reader           ( MonadReader
                                                , ReaderT
                                                , ask
                                                , runReaderT
                                                )
import           Data.Default.Class             ( Default
                                                , def
                                                )
import           Data.IP                        ( IP )
import           Data.String                    ( fromString )
import qualified Network.HTTP.Types            as HTTP
import qualified Network.HTTP.Types.Header     as HTTPHeaders
import           Network.Socket                 ( PortNumber )
import           Network.Wai                    ( Application )
import qualified Network.Wai                   as Wai
import qualified Network.Wai.Handler.Warp      as Warp
import           System.Environment             ( lookupEnv )


data DemoEnv = DemoEnv { demoEnvHost :: IP,
                         demoEnvPort :: PortNumber
                       } deriving (Show)

-- this is the default demoenv
instance Default DemoEnv where
  def = DemoEnv "127.0.0.1" 55555

newtype DemoT m a = DemoT
  { runDemoT :: ReaderT DemoEnv (LoggingT m) a }
  deriving (
    Functor,
    Applicative,
    Monad,
    MonadIO,
    MonadThrow,
    MonadCatch,
    MonadLogger,
    MonadReader DemoEnv
    )

type Demo = DemoT IO

runDemo :: DemoEnv -> Demo a -> IO a
runDemo env demo = L.runStderrLoggingT $ runReaderT (runDemoT demo) env

warpApp :: Application
warpApp _req respond = E.bracket_
  (L.runStderrLoggingT ($(L.logInfo) "Try IO Block"))
  (L.runStderrLoggingT ($(L.logInfo) "Clean IO Block"))
  (respond $ Wai.responseLBS HTTP.status200
                             [(HTTPHeaders.hContentType, "text/plain")]
                             "Hello from Demo!\n"
  )

demoApp :: Demo ()
demoApp = do
  $(L.logInfo) "Starting Demo Server"
  DemoEnv ip port <- ask
  let settings =
        Warp.setHost (fromString $ show ip)
          $ Warp.setPort (fromIntegral port)
          $ Warp.defaultSettings
  $(L.logInfo) $ fromString $ "Running on " ++ show ip ++ ":" ++ show port
  liftIO $ Warp.runSettings settings warpApp
  $(L.logInfo) "Terminated Demo Server"

runDemoApp :: IO ()
runDemoApp = do
  demoHost <- lookupEnv "DEMO_HOST"
  demoPort <- lookupEnv "DEMO_PORT"
  let defaultEnv = def :: DemoEnv
  defaultEnv' <- return $ maybe
    defaultEnv
    (\host -> defaultEnv { demoEnvHost = read host })
    demoHost
  defaultEnv'' <- return $ maybe
    defaultEnv'
    (\port -> defaultEnv' { demoEnvPort = read port })
    demoPort
  runDemo defaultEnv'' demoApp