Merge pull request #35 from alpmestan/static_files_shahn

Static files shahn

servant.cabal

@@ -33,6 +33,7 @@ library
     Servant.Server
     Servant.Utils.ApiQuasiQuoting
     Servant.Utils.Links
+    Servant.Utils.StaticFiles
   build-depends:
       base >=4.7 && <5
     , either
@@ -46,15 +47,18 @@ library
     , http-types
     , network-uri >= 2.6
     , wai
+    , wai-app-static
     , warp
     , parsec
     , safe
     , transformers
     , template-haskell
     , text
+    , system-filepath
     , lens
     , unordered-containers
     , hashable
+    , system-filepath
   hs-source-dirs: src
   default-language: Haskell2010
   ghc-options: -O0 -Wall
@@ -85,6 +89,7 @@ test-suite spec
     , aeson
     , bytestring
     , deepseq
+    , directory
     , either
     , exceptions
     , hspec == 2.*
@@ -96,6 +101,7 @@ test-suite spec
     , parsec
     , servant
     , string-conversions
+    , temporary
     , text
     , transformers
     , wai

src/Servant.hs

@@ -12,6 +12,10 @@ module Servant (
   module Servant.Docs,
   -- | Helper module
   module Servant.Common.Text,
+  -- | Utilities on top of the servant core
+  module Servant.Utils.ApiQuasiQuoting,
+  module Servant.Utils.Links,
+  module Servant.Utils.StaticFiles,
   -- | Useful re-exports
   Proxy(..),
   ) where
@@ -23,3 +27,6 @@ import Servant.Common.BaseUrl
 import Servant.Common.Text
 import Servant.Docs
 import Servant.Server
+import Servant.Utils.ApiQuasiQuoting
+import Servant.Utils.Links
+import Servant.Utils.StaticFiles

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
-          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))

src/Servant/Utils/StaticFiles.hs

@@ -0,0 +1,33 @@
+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

@@ -0,0 +1,80 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Servant.Utils.StaticFilesSpec where
+
+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.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 =
+       "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 api server
+
+server :: Server Api
+server =
+       (\ name -> return (Person name 42))
+  :<|> serveDirectory "static"
+  :<|> serveDocumentation api
+
+withStaticFiles :: IO () -> IO ()
+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
+  bracket (setup tmpDir) teardown (const action)
+ where
+  setup tmpDir = do
+    outer <- getCurrentDirectory
+    setCurrentDirectory tmpDir
+    createDirectory "static"
+    writeFile "static/foo.txt" "bar"
+    writeFile "static/index.html" "index"
+    return outer
+
+  teardown outer = do
+    setCurrentDirectory outer
+
+spec :: Spec
+spec = do
+  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