Discovery.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Network.Legion.Discovery (
  main,
) where

import Canteven.HTTP (requestLogging, logExceptionsAndContinue)
import Canteven.Log.MonadLog (getCantevenOutput)
import Control.Monad (void)
import Control.Monad.Logger (runLoggingT)
import Data.Proxy (Proxy(Proxy))
import Data.Version (showVersion)
import Network.Legion (forkLegionary, newMemoryPersistence, Persistence)
import Network.Legion.Config (parseArgs)
import Network.Legion.Discovery.Api(DiscoveryApi)
import Network.Legion.Discovery.LegionApp (Input, Output, State)
import Network.Legion.Discovery.Server (discoveryServer)
import Network.Wai (Middleware, modifyResponse)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.StripHeaders (stripHeader)
import Servant (serve)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.Legion.Discovery.Config as C
import qualified Network.Wai.Handler.Warp as Warp
import qualified Paths_legion_discovery as P
import qualified System.Remote.Monitoring as Ekg

main :: IO ()
main = do
  (settings, startupMode, config) <- parseArgs
  logging <- getCantevenOutput (C.logging config)
  void $ Ekg.forkServer "localhost" (C.ekgPort config)
  persist <- newMemoryPersistence :: IO (Persistence Input Output State)
  legion <- (`runLoggingT` logging)
    $ forkLegionary persist settings startupMode
  Warp.run
    (C.servicePort config)
    (
      requestLogging logging
      . setServer "legion-discovery"
      . logExceptionsAndContinue logging
      . serve (Proxy :: Proxy DiscoveryApi)
      . discoveryServer
      $ legion
    ) 


{- | Set the server header.  -}
setServer :: String -> Middleware
setServer serviceName = addServerHeader . stripServerHeader
  where
    {- | Strip the server header. -}
    stripServerHeader :: Middleware
    stripServerHeader = modifyResponse (stripHeader "Server")

    {- | Add our own server header. -}
    addServerHeader :: Middleware
    addServerHeader = addHeaders [("Server", serverValue)]

    {- | The value of the @Server:@ header. -}
    serverValue =
      TE.encodeUtf8 (T.pack (serviceName ++ "/" ++ showVersion P.version))