{- | Parse Servant API into documentation

__Example script__

[Generating the intermediate documentation structure](https://github.com/Holmusk/servant-docs-simple/blob/master/examples/parse.hs)

__Example of parsing an API__

/API type/

> type API = "hello" :> "world" :> Request :> Response
> type Request = ReqBody '[()] ()
> type Response = Post '[()] ()

/Intermediate structure/

> Endpoints [Node "/hello/world"
>                 (Details [ Node "RequestBody" (Details [ Node "Format"
>                                                               (Detail "': * () ('[] *)")
>                                                        , Node "ContentType"
>                                                               (Detail "()")
>                                                        ])
>                          , Node "RequestType" (Detail "'POST")
>                          , Node "Response" (Details [ Node "Format"
>                                                            (Detail "': * () ('[] *)")
>                                                     , Node "ContentType"
>                                                            (Detail "()")
>                                                     ])
>                          ])]

-}

{-# LANGUAGE UndecidableInstances #-}

module Servant.Docs.Simple.Parse (HasParsable (..)) where


import Data.Foldable (fold)
import Data.Proxy
import Data.Text (Text, pack)
import Data.Typeable (Typeable, typeRep)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

import Servant.API ((:>), AuthProtect, BasicAuth, Capture', CaptureAll, Description, EmptyAPI,
                    Header', HttpVersion, IsSecure, QueryFlag, QueryParam', QueryParams, RemoteHost,
                    ReqBody', StreamBody', Summary, Vault, Verb)
import qualified Servant.API.TypeLevel as S (Endpoints)

import Servant.Docs.Simple.Render (Details (..), Endpoints (..), Node (..))

-- | Flattens API into type level list of 'Endpoints'
class HasParsable api where
    parse :: Endpoints

instance HasCollatable (S.Endpoints a) => HasParsable a where
    parse :: Endpoints
parse = HasCollatable (Endpoints a) => Endpoints
forall k (api :: k). HasCollatable api => Endpoints
collate @(S.Endpoints a)

instance {-# OVERLAPPING #-} HasParsable EmptyAPI where
    parse :: Endpoints
parse = HasCollatable '[] => Endpoints
forall k (api :: k). HasCollatable api => Endpoints
collate @'[]

-- | Folds api endpoints into documentation
class HasCollatable api where
    -- | Folds list of endpoints to documentation
    collate :: Endpoints

instance (HasDocumentApi api, HasCollatable b) => HasCollatable (api ': b) where
    collate :: Endpoints
collate = [Node] -> Endpoints
Endpoints ([Node] -> Endpoints) -> [Node] -> Endpoints
forall a b. (a -> b) -> a -> b
$ HasDocumentApi api => Node
forall k (a :: k). HasDocumentApi a => Node
documentEndpoint @api Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
previous
      where Endpoints previous :: [Node]
previous = HasCollatable b => Endpoints
forall k (api :: k). HasCollatable api => Endpoints
collate @b

instance HasCollatable '[] where
    collate :: Endpoints
collate = [Node] -> Endpoints
Endpoints []

-- | Folds an api endpoint into documentation
documentEndpoint :: forall a. HasDocumentApi a => Node
documentEndpoint :: Node
documentEndpoint = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @a "" []

-- | Folds an api endpoint into documentation
class HasDocumentApi api where

    -- | We use this to destructure the API type and convert it into documentation
    document :: Text -- ^ Route documentation
             -> [Node] -- ^ Everything else documentation
             -> Node -- ^ Generated documentation for the route

-- | Static route documentation
instance (HasDocumentApi b, KnownSymbol route) => HasDocumentApi ((route :: Symbol) :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
formatted
        where formatted :: Text
formatted = [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
r, "/", Text
fragment]
              fragment :: Text
fragment = KnownSymbol route => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @route

-- | Capture documentation
instance (HasDocumentApi b, KnownSymbol dRoute, Typeable t) => HasDocumentApi (Capture' m (dRoute :: Symbol) t :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
formatted
        where formatted :: Text
formatted = [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
r, "/", "{", Text
var, "::", Text
format, "}"]
              var :: Text
var = KnownSymbol dRoute => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @dRoute
              format :: Text
format = Typeable t => Text
forall k (a :: k). Typeable a => Text
typeText @t

-- | CaptureAll documentation
instance (HasDocumentApi b, KnownSymbol dRoute, Typeable t) => HasDocumentApi (CaptureAll (dRoute :: Symbol) t :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
formatted
        where formatted :: Text
formatted = [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Text
r, "/", "{", Text
var, "::", Text
format, "}"]
              var :: Text
var = KnownSymbol dRoute => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @dRoute
              format :: Text
format = Typeable t => Text
forall k (a :: k). Typeable a => Text
typeText @t

-- | Request HttpVersion documentation
instance HasDocumentApi b => HasDocumentApi (HttpVersion :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "Captures Http Version" (Text -> Details
Detail "True")

-- | IsSecure documentation
instance HasDocumentApi b => HasDocumentApi (IsSecure :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "SSL Only" (Text -> Details
Detail "True")

-- | Request Remote host documentation
instance HasDocumentApi b => HasDocumentApi (RemoteHost :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "Captures RemoteHost/IP" (Text -> Details
Detail "True")

-- | Description documentation
instance (HasDocumentApi b, KnownSymbol desc) => HasDocumentApi (Description (desc :: Symbol) :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "Description" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol desc => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @desc)

-- | Summary documentation
instance (HasDocumentApi b, KnownSymbol s) => HasDocumentApi (Summary (s :: Symbol) :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "Summary" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol s => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @s)

-- | Vault documentation
instance HasDocumentApi b => HasDocumentApi (Vault :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
desc])
        where desc :: Node
desc = Text -> Details -> Node
Node "Vault" (Text -> Details
Detail "True")

-- | Basic authentication documentation
instance (HasDocumentApi b, KnownSymbol realm, Typeable a) => HasDocumentApi (BasicAuth (realm :: Symbol) a :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "Basic Authentication" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                               [Node] -> Details
Details [ Text -> Details -> Node
Node "Realm" (Text -> Details
Detail Text
realm)
                                       , Text -> Details -> Node
Node "UserData" (Text -> Details
Detail Text
userData)
                                       ]
              realm :: Text
realm = KnownSymbol realm => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @realm
              userData :: Text
userData = Typeable a => Text
forall k (a :: k). Typeable a => Text
typeText @a

-- | Authentication documentation
instance (HasDocumentApi b, KnownSymbol token) => HasDocumentApi (AuthProtect (token :: Symbol) :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "Authentication" (Text -> Details
Detail Text
authDoc)
              authDoc :: Text
authDoc = KnownSymbol token => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @token

-- | Request header documentation
instance (HasDocumentApi b, KnownSymbol ct, Typeable typ) => HasDocumentApi (Header' m (ct :: Symbol) typ :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "RequestHeaders" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                               [Node] -> Details
Details [ Text -> Details -> Node
Node "Name" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol ct => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @ct)
                                       , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                       ]

-- | Query flag documentation
instance (HasDocumentApi b, KnownSymbol param) => HasDocumentApi (QueryFlag (param :: Symbol) :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "QueryFlag" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                                [Node] -> Details
Details [ Text -> Details -> Node
Node "Param" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol param => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @param) ]

-- | Query param documentation
instance (HasDocumentApi b, KnownSymbol param, Typeable typ) => HasDocumentApi (QueryParam' m (param :: Symbol) typ :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "QueryParam" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                                [Node] -> Details
Details [ Text -> Details -> Node
Node "Param" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol param => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @param)
                                        , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                        ]

-- | Query params documentation
instance (HasDocumentApi b, KnownSymbol param, Typeable typ) => HasDocumentApi (QueryParams (param :: Symbol) typ :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "QueryParams" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                                [Node] -> Details
Details [ Text -> Details -> Node
Node "Param" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ KnownSymbol param => Text
forall (n :: Symbol). KnownSymbol n => Text
symbolVal' @param)
                                        , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                        ]

-- | Request body documentation
instance (HasDocumentApi b, Typeable ct, Typeable typ) => HasDocumentApi (ReqBody' m ct typ :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "RequestBody" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                                [Node] -> Details
Details [ Text -> Details -> Node
Node "Format" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable ct => Text
forall k (a :: k). Typeable a => Text
typeText @ct)
                                        , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                        ]

-- | Stream body documentation
instance (HasDocumentApi b, Typeable ct, Typeable typ) => HasDocumentApi (StreamBody' m ct typ :> b) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> [Node] -> Node
forall k (api :: k). HasDocumentApi api => Text -> [Node] -> Node
document @b Text
r ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [Node
formatted])
        where formatted :: Node
formatted = Text -> Details -> Node
Node "StreamBody" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                                [Node] -> Details
Details [ Text -> Details -> Node
Node "Format" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable ct => Text
forall k (a :: k). Typeable a => Text
typeText @ct)
                                        , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                        ]

-- | Response documentation
--   Terminates here as responses are last parts of api endpoints
--   Note that request type information (GET, POST etc...) is contained here
instance (Typeable m, Typeable ct, Typeable typ) => HasDocumentApi (Verb m s ct typ) where
    document :: Text -> [Node] -> Node
document r :: Text
r a :: [Node]
a = Text -> Details -> Node
Node Text
r (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                        [Node] -> Details
Details ([Node]
a [Node] -> [Node] -> [Node]
forall a. Semigroup a => a -> a -> a
<> [ Node
requestType
                                      , Node
response
                                      ])
        where requestType :: Node
requestType = Text -> Details -> Node
Node "RequestType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable m => Text
forall k (a :: k). Typeable a => Text
typeText @m)
              response :: Node
response = Text -> Details -> Node
Node "Response" (Details -> Node) -> Details -> Node
forall a b. (a -> b) -> a -> b
$
                              [Node] -> Details
Details [ Text -> Details -> Node
Node "Format" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable ct => Text
forall k (a :: k). Typeable a => Text
typeText @ct)
                                      , Text -> Details -> Node
Node "ContentType" (Text -> Details
Detail (Text -> Details) -> Text -> Details
forall a b. (a -> b) -> a -> b
$ Typeable typ => Text
forall k (a :: k). Typeable a => Text
typeText @typ)
                                      ]

-- | Internal Helper utilities
typeText :: forall a. (Typeable a) => Text
typeText :: Text
typeText = String -> Text
pack (String -> Text) -> (Proxy a -> String) -> Proxy a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy a -> TypeRep) -> Proxy a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a

symbolVal' :: forall n. KnownSymbol n => Text
symbolVal' :: Text
symbolVal' = String -> Text
pack (String -> Text) -> (Proxy n -> String) -> Proxy n -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n -> Text) -> Proxy n -> Text
forall a b. (a -> b) -> a -> b
$ Proxy n
forall k (t :: k). Proxy t
Proxy @n