added Servant.Utils.StaticFiles.serveDocumentation

servant.cabal

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

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

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
+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
                 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 =
-          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
 
-        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 = do
+        jsonStr b =
-          putStrLn ""
+          "" :
-          putStrLn "``` javascript"
+          "``` javascript" :
-          LB.putStrLn b
+          cs b :
-          putStrLn "```"
+          "```" :
-          putStrLn ""
+          "" :
+          []
 
-        responseStr :: Response -> IO ()
+        responseStr :: Response -> [String]
-        responseStr resp = do
+        responseStr resp =
-          putStrLn $ "**Response**: "
+          "**Response**: " :
-          putStrLn $ ""
+          "" :
-          putStrLn $ " - Status code " ++ show (resp ^. respStatus)
+          (" - Status code " ++ show (resp ^. respStatus)) :
-          resp ^. respBody &
+          (resp ^. respBody &
-            maybe (putStrLn " - No response body\n")
+            maybe [" - No response body\n"]
-                  (\b -> putStrLn " - Response body as below." >> jsonStr b)
+                  (\b -> " - Response body as below." : jsonStr 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 =
+  "<html>" ++
+  "<body>" ++
+  "<verbatim>" ++
+  markdown ++
+  "</verbatim>" ++
+  "</body>" ++
+  "</html>"

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

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.Alternative
-import Servant.API.Sub
+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