added Servant.Utils.StaticFiles.serveDocumentation
This commit is contained in:
parent
fc3c2c4128
commit
82ff0a6ad7
6 changed files with 139 additions and 69 deletions
|
@ -53,6 +53,7 @@ library
|
|||
, transformers
|
||||
, template-haskell
|
||||
, text
|
||||
, system-filepath
|
||||
, lens
|
||||
, unordered-containers
|
||||
, hashable
|
||||
|
|
|
@ -4,6 +4,7 @@ module Servant.API.Raw where
|
|||
|
||||
import Data.Proxy
|
||||
import Network.Wai
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
-- | Endpoint for plugging in your own Wai 'Application's.
|
||||
|
@ -16,3 +17,7 @@ instance HasServer Raw where
|
|||
type Server Raw = Application
|
||||
route Proxy rawApplication request respond =
|
||||
rawApplication request (respond . succeedWith)
|
||||
|
||||
instance HasDocs Raw where
|
||||
docsFor _proxy (endpoint, action) =
|
||||
single endpoint action
|
||||
|
|
|
@ -85,7 +85,7 @@
|
|||
-- > main = printMarkdown greetDocs
|
||||
module Servant.Docs
|
||||
( -- * 'HasDocs' class and key functions
|
||||
HasDocs(..), docs, printMarkdown
|
||||
HasDocs(..), docs, markdown, printMarkdown
|
||||
|
||||
, -- * Classes you need to implement for your types
|
||||
ToSample(..), ToParam(..), ToCapture(..)
|
||||
|
@ -106,7 +106,6 @@ module Servant.Docs
|
|||
) where
|
||||
|
||||
import Control.Lens hiding (Action)
|
||||
import Control.Monad (when)
|
||||
import Data.Aeson
|
||||
import Data.ByteString.Lazy.Char8 (ByteString)
|
||||
import Data.Hashable
|
||||
|
@ -114,9 +113,9 @@ import Data.HashMap.Strict (HashMap)
|
|||
import Data.List
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import GHC.Generics
|
||||
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
|
||||
-- | Supported HTTP request methods
|
||||
|
@ -349,69 +348,80 @@ class ToCapture c where
|
|||
-- | Print documentation in Markdown format for
|
||||
-- the given 'API', on standard output.
|
||||
printMarkdown :: API -> IO ()
|
||||
printMarkdown = imapM_ printEndpoint
|
||||
printMarkdown = print . markdown
|
||||
|
||||
where printEndpoint endpoint action = do
|
||||
putStrLn $ str
|
||||
putStrLn $ replicate len '-'
|
||||
putStrLn ""
|
||||
capturesStr (action ^. captures)
|
||||
paramsStr (action ^. params)
|
||||
rqbodyStr (action ^. rqbody)
|
||||
responseStr (action ^. response)
|
||||
markdown :: API -> String
|
||||
markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
|
||||
|
||||
where printEndpoint :: Endpoint -> Action -> [String]
|
||||
printEndpoint endpoint action =
|
||||
str :
|
||||
replicate len '-' :
|
||||
"" :
|
||||
capturesStr (action ^. captures) ++
|
||||
paramsStr (action ^. params) ++
|
||||
rqbodyStr (action ^. rqbody) ++
|
||||
responseStr (action ^. response) ++
|
||||
[]
|
||||
|
||||
where str = show (endpoint^.method) ++ " " ++ endpoint^.path
|
||||
len = length str
|
||||
|
||||
capturesStr :: [DocCapture] -> IO ()
|
||||
capturesStr [] = return ()
|
||||
capturesStr l = do
|
||||
putStrLn "**Captures**: "
|
||||
putStrLn ""
|
||||
mapM_ captureStr l
|
||||
putStrLn ""
|
||||
capturesStr :: [DocCapture] -> [String]
|
||||
capturesStr [] = []
|
||||
capturesStr l =
|
||||
"**Captures**: " :
|
||||
"" :
|
||||
map captureStr l ++
|
||||
"" :
|
||||
[]
|
||||
captureStr cap =
|
||||
putStrLn $ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
|
||||
"- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
|
||||
|
||||
paramsStr :: [DocQueryParam] -> IO ()
|
||||
paramsStr [] = return ()
|
||||
paramsStr l = do
|
||||
putStrLn "**GET Parameters**: "
|
||||
putStrLn ""
|
||||
mapM_ paramStr l
|
||||
putStrLn ""
|
||||
paramStr param = do
|
||||
putStrLn $ " - " ++ param ^. paramName
|
||||
when (not (null values) || param ^. paramKind /= Flag) $
|
||||
putStrLn $ " - **Values**: *" ++ intercalate ", " values ++ "*"
|
||||
putStrLn $ " - **Description**: " ++ param ^. paramDesc
|
||||
when (param ^. paramKind == List) $
|
||||
putStrLn $ " - This parameter is a **list**. All GET parameters with the name "
|
||||
++ param ^. paramName ++ "[] will forward their values in a list to the handler."
|
||||
when (param ^. paramKind == Flag) $
|
||||
putStrLn $ " - This parameter is a **flag**. This means no value is expected to be associated to this parameter."
|
||||
paramsStr :: [DocQueryParam] -> [String]
|
||||
paramsStr [] = []
|
||||
paramsStr l =
|
||||
"**GET Parameters**: " :
|
||||
"" :
|
||||
map paramStr l ++
|
||||
"" :
|
||||
[]
|
||||
paramStr param = unlines $
|
||||
(" - " ++ param ^. paramName) :
|
||||
(if (not (null values) || param ^. paramKind /= Flag)
|
||||
then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
|
||||
else []) ++
|
||||
(" - **Description**: " ++ param ^. paramDesc) :
|
||||
(if (param ^. paramKind == List)
|
||||
then [" - This parameter is a **list**. All GET parameters with the name "
|
||||
++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
|
||||
else []) ++
|
||||
(if (param ^. paramKind == Flag)
|
||||
then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
|
||||
else []) ++
|
||||
[]
|
||||
|
||||
where values = param ^. paramValues
|
||||
|
||||
rqbodyStr :: Maybe ByteString -> IO ()
|
||||
rqbodyStr Nothing = return ()
|
||||
rqbodyStr (Just b) = do
|
||||
putStrLn "**Request Body**: "
|
||||
rqbodyStr :: Maybe ByteString -> [String]
|
||||
rqbodyStr Nothing = []
|
||||
rqbodyStr (Just b) =
|
||||
"**Request Body**: " :
|
||||
jsonStr b
|
||||
|
||||
jsonStr b = do
|
||||
putStrLn ""
|
||||
putStrLn "``` javascript"
|
||||
LB.putStrLn b
|
||||
putStrLn "```"
|
||||
putStrLn ""
|
||||
|
||||
responseStr :: Response -> IO ()
|
||||
responseStr resp = do
|
||||
putStrLn $ "**Response**: "
|
||||
putStrLn $ ""
|
||||
putStrLn $ " - Status code " ++ show (resp ^. respStatus)
|
||||
resp ^. respBody &
|
||||
maybe (putStrLn " - No response body\n")
|
||||
(\b -> putStrLn " - Response body as below." >> jsonStr b)
|
||||
jsonStr b =
|
||||
"" :
|
||||
"``` javascript" :
|
||||
cs b :
|
||||
"```" :
|
||||
"" :
|
||||
[]
|
||||
|
||||
responseStr :: Response -> [String]
|
||||
responseStr resp =
|
||||
"**Response**: " :
|
||||
"" :
|
||||
(" - Status code " ++ show (resp ^. respStatus)) :
|
||||
(resp ^. respBody &
|
||||
maybe [" - No response body\n"]
|
||||
(\b -> " - Response body as below." : jsonStr b))
|
||||
|
|
|
@ -1,11 +1,33 @@
|
|||
module Servant.Utils.StaticFiles where
|
||||
module Servant.Utils.StaticFiles (
|
||||
serveDirectory,
|
||||
serveDocumentation,
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Application.Static
|
||||
|
||||
import Servant.API
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
serveDirectory :: FilePath -> Server Raw
|
||||
serveDirectory documentRoot =
|
||||
staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))
|
||||
|
||||
serveDocumentation :: HasDocs api => Proxy api -> Server Raw
|
||||
serveDocumentation proxy _request respond =
|
||||
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
||||
|
||||
toHtml :: String -> String
|
||||
toHtml markdown =
|
||||
"<html>" ++
|
||||
"<body>" ++
|
||||
"<verbatim>" ++
|
||||
markdown ++
|
||||
"</verbatim>" ++
|
||||
"</body>" ++
|
||||
"</html>"
|
||||
|
|
|
@ -29,6 +29,7 @@ import Servant.API.QueryParam
|
|||
import Servant.API.Raw
|
||||
import Servant.API.Sub
|
||||
import Servant.API.Alternative
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
|
||||
|
||||
|
@ -42,6 +43,8 @@ data Person = Person {
|
|||
|
||||
instance ToJSON Person
|
||||
instance FromJSON Person
|
||||
instance ToSample Person where
|
||||
toSample _proxy = Just $ encode alice
|
||||
|
||||
alice :: Person
|
||||
alice = Person "Alice" 42
|
||||
|
|
|
@ -1,29 +1,51 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Utils.StaticFilesSpec where
|
||||
|
||||
import Test.Hspec hiding (pending)
|
||||
import System.IO.Temp
|
||||
import Test.Hspec.Wai
|
||||
import Network.Wai
|
||||
import Data.Proxy
|
||||
import System.Directory
|
||||
import Control.Exception
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Network.Wai
|
||||
import Network.Wai.Test
|
||||
import System.Directory
|
||||
import System.IO.Temp
|
||||
import Test.Hspec hiding (pending)
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Servant.Utils.StaticFiles
|
||||
import Servant.API.Sub
|
||||
import Servant.API.Alternative
|
||||
import Servant.API.Capture
|
||||
import Servant.API.Get
|
||||
import Servant.API.Raw
|
||||
import Servant.API.Sub
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
import Servant.ServerSpec
|
||||
import Servant.Utils.StaticFiles
|
||||
|
||||
type Api =
|
||||
"static" :> Raw
|
||||
"dummy_api" :> Capture "person_name" String :> Get Person
|
||||
:<|> "static" :> Raw
|
||||
:<|> "documentation" :> Raw
|
||||
|
||||
instance ToCapture (Capture "person_name" String) where
|
||||
toCapture _proxy = DocCapture "person_name" "person_name_doc"
|
||||
|
||||
api :: Proxy Api
|
||||
api = Proxy
|
||||
|
||||
app :: Application
|
||||
app = serve (Proxy :: Proxy Api) server
|
||||
app = serve api server
|
||||
|
||||
server :: Server Api
|
||||
server = serveDirectory "static"
|
||||
server =
|
||||
(\ name -> return (Person name 42))
|
||||
:<|> serveDirectory "static"
|
||||
:<|> serveDocumentation api
|
||||
|
||||
withStaticFiles :: IO () -> IO ()
|
||||
withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
|
||||
|
@ -42,10 +64,17 @@ withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
|
|||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
around_ withStaticFiles $ with (return app) $
|
||||
around_ withStaticFiles $ with (return app) $ do
|
||||
describe "serveDirectory" $ do
|
||||
it "successfully serves files" $ do
|
||||
get "/static/foo.txt" `shouldRespondWith` "bar"
|
||||
|
||||
it "serves the contents of index.html when requesting the root of a directory" $ do
|
||||
get "/static" `shouldRespondWith` "index"
|
||||
|
||||
describe "serveDocumentation" $ do
|
||||
it "serves documentation about the expose API" $ do
|
||||
response <- get "/documentation"
|
||||
liftIO $ forM_ ["person_name" :: String, "static", "dummy_api", "person_name_doc"] $
|
||||
\ snippet ->
|
||||
(snippet, cs (simpleBody response)) `shouldSatisfy` uncurry isInfixOf
|
||||
|
|
Loading…
Reference in a new issue