Add initial mockup of general extra info API

This commit is contained in:
Christian Marie 2015-02-07 15:17:39 +11:00
parent 2ea8a48eff
commit a008e08dd1
2 changed files with 69 additions and 4 deletions

View file

@ -78,6 +78,14 @@ type TestApi =
testApi :: Proxy TestApi testApi :: Proxy TestApi
testApi = Proxy testApi = Proxy
extras :: ExtraInfo TestApi
extras =
safeInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $
defAction & headers <>~ ["unicorns"]
& notes <>~ [ DocNote "Title" ["This is some text"]
, DocNote "Second secton" ["And some more"]
]
-- Generate the data that lets us have API docs. This -- Generate the data that lets us have API docs. This
-- is derived from the type as well as from -- is derived from the type as well as from
-- the 'ToCapture', 'ToParam' and 'ToSample' instances from above. -- the 'ToCapture', 'ToParam' and 'ToSample' instances from above.
@ -86,7 +94,7 @@ testApi = Proxy
-- --
-- > docs testAPI -- > docs testAPI
docsGreet :: API docsGreet :: API
docsGreet = docsWithIntros [intro1, intro2] testApi docsGreet = docsWith [intro1, intro2] extras testApi
main :: IO () main :: IO ()
main = putStrLn $ markdown docsGreet main = putStrLn $ markdown docsGreet

View file

@ -8,6 +8,9 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE PolyKinds #-}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- | This module lets you get API docs for free. It lets generate -- | This module lets you get API docs for free. It lets generate
@ -128,7 +131,9 @@
-- > main = putStrLn $ markdown docsGreet -- > main = putStrLn $ markdown docsGreet
module Servant.Docs module Servant.Docs
( -- * 'HasDocs' class and key functions ( -- * 'HasDocs' class and key functions
HasDocs(..), docs, docsWithIntros, markdown HasDocs(..), docs, markdown
-- * Generating docs with extra information
, ExtraInfo(..), docsWith, docsWithIntros, safeInfo
, -- * Classes you need to implement for your types , -- * Classes you need to implement for your types
ToSample(..) ToSample(..)
@ -169,7 +174,9 @@ import Data.Text (Text, pack, unpack)
import Data.String.Conversions import Data.String.Conversions
import GHC.Generics import GHC.Generics
import GHC.TypeLits import GHC.TypeLits
import GHC.Exts(Constraint)
import Servant.API import Servant.API
import Servant.Utils.Links
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T import qualified Data.Text as T
@ -343,12 +350,21 @@ data Action = Action
{ _captures :: [DocCapture] -- type collected + user supplied info { _captures :: [DocCapture] -- type collected + user supplied info
, _headers :: [Text] -- type collected , _headers :: [Text] -- type collected
, _params :: [DocQueryParam] -- type collected + user supplied info , _params :: [DocQueryParam] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
, _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied
, _rqbody :: Maybe ByteString -- user supplied , _rqbody :: Maybe ByteString -- user supplied
, _response :: Response -- user supplied , _response :: Response -- user supplied
} deriving (Eq, Show) } deriving (Eq, Show)
-- | Combine two Actions, we can't make a monoid as merging Response breaks the
-- laws.
--
-- As such, we invent a non-commutative, left associative operation
-- 'combineAction' to mush two together taking the response from the very left.
combineAction :: Action -> Action -> Action
Action c h p m n r resp `combineAction` Action c' h' p' m' n' r' _ =
Action (c <> c') (h <> h') (p <> p') (m <> m') (n <> n') (r <> r') resp
-- Default 'Action'. Has no 'captures', no GET 'params', expects -- Default 'Action'. Has no 'captures', no GET 'params', expects
-- no request body ('rqbody') and the typical response is 'defResponse'. -- no request body ('rqbody') and the typical response is 'defResponse'.
-- --
@ -389,10 +405,51 @@ makeLenses ''Action
docs :: HasDocs layout => Proxy layout -> API docs :: HasDocs layout => Proxy layout -> API
docs p = docsFor p (defEndpoint, defAction) docs p = docsFor p (defEndpoint, defAction)
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action)
instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b =
ExtraInfo $ HM.unionWith combineAction a b
-- | Closed type family, check if endpoint is exactly within API.
-- We aren't sure what affects how an Endpoint is built up, so we require an
-- exact match.
type family IsIn (endpoint :: *) (api :: *) :: Constraint where
IsIn e (sa :<|> sb) = Or (IsIn e sa) (IsIn e sb)
IsIn (e :> sa) (e :> sb) = IsIn sa sb
IsIn e e = ()
safeInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout
safeInfo p action =
let api = docsFor p (defEndpoint, defAction)
-- Assume one endpoint, HasLink constraint means that we should only ever
-- point at one endpoint.
in ExtraInfo $ api ^. apiEndpoints & traversed .~ action
-- | Generate documentation given some initial state, in which you may wish to
-- note that certain endpoints are special in some way.
--
-- If you only want to add an introduction, use 'docsWithIntros'.
--
-- You are expected to build up the SafeMap with safeEntry
docsWith :: HasDocs layout
=> [DocIntro]
-> ExtraInfo layout
-> Proxy layout
-> API
docsWith intros (ExtraInfo endpoints) p =
docs p & apiIntros <>~ intros
& apiEndpoints %~ HM.unionWith combineAction endpoints
-- | Generate the docs for a given API that implements 'HasDocs' with with any -- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API
docsWithIntros intros p = docs p & apiIntros <>~ intros docsWithIntros intros = docsWith intros mempty
-- | The class that abstracts away the impact of API combinators -- | The class that abstracts away the impact of API combinators
-- on documentation generation. -- on documentation generation.