added Servant.Utils.StaticFiles.serveDocumentation

This commit is contained in:
Sönke Hahn 2014-11-12 16:58:22 +08:00
parent fc3c2c4128
commit 82ff0a6ad7
6 changed files with 139 additions and 69 deletions

View file

@ -53,6 +53,7 @@ library
, transformers , transformers
, template-haskell , template-haskell
, text , text
, system-filepath
, lens , lens
, unordered-containers , unordered-containers
, hashable , hashable

View file

@ -4,6 +4,7 @@ module Servant.API.Raw where
import Data.Proxy import Data.Proxy
import Network.Wai import Network.Wai
import Servant.Docs
import Servant.Server import Servant.Server
-- | Endpoint for plugging in your own Wai 'Application's. -- | Endpoint for plugging in your own Wai 'Application's.
@ -16,3 +17,7 @@ instance HasServer Raw where
type Server Raw = Application type Server Raw = Application
route Proxy rawApplication request respond = route Proxy rawApplication request respond =
rawApplication request (respond . succeedWith) rawApplication request (respond . succeedWith)
instance HasDocs Raw where
docsFor _proxy (endpoint, action) =
single endpoint action

View file

@ -85,7 +85,7 @@
-- > main = printMarkdown greetDocs -- > main = printMarkdown greetDocs
module Servant.Docs module Servant.Docs
( -- * 'HasDocs' class and key functions ( -- * 'HasDocs' class and key functions
HasDocs(..), docs, printMarkdown HasDocs(..), docs, markdown, printMarkdown
, -- * Classes you need to implement for your types , -- * Classes you need to implement for your types
ToSample(..), ToParam(..), ToCapture(..) ToSample(..), ToParam(..), ToCapture(..)
@ -106,7 +106,6 @@ module Servant.Docs
) where ) where
import Control.Lens hiding (Action) import Control.Lens hiding (Action)
import Control.Monad (when)
import Data.Aeson import Data.Aeson
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Hashable import Data.Hashable
@ -114,9 +113,9 @@ import Data.HashMap.Strict (HashMap)
import Data.List import Data.List
import Data.Monoid import Data.Monoid
import Data.Proxy import Data.Proxy
import Data.String.Conversions
import GHC.Generics import GHC.Generics
import qualified Data.ByteString.Lazy.Char8 as LB
import qualified Data.HashMap.Strict as HM import qualified Data.HashMap.Strict as HM
-- | Supported HTTP request methods -- | Supported HTTP request methods
@ -349,69 +348,80 @@ class ToCapture c where
-- | Print documentation in Markdown format for -- | Print documentation in Markdown format for
-- the given 'API', on standard output. -- the given 'API', on standard output.
printMarkdown :: API -> IO () printMarkdown :: API -> IO ()
printMarkdown = imapM_ printEndpoint printMarkdown = print . markdown
where printEndpoint endpoint action = do markdown :: API -> String
putStrLn $ str markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
putStrLn $ replicate len '-'
putStrLn "" where printEndpoint :: Endpoint -> Action -> [String]
capturesStr (action ^. captures) printEndpoint endpoint action =
paramsStr (action ^. params) str :
rqbodyStr (action ^. rqbody) replicate len '-' :
responseStr (action ^. response) "" :
capturesStr (action ^. captures) ++
paramsStr (action ^. params) ++
rqbodyStr (action ^. rqbody) ++
responseStr (action ^. response) ++
[]
where str = show (endpoint^.method) ++ " " ++ endpoint^.path where str = show (endpoint^.method) ++ " " ++ endpoint^.path
len = length str len = length str
capturesStr :: [DocCapture] -> IO () capturesStr :: [DocCapture] -> [String]
capturesStr [] = return () capturesStr [] = []
capturesStr l = do capturesStr l =
putStrLn "**Captures**: " "**Captures**: " :
putStrLn "" "" :
mapM_ captureStr l map captureStr l ++
putStrLn "" "" :
[]
captureStr cap = captureStr cap =
putStrLn $ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc) "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
paramsStr :: [DocQueryParam] -> IO () paramsStr :: [DocQueryParam] -> [String]
paramsStr [] = return () paramsStr [] = []
paramsStr l = do paramsStr l =
putStrLn "**GET Parameters**: " "**GET Parameters**: " :
putStrLn "" "" :
mapM_ paramStr l map paramStr l ++
putStrLn "" "" :
paramStr param = do []
putStrLn $ " - " ++ param ^. paramName paramStr param = unlines $
when (not (null values) || param ^. paramKind /= Flag) $ (" - " ++ param ^. paramName) :
putStrLn $ " - **Values**: *" ++ intercalate ", " values ++ "*" (if (not (null values) || param ^. paramKind /= Flag)
putStrLn $ " - **Description**: " ++ param ^. paramDesc then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
when (param ^. paramKind == List) $ else []) ++
putStrLn $ " - This parameter is a **list**. All GET parameters with the name " (" - **Description**: " ++ param ^. paramDesc) :
++ param ^. paramName ++ "[] will forward their values in a list to the handler." (if (param ^. paramKind == List)
when (param ^. paramKind == Flag) $ then [" - This parameter is a **list**. All GET parameters with the name "
putStrLn $ " - This parameter is a **flag**. This means no value is expected to be associated to this parameter." ++ 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 where values = param ^. paramValues
rqbodyStr :: Maybe ByteString -> IO () rqbodyStr :: Maybe ByteString -> [String]
rqbodyStr Nothing = return () rqbodyStr Nothing = []
rqbodyStr (Just b) = do rqbodyStr (Just b) =
putStrLn "**Request Body**: " "**Request Body**: " :
jsonStr b jsonStr b
jsonStr b = do jsonStr b =
putStrLn "" "" :
putStrLn "``` javascript" "``` javascript" :
LB.putStrLn b cs 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)
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))

View file

@ -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 Filesystem.Path.CurrentOS (decodeString)
import Network.HTTP.Types
import Network.Wai
import Network.Wai.Application.Static import Network.Wai.Application.Static
import Servant.API import Servant.API
import Servant.Docs
import Servant.Server import Servant.Server
serveDirectory :: FilePath -> Server Raw serveDirectory :: FilePath -> Server Raw
serveDirectory documentRoot = serveDirectory documentRoot =
staticApp (defaultFileServerSettings (decodeString (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>"

View file

@ -29,6 +29,7 @@ import Servant.API.QueryParam
import Servant.API.Raw import Servant.API.Raw
import Servant.API.Sub import Servant.API.Sub
import Servant.API.Alternative import Servant.API.Alternative
import Servant.Docs
import Servant.Server import Servant.Server
@ -42,6 +43,8 @@ data Person = Person {
instance ToJSON Person instance ToJSON Person
instance FromJSON Person instance FromJSON Person
instance ToSample Person where
toSample _proxy = Just $ encode alice
alice :: Person alice :: Person
alice = Person "Alice" 42 alice = Person "Alice" 42

View file

@ -1,29 +1,51 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.Utils.StaticFilesSpec where 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 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.Alternative
import Servant.API.Sub import Servant.API.Capture
import Servant.API.Get
import Servant.API.Raw import Servant.API.Raw
import Servant.API.Sub
import Servant.Docs
import Servant.Server import Servant.Server
import Servant.ServerSpec
import Servant.Utils.StaticFiles
type Api = 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 :: Application
app = serve (Proxy :: Proxy Api) server app = serve api server
server :: Server Api server :: Server Api
server = serveDirectory "static" server =
(\ name -> return (Person name 42))
:<|> serveDirectory "static"
:<|> serveDocumentation api
withStaticFiles :: IO () -> IO () withStaticFiles :: IO () -> IO ()
withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
@ -42,10 +64,17 @@ withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
spec :: Spec spec :: Spec
spec = do spec = do
around_ withStaticFiles $ with (return app) $ around_ withStaticFiles $ with (return app) $ do
describe "serveDirectory" $ do describe "serveDirectory" $ do
it "successfully serves files" $ do it "successfully serves files" $ do
get "/static/foo.txt" `shouldRespondWith` "bar" get "/static/foo.txt" `shouldRespondWith` "bar"
it "serves the contents of index.html when requesting the root of a directory" $ do it "serves the contents of index.html when requesting the root of a directory" $ do
get "/static" `shouldRespondWith` "index" 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