Api.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{- | The descovery api specification. -}
module Network.Legion.Discovery.Api (
  -- * Api types
  DiscoveryApi,
  V1Api,
  PingApi,
  InstancesApi,
  GraphApi,

  -- * "Real" data types.
  ClientList(..),
  InstanceList(..),
  Range(..),
  PingRequest(..),
  Graph(..),
) where

import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:), eitherDecode,
  encode, object, (.=))
import Data.ByteString (hGetContents)
import Data.GraphViz (graphvizWithHandle, GraphvizCommand(Dot),
  GraphvizOutput(Svg))
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.Encoding (encodeUtf8, decodeUtf8)
import Data.Version (showVersion)
import Distribution.Text (simpleParse)
import Distribution.Version (VersionRange)
import Network.Legion.Discovery.LegionApp (ServiceAddr(ServiceAddr),
  Client(Client), cName, cVersion, EntityName(EntityName), Client,
  unServiceAddr, version, InstanceInfo)
import Network.Legion.Discovery.UserAgent (parseUserAgent,
  UserAgent(UAProduct), Product(Product), productName, productVersion)
import Servant ((:>), (:<|>), Get, Accept, contentType, ReqBody, Capture,
  Header, MimeUnrender, mimeUnrender, MimeRender, mimeRender, NoContent,
  JSON)
import System.IO.Unsafe (unsafePerformIO)
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 Servant as S


type DiscoveryApi =
  "v1" :> V1Api


type V1Api =
  Header "User-Agent" ClientList :> (
    "ping" :> PingApi :<|>
    "services" :> (
      Capture "serviceName" EntityName :> (
        InstancesApi :<|>
        Capture "versionRange" Range :> InstancesApi
      )
    )
  ) :<|>
  "graph" :> GraphApi


{- | The "graph" endpoint. -}
type GraphApi = Get '[SvgCT, DotCT] Graph


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


{- | 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


{- | Api segment that returns a list of instances. -}
type InstancesApi = Get '[InstanceListCT] InstanceList


{- | 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
instance MimeRender SvgCT Graph where
  mimeRender Proxy (Graph graph) = unsafePerformIO $ do
    bytes <- graphvizWithHandle Dot graph Svg hGetContents
    return (BSL.fromStrict 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 [Client]
instance FromHttpApiData ClientList where
  parseUrlPiece = parseHeader . encodeUtf8
  parseHeader bytes = do
    agents <- parseUserAgent bytes
    return $ ClientList [
        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)
      ]


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


{- | Decode a ping request entity. -}
newtype PingRequest = PingRequest {
    serviceAddress :: ServiceAddr
  }
instance FromJSON PingRequest where
  parseJSON (Object o) =
    PingRequest . ServiceAddr <$> o .: "serviceAddress"
  parseJSON v = fail
    $ "Can't parse PingRequest from: " ++ show v
instance MimeUnrender PingRequestCT PingRequest where
  mimeUnrender Proxy = eitherDecode