Api.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}

{- | The descovery api specification. -}
module Network.Legion.Discovery.Api (
  -- * Types that descirbe the API structure.
  DiscoveryApi,
  V1Api,
  PingApi,
  ServicesApi,
  GraphApi,

  -- * Types that describe API data.
  ClientList(..),
  InstanceList(..),
  Range(..),
  PingRequest(..),
  Graph(..),
  SvgGraph(..),
) where

import Data.Aeson (FromJSON, eitherDecode, encode, object, (.=))
import Data.Attoparsec.ByteString (parseOnly)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.GraphViz.Printing (renderDot, toDot)
import Data.GraphViz.Types.Canonical (DotGraph)
import Data.Map (Map)
import Data.Monoid ((<>))
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Version (showVersion)
import Distribution.Text (simpleParse)
import Distribution.Version (VersionRange)
import GHC.Generics (Generic)
import Network.HTTP.Grammar (UserAgent(UAProduct), Product(Product),
  productName, productVersion, userAgent)
import Network.Legion.Discovery.LegionApp (ServiceAddr, Client(Client),
  cName, cVersion, EntityName(EntityName), Client, unServiceAddr, version,
  InstanceInfo, Metadata)
import Servant ((:>), (:<|>), Get, Accept, contentType, ReqBody, Capture,
  Header, MimeUnrender, mimeUnrender, MimeRender, mimeRender, NoContent,
  JSON)
import Web.HttpApiData (FromHttpApiData, parseUrlPiece, parseHeader)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Network.Legion.Discovery.LegionApp as App
import qualified Servant as S


type DiscoveryApi = V1Api


type V1Api = "v1" :> (PingApi :<|> ServicesApi :<|> GraphApi)


{- | The "graph" endpoint. -}
type GraphApi =
    "graph"
    :> Get '[SvgCT] SvgGraph
  :<|>
    "graph"
    :> Get '[DotCT] Graph


{- | The "ping" endpoint. -}
type PingApi =
  "ping"
  :> Header "User-Agent" ClientList
  :> ReqBody '[PingRequestCT] PingRequest
  :> PostNoContent


{- | The "services" endpoint. -}
type ServicesApi =
    "services"
    :> Header "User-Agent" ClientList
    :> Capture "serviceName" EntityName
    :> Get '[InstanceListCT] InstanceList
  :<|>
    "services"
    :> Header "User-Agent" ClientList
    :> Capture "serviceName" EntityName
    :> Capture "versionRange" Range
    :> Get '[InstanceListCT] InstanceList


{- | Shorthand for a post returning no contents. -}
type PostNoContent = S.PostNoContent '[StupidArbitraryPlaceholder] NoContent


{- | see: https://github.com/haskell-servant/servant/issues/498 -}
type StupidArbitraryPlaceholder = JSON


{- | The type of graph data. -}
newtype Graph = Graph (DotGraph TL.Text)
instance MimeRender DotCT Graph where
  mimeRender Proxy (Graph graph) = 
    TLE.encodeUtf8 . renderDot . toDot $ graph


newtype SvgGraph = SvgGraph BSL.ByteString
instance MimeRender SvgCT SvgGraph where
  mimeRender Proxy (SvgGraph bytes) = bytes


newtype Range = Range VersionRange
instance FromHttpApiData Range where
  parseUrlPiece r = case simpleParse (T.unpack r) of
    Nothing -> Left . T.pack $ ("Invalid version range: " ++ show r)
    Just vr -> Right (Range vr)


data InstanceListCT
instance Accept InstanceListCT where
  contentType Proxy = "application/vnd.legion-discovery.instance-list+json"


data PingRequestCT
instance Accept PingRequestCT where
  contentType Proxy = "application/vnd.legion-discovery.ping-request+json"


data DotCT
instance Accept DotCT where
  contentType Proxy = "text/vnd.graphviz"


data SvgCT
instance Accept SvgCT where
  contentType Proxy = "image/svg+xml"


newtype ClientList = ClientList {
    unClientList :: [Client]
  }
instance FromHttpApiData ClientList where
  parseUrlPiece = parseHeader . encodeUtf8
  parseHeader bytes = do
      agents <- parseUserAgent bytes
      let
        clients = [
            Client {
                cName = EntityName (decodeUtf8 name),
                cVersion = version
              }
            | UAProduct Product {productName, productVersion} <- agents
            , let
                vstring = T.unpack . decodeUtf8 <$> productVersion
                (name, version) = case simpleParse =<< vstring of
                  Nothing -> (
                      productName <> maybe "" ("/" <>) productVersion,
                      Nothing
                    )
                  Just v -> (productName, Just v)
          ]
      case clients of
        [] -> Left "Invalid User-Agent request header."
        _ -> Right (ClientList clients)
    where
      {- |
        Parse a user-agent header according to the specification in
        RFC-2616, or else return a reason why parsing failed.
      -}
      parseUserAgent :: ByteString -> Either Text [UserAgent]
      parseUserAgent = first T.pack . parseOnly userAgent


newtype InstanceList = InstanceList (Map ServiceAddr InstanceInfo)
instance MimeRender InstanceListCT InstanceList where
  mimeRender Proxy (InstanceList instances) = 
    encode $ object [
        unServiceAddr addr .= object [
            "version" .= showVersion (version info),
            "metadata" .= App.metadata info
          ]
        | (addr, info) <- Map.toList instances
      ]


{- | Decode a ping request entity. -}
data PingRequest = PingRequest {
    serviceAddress :: ServiceAddr,
          metadata :: Maybe Metadata
  }
  deriving (Generic)
instance FromJSON PingRequest
instance MimeUnrender PingRequestCT PingRequest where
  mimeUnrender Proxy = eitherDecode