Warp and Logging and Application Transformer Demo

app/service/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Demo as Demo
+
+main :: IO ()
+main = Demo.runDemoApp

default.nix

@@ -1,14 +1,26 @@
-{ mkDerivation, base, hpack, stdenv }:
+{ mkDerivation, base, data-default-class, hpack, http-types
+, iproute, monad-logger, mtl, network, safe-exceptions, stdenv
+, transformers, wai, warp
+}:
 mkDerivation {
   pname = "haskell-demo";
   version = "0.1.0.0";
   src = ./.;
   isLibrary = true;
   isExecutable = true;
-  libraryHaskellDepends = [ base ];
+  libraryHaskellDepends = [
+    base data-default-class http-types iproute monad-logger mtl network
+    safe-exceptions transformers wai warp
+  ];
   libraryToolDepends = [ hpack ];
-  executableHaskellDepends = [ base ];
-  testHaskellDepends = [ base ];
+  executableHaskellDepends = [
+    base data-default-class http-types iproute monad-logger mtl network
+    safe-exceptions transformers wai warp
+  ];
+  testHaskellDepends = [
+    base data-default-class http-types iproute monad-logger mtl network
+    safe-exceptions transformers wai warp
+  ];
   prePatch = "hpack";
   homepage = "https://github.com/MatrixAI/Haskell-Demo#readme";
   license = stdenv.lib.licenses.asl20;

package.yaml

@@ -14,6 +14,16 @@ description:         Please see the README on Github at <https://github.com/Matr
 
 dependencies:
 - base >= 4.7 && < 5
+- transformers
+- mtl
+- monad-logger
+- safe-exceptions
+- network
+- iproute
+- wai
+- warp
+- http-types
+- data-default-class
 
 library:
   source-dirs: src
@@ -28,11 +38,21 @@ library:
   exposed-modules:
     - Lib
     - FFI
+    - Demo
 
 executables:
-  haskell-demo-exe:
+  haskell-demo-ffi-exe:
     main:                Main.hs
-    source-dirs:         app
+    source-dirs:         app/ffi
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - haskell-demo
+  haskell-demo-service-exe:
+    main:                Main.hs
+    source-dirs:         app/service
     ghc-options:
     - -threaded
     - -rtsopts

src/Demo.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+module Demo where
+
+import           Control.Exception.Safe        as E
+import           Control.Exception.Safe         ( MonadCatch
+                                                , MonadMask
+                                                , MonadThrow
+                                                )
+import           Control.Monad.IO.Class         ( MonadIO
+                                                , liftIO
+                                                )
+import           Control.Monad.Logger          as L
+import           Control.Monad.Logger           ( LoggingT
+                                                , MonadLogger
+                                                )
+import           Control.Monad.Reader           ( MonadReader
+                                                , ReaderT
+                                                , ask
+                                                , runReaderT
+                                                )
+import           Control.Monad.Trans.Class      ( MonadTrans
+                                                , lift
+                                                )
+import           Data.Default.Class             ( Default
+                                                , def
+                                                )
+import           Data.IP                        ( IP )
+import           Data.String                    ( fromString )
+import           Network.HTTP.Types            as HTTP
+import           Network.HTTP.Types.Header     as HTTPHeaders
+import           Network.Socket                 ( PortNumber )
+import           Network.Wai                    ( Application )
+import           Network.Wai                   as Wai
+import           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 = do
+  runStderrLoggingT $ runReaderT (runDemoT demo) env
+
+warpApp :: Application
+warpApp req respond = E.bracket_
+  (runStderrLoggingT ($(L.logInfo) "Try IO Block"))
+  (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