Server.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{- | Contains the servant implentation of the 'DiscoveryApi'. -}
module Network.Legion.Discovery.Server (
  discoveryServer,
) where

import Control.Monad.Except (throwError)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString (hGetContents)
import Data.GraphViz (graphvizWithHandle, GraphvizCommand(Dot),
  GraphvizOutput(Svg))
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Version (Version)
import Distribution.Version (anyVersion)
import Network.Legion (Runtime)
import Network.Legion.Discovery.Api(DiscoveryApi, V1Api,
  ClientList(ClientList), DiscoveryApi, PingRequest(PingRequest),
  Range(Range), serviceAddress, PingApi, InstancesApi,
  InstanceList(InstanceList), GraphApi, Graph(Graph), SvgGraph(SvgGraph))
import Network.Legion.Discovery.Graphviz (toDotGraph)
import Network.Legion.Discovery.LegionApp (Input, Output, unEntityName,
  Client(Client), cName, cVersion, EntityName, Client, Output, getRange,
  getAllServices)
import Servant ((:<|>)((:<|>)), Server, ServantErr, errBody,
  errHeaders, err400, NoContent(NoContent), Handler)
import qualified Data.ByteString.Lazy as BSL
import qualified Network.Legion.Discovery.LegionApp as App


{- | The implementation of the 'DiscoveryApi' api.  -}
discoveryServer :: Runtime Input Output -> Server DiscoveryApi
discoveryServer = v1


{- | version 1 of the api. -}
v1 :: Runtime Input Output -> Server V1Api
v1 runtime  =
    (\case
      Just (ClientList (clients@(_:_))) ->
        ping clients :<|>
        (\name ->
          allInstances clients name :<|>
          rangedInstances clients name
        )
      Just (ClientList []) ->
        let bad = throwError (badRequest "Invalid User-Agent request header.")
        in const bad :<|> const (bad :<|> const bad)
      _ ->
        let bad = throwError (badRequest "Missing User-Agent request header.")
        in const bad :<|> const (bad :<|> const bad)
    ) :<|>
    graph
  where
    graph :: Server GraphApi
    graph = svgGraph :<|> dotGraph
      where
        dotGraph = Graph . toDotGraph <$> getAllServices runtime
        svgGraph = do
          g <- toDotGraph <$> getAllServices runtime
          bytes <- liftIO $ graphvizWithHandle Dot g Svg hGetContents
          return (SvgGraph (BSL.fromStrict bytes))

    ping :: [Client] -> Server PingApi
    ping clients PingRequest {serviceAddress} = do
        strictClients <- mapM toStrict clients
        liftIO $ do
          sequence_ [
              App.ping runtime name version serviceAddress
              | (name, version) <- strictClients
            ]
          return NoContent
      where
        {- |
          Return the client name and version, or else throw an error if
          the client doesn't provide a version.
        -}
        toStrict :: Client -> Handler (EntityName, Version)
        toStrict Client {cName, cVersion = Just version} =
          return (cName, version)
        toStrict Client {cName, cVersion = Nothing} =
          throwError $ badRequest (
              "Missing version for client product: "
              <> unEntityName cName
              <> ". Please fix your User-Agent header."
            )

    allInstances :: [Client] -> EntityName -> Server InstancesApi
    allInstances clients name = rangedInstances clients name (Range anyVersion)

    rangedInstances :: [Client] -> EntityName -> Range -> Server InstancesApi
    rangedInstances clients name (Range range) = liftIO $
      InstanceList <$> getRange runtime clients name range


{- | 400 BadRequest servant error helper. -}
badRequest :: Text -> ServantErr
badRequest msg = err400 {
    errBody = BSL.fromStrict (encodeUtf8 msg),
    errHeaders = [("content-type", "text/plain")]
  }