{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module      :  Servant.Checked.Exceptions.Internal.Servant.Docs

Copyright   :  Dennis Gosnell 2017
License     :  BSD3

Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

This module exports 'HasDocs' instances for 'Throws' and 'Throwing'.
-}

module Servant.Checked.Exceptions.Internal.Servant.Docs where

import Data.Proxy (Proxy(Proxy))
import Data.ByteString.Lazy (ByteString)
import Data.Function ((&))
import Data.Monoid ((<>))
import Data.Text (Text)
import Network.HTTP.Media (MediaType)
import Servant.API (Verb, (:>))
import Servant.API.ContentTypes (AllMimeRender(allMimeRender))
import Servant.Docs
       (Action, API, DocOptions, Endpoint, HasDocs(docsFor),
        ToSample(toSamples))
import Servant.Docs.Internal (apiEndpoints, respBody, response)

import Servant.Checked.Exceptions.Internal.Envelope
       (Envelope, toErrEnvelope, toSuccEnvelope)
import Servant.Checked.Exceptions.Internal.Prism ((<>~))
import Servant.Checked.Exceptions.Internal.Servant.API
       (NoThrow, Throws, Throwing)
import Servant.Checked.Exceptions.Internal.Util (Snoc)

-- TODO: Make sure to also account for when headers are being used.

-- | Change a 'Throws' into 'Throwing'.
instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where
  docsFor
    :: Proxy (Throws e :> api)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor :: Proxy (Throws e :> api) -> (Endpoint, Action) -> DocOptions -> API
docsFor Proxy (Throws e :> api)
Proxy = Proxy (Throwing '[e] :> api)
-> (Endpoint, Action) -> DocOptions -> API
forall k (api :: k).
HasDocs api =>
Proxy api -> (Endpoint, Action) -> DocOptions -> API
docsFor (Proxy (Throwing '[e] :> api)
forall k (t :: k). Proxy t
Proxy :: Proxy (Throwing '[e] :> api))

-- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for
-- the same 'Verb', but returning an @'Envelope' es@.  Also add documentation
-- for the potential @es@.
instance
       ( CreateRespBodiesFor es ctypes
       , HasDocs (Verb method status ctypes (Envelope es a))
       )
    => HasDocs (Throwing es :> Verb method status ctypes a) where
  docsFor
    :: Proxy (Throwing es :> Verb method status ctypes a)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor :: Proxy (Throwing es :> Verb method status ctypes a)
-> (Endpoint, Action) -> DocOptions -> API
docsFor Proxy (Throwing es :> Verb method status ctypes a)
Proxy (Endpoint
endpoint, Action
action) DocOptions
docOpts =
    let api :: API
api =
          Proxy (Verb method status ctypes (Envelope es a))
-> (Endpoint, Action) -> DocOptions -> API
forall k (api :: k).
HasDocs api =>
Proxy api -> (Endpoint, Action) -> DocOptions -> API
docsFor
            (Proxy (Verb method status ctypes (Envelope es a))
forall k (t :: k). Proxy t
Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
            (Endpoint
endpoint, Action
action)
            DocOptions
docOpts
    in API
api API -> (API -> API) -> API
forall a b. a -> (a -> b) -> b
& (HashMap Endpoint Action -> Identity (HashMap Endpoint Action))
-> API -> Identity API
Lens' API (HashMap Endpoint Action)
apiEndpoints ((HashMap Endpoint Action -> Identity (HashMap Endpoint Action))
 -> API -> Identity API)
-> (([(Text, MediaType, ByteString)]
     -> Identity [(Text, MediaType, ByteString)])
    -> HashMap Endpoint Action -> Identity (HashMap Endpoint Action))
-> ([(Text, MediaType, ByteString)]
    -> Identity [(Text, MediaType, ByteString)])
-> API
-> Identity API
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Action -> Identity Action)
-> HashMap Endpoint Action -> Identity (HashMap Endpoint Action)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Action -> Identity Action)
 -> HashMap Endpoint Action -> Identity (HashMap Endpoint Action))
-> (([(Text, MediaType, ByteString)]
     -> Identity [(Text, MediaType, ByteString)])
    -> Action -> Identity Action)
-> ([(Text, MediaType, ByteString)]
    -> Identity [(Text, MediaType, ByteString)])
-> HashMap Endpoint Action
-> Identity (HashMap Endpoint Action)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> Identity Response) -> Action -> Identity Action
Lens' Action Response
response ((Response -> Identity Response) -> Action -> Identity Action)
-> (([(Text, MediaType, ByteString)]
     -> Identity [(Text, MediaType, ByteString)])
    -> Response -> Identity Response)
-> ([(Text, MediaType, ByteString)]
    -> Identity [(Text, MediaType, ByteString)])
-> Action
-> Identity Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, MediaType, ByteString)]
 -> Identity [(Text, MediaType, ByteString)])
-> Response -> Identity Response
Lens' Response [(Text, MediaType, ByteString)]
respBody (([(Text, MediaType, ByteString)]
  -> Identity [(Text, MediaType, ByteString)])
 -> API -> Identity API)
-> [(Text, MediaType, ByteString)] -> API -> API
forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~
        Proxy es -> Proxy ctypes -> [(Text, MediaType, ByteString)]
forall k k (list :: k) (ctypes :: k).
CreateRespBodiesFor list ctypes =>
Proxy list -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodiesFor (Proxy es
forall k (t :: k). Proxy t
Proxy :: Proxy es) (Proxy ctypes
forall k (t :: k). Proxy t
Proxy :: Proxy ctypes)

-- | When 'NoThrow' comes before a 'Verb', generate the documentation for
-- the same 'Verb', but returning an @'Envelope' \'[]@.
instance (HasDocs (Verb method status ctypes (Envelope '[] a)))
    => HasDocs (NoThrow :> Verb method status ctypes a) where
  docsFor
    :: Proxy (NoThrow :> Verb method status ctypes a)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor :: Proxy (NoThrow :> Verb method status ctypes a)
-> (Endpoint, Action) -> DocOptions -> API
docsFor Proxy (NoThrow :> Verb method status ctypes a)
Proxy (Endpoint
endpoint, Action
action) DocOptions
docOpts =
    Proxy (Verb method status ctypes (Envelope '[] a))
-> (Endpoint, Action) -> DocOptions -> API
forall k (api :: k).
HasDocs api =>
Proxy api -> (Endpoint, Action) -> DocOptions -> API
docsFor
      (Proxy (Verb method status ctypes (Envelope '[] a))
forall k (t :: k). Proxy t
Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
      (Endpoint
endpoint, Action
action)
      DocOptions
docOpts

-- | Create samples for a given @list@ of types, under given @ctypes@.
--
-- Additional instances of this class should not need to be created.
class CreateRespBodiesFor list ctypes where
  createRespBodiesFor
    :: Proxy list
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]

-- | An empty list of types has no samples.
instance CreateRespBodiesFor '[] ctypes where
  createRespBodiesFor
    :: Proxy '[]
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]
  createRespBodiesFor :: Proxy '[] -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodiesFor Proxy '[]
Proxy Proxy ctypes
Proxy = []

-- | Create a response body for each of the error types.
instance
       ( AllMimeRender ctypes (Envelope '[e] ())
       , CreateRespBodiesFor es ctypes
       , ToSample e
       )
    => CreateRespBodiesFor (e ': es) ctypes where
  createRespBodiesFor
    :: Proxy (e ': es)
    -> Proxy ctypes
    -> [(Text, MediaType, ByteString)]
  createRespBodiesFor :: Proxy (e : es) -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodiesFor Proxy (e : es)
Proxy Proxy ctypes
ctypes =
    Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
forall e (ctypes :: [*]).
(AllMimeRender ctypes (Envelope '[e] ()), ToSample e) =>
Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodyFor (Proxy e
forall k (t :: k). Proxy t
Proxy :: Proxy e) Proxy ctypes
ctypes [(Text, MediaType, ByteString)]
-> [(Text, MediaType, ByteString)]
-> [(Text, MediaType, ByteString)]
forall a. Semigroup a => a -> a -> a
<>
    Proxy es -> Proxy ctypes -> [(Text, MediaType, ByteString)]
forall k k (list :: k) (ctypes :: k).
CreateRespBodiesFor list ctypes =>
Proxy list -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodiesFor (Proxy es
forall k (t :: k). Proxy t
Proxy :: Proxy es) Proxy ctypes
ctypes

-- | Create a sample for a given @e@ under given @ctypes@.
createRespBodyFor
  :: forall e ctypes.
     (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)
  => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodyFor :: Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
createRespBodyFor Proxy e
Proxy Proxy ctypes
ctypes = ((Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)])
-> [(Text, Envelope '[e] ())] -> [(Text, MediaType, ByteString)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]
enc [(Text, Envelope '[e] ())]
samples
    where
      samples :: [(Text, Envelope '[e] ())]
      samples :: [(Text, Envelope '[e] ())]
samples = (e -> Envelope '[e] ()) -> (Text, e) -> (Text, Envelope '[e] ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Envelope '[e] ()
forall e (es :: [*]) a. IsMember e es => e -> Envelope es a
toErrEnvelope ((Text, e) -> (Text, Envelope '[e] ()))
-> [(Text, e)] -> [(Text, Envelope '[e] ())]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy e -> [(Text, e)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy e
forall k (t :: k). Proxy t
Proxy :: Proxy e)

      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]
      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]
enc (Text
t, Envelope '[e] ()
s) = (MediaType -> ByteString -> (Text, MediaType, ByteString))
-> (MediaType, ByteString) -> (Text, MediaType, ByteString)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text
t,,) ((MediaType, ByteString) -> (Text, MediaType, ByteString))
-> [(MediaType, ByteString)] -> [(Text, MediaType, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy ctypes -> Envelope '[e] () -> [(MediaType, ByteString)]
forall (list :: [*]) a.
AllMimeRender list a =>
Proxy list -> a -> [(MediaType, ByteString)]
allMimeRender Proxy ctypes
ctypes Envelope '[e] ()
s

-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
-- @e@ onto the @es@.
instance (HasDocs (Throwing (Snoc es e) :> api)) =>
    HasDocs (Throwing es :> Throws e :> api) where
  docsFor
    :: Proxy (Throwing es :> Throws e :> api)
    -> (Endpoint, Action)
    -> DocOptions
    -> API
  docsFor :: Proxy (Throwing es :> (Throws e :> api))
-> (Endpoint, Action) -> DocOptions -> API
docsFor Proxy (Throwing es :> (Throws e :> api))
Proxy =
    Proxy (Throwing (Snoc es e) :> api)
-> (Endpoint, Action) -> DocOptions -> API
forall k (api :: k).
HasDocs api =>
Proxy api -> (Endpoint, Action) -> DocOptions -> API
docsFor (Proxy (Throwing (Snoc es e) :> api)
forall k (t :: k). Proxy t
Proxy :: Proxy (Throwing (Snoc es e) :> api))

-- | We can generate a sample of an @'Envelope' es a@ as long as there is a way
-- to generate a sample of the @a@.
--
-- This doesn't need to worry about generating a sample of @es@, because that is
-- taken care of in the 'HasDocs' instance for @'Throwing' es@.
instance ToSample a => ToSample (Envelope es a) where
  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]
  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]
toSamples Proxy (Envelope es a)
Proxy = (a -> Envelope es a) -> (Text, a) -> (Text, Envelope es a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Envelope es a
forall a (es :: [*]). a -> Envelope es a
toSuccEnvelope ((Text, a) -> (Text, Envelope es a))
-> [(Text, a)] -> [(Text, Envelope es a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy a -> [(Text, a)]
forall a. ToSample a => Proxy a -> [(Text, a)]
toSamples (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)