diff --git a/servant.cabal b/servant.cabal index b64dd75d..f5d50313 100644 --- a/servant.cabal +++ b/servant.cabal @@ -53,6 +53,7 @@ library , transformers , template-haskell , text + , system-filepath , lens , unordered-containers , hashable diff --git a/src/Servant/API/Raw.hs b/src/Servant/API/Raw.hs index d26d3855..27e43063 100644 --- a/src/Servant/API/Raw.hs +++ b/src/Servant/API/Raw.hs @@ -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 diff --git a/src/Servant/Docs.hs b/src/Servant/Docs.hs index 765d49dd..beeec4ec 100644 --- a/src/Servant/Docs.hs +++ b/src/Servant/Docs.hs @@ -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 "" + jsonStr b = + "" : + "``` javascript" : + cs b : + "```" : + "" : + [] - 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) - \ No newline at end of file + 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)) diff --git a/src/Servant/Utils/StaticFiles.hs b/src/Servant/Utils/StaticFiles.hs index cdeccffa..8b1c772c 100644 --- a/src/Servant/Utils/StaticFiles.hs +++ b/src/Servant/Utils/StaticFiles.hs @@ -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 = + "" ++ + "" ++ + "" ++ + markdown ++ + "" ++ + "" ++ + "" diff --git a/test/Servant/ServerSpec.hs b/test/Servant/ServerSpec.hs index 38313136..d9f952b3 100644 --- a/test/Servant/ServerSpec.hs +++ b/test/Servant/ServerSpec.hs @@ -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 diff --git a/test/Servant/Utils/StaticFilesSpec.hs b/test/Servant/Utils/StaticFilesSpec.hs index 048ec68d..a269599f 100644 --- a/test/Servant/Utils/StaticFilesSpec.hs +++ b/test/Servant/Utils/StaticFilesSpec.hs @@ -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