git.iko.soy/typeable/servant
on master help sign in
Merge pull request #35 from alpmestan/static_files_shahn

Static files shahn

commite7b72561ee322b894977872bac2387ca953b2779 authorAlp Mestanogullari <alpmestan@gmail.com> dateFri 14 Nov 2014, 11:12 (12 years ago) parentd8ab4ec82ff0a6
7 files changed+203−59
compare with master
unifiedsplit
servant.cabal+6 src/Servant.hs+7 src/Servant/API/Raw.hs+5 src/Servant/Docs.hs+69−59 src/Servant/Utils/StaticFiles.hs+33 test/Servant/ServerSpec.hs+3 test/Servant/Utils/StaticFilesSpec.hs+80
servant.cabal+6
@@ -33,6 +33,7 @@ library
3333 Servant.Server
3434 Servant.Utils.ApiQuasiQuoting
3535 Servant.Utils.Links
36+ Servant.Utils.StaticFiles
3637 build-depends:
3738 base >=4.7 && <5
3839 , either
@@ -46,15 +47,18 @@ library
4647 , http-types
4748 , network-uri >= 2.6
4849 , wai
50+ , wai-app-static
4951 , warp
5052 , parsec
5153 , safe
5254 , transformers
5355 , template-haskell
5456 , text
57+ , system-filepath
5558 , lens
5659 , unordered-containers
5760 , hashable
61+ , system-filepath
5862 hs-source-dirs: src
5963 default-language: Haskell2010
6064 ghc-options: -O0 -Wall
@@ -85,6 +89,7 @@ test-suite spec
8589 , aeson
8690 , bytestring
8791 , deepseq
92+ , directory
8893 , either
8994 , exceptions
9095 , hspec == 2.*
@@ -96,6 +101,7 @@ test-suite spec
96101 , parsec
97102 , servant
98103 , string-conversions
104+ , temporary
99105 , text
100106 , transformers
101107 , wai
src/Servant.hs+7
@@ -12,6 +12,10 @@ module Servant (
1212 module Servant.Docs,
1313 -- | Helper module
1414 module Servant.Common.Text,
15+ -- | Utilities on top of the servant core
16+ module Servant.Utils.ApiQuasiQuoting,
17+ module Servant.Utils.Links,
18+ module Servant.Utils.StaticFiles,
1519 -- | Useful re-exports
1620 Proxy(..),
1721 ) where
@@ -23,3 +27,6 @@ import Servant.Common.BaseUrl
2327import Servant.Common.Text
2428import Servant.Docs
2529import Servant.Server
30+import Servant.Utils.ApiQuasiQuoting
31+import Servant.Utils.Links
32+import Servant.Utils.StaticFiles
src/Servant/API/Raw.hs+5
@@ -4,6 +4,7 @@ module Servant.API.Raw where
44
55import Data.Proxy
66import Network.Wai
7+import Servant.Docs
78import Servant.Server
89
910-- | Endpoint for plugging in your own Wai 'Application's.
@@ -16,3 +17,7 @@ instance HasServer Raw where
1617 type Server Raw = Application
1718 route Proxy rawApplication request respond =
1819 rawApplication request (respond . succeedWith)
20+
21+instance HasDocs Raw where
22+ docsFor _proxy (endpoint, action) =
23+ single endpoint action
src/Servant/Docs.hs+69−59
@@ -85,7 +85,7 @@
8585-- > main = printMarkdown greetDocs
8686module Servant.Docs
8787 ( -- * 'HasDocs' class and key functions
88− HasDocs(..), docs, printMarkdown
88+ HasDocs(..), docs, markdown, printMarkdown
8989
9090 , -- * Classes you need to implement for your types
9191 ToSample(..), ToParam(..), ToCapture(..)
@@ -106,7 +106,6 @@ module Servant.Docs
106106 ) where
107107
108108import Control.Lens hiding (Action)
109−import Control.Monad (when)
110109import Data.Aeson
111110import Data.ByteString.Lazy.Char8 (ByteString)
112111import Data.Hashable
@@ -114,9 +113,9 @@ import Data.HashMap.Strict (HashMap)
114113import Data.List
115114import Data.Monoid
116115import Data.Proxy
116+import Data.String.Conversions
117117import GHC.Generics
118118
119−import qualified Data.ByteString.Lazy.Char8 as LB
120119import qualified Data.HashMap.Strict as HM
121120
122121-- | Supported HTTP request methods
@@ -349,69 +348,80 @@ class ToCapture c where
349348-- | Print documentation in Markdown format for
350349-- the given 'API', on standard output.
351350printMarkdown :: API -> IO ()
352−printMarkdown = imapM_ printEndpoint
353−
354− where printEndpoint endpoint action = do
355− putStrLn $ str
356− putStrLn $ replicate len '-'
357− putStrLn ""
358− capturesStr (action ^. captures)
359− paramsStr (action ^. params)
360− rqbodyStr (action ^. rqbody)
361− responseStr (action ^. response)
351+printMarkdown = print . markdown
352+
353+markdown :: API -> String
354+markdown = unlines . concat . map (uncurry printEndpoint) . HM.toList
355+
356+ where printEndpoint :: Endpoint -> Action -> [String]
357+ printEndpoint endpoint action =
358+ str :
359+ replicate len '-' :
360+ "" :
361+ capturesStr (action ^. captures) ++
362+ paramsStr (action ^. params) ++
363+ rqbodyStr (action ^. rqbody) ++
364+ responseStr (action ^. response) ++
365+ []
362366
363367 where str = show (endpoint^.method) ++ " " ++ endpoint^.path
364368 len = length str
365369
366− capturesStr :: [DocCapture] -> IO ()
367− capturesStr [] = return ()
368− capturesStr l = do
369− putStrLn "**Captures**: "
370− putStrLn ""
371− mapM_ captureStr l
372− putStrLn ""
370+ capturesStr :: [DocCapture] -> [String]
371+ capturesStr [] = []
372+ capturesStr l =
373+ "**Captures**: " :
374+ "" :
375+ map captureStr l ++
376+ "" :
377+ []
373378 captureStr cap =
374− putStrLn $ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
375−
376− paramsStr :: [DocQueryParam] -> IO ()
377− paramsStr [] = return ()
378− paramsStr l = do
379− putStrLn "**GET Parameters**: "
380− putStrLn ""
381− mapM_ paramStr l
382− putStrLn ""
383− paramStr param = do
384− putStrLn $ " - " ++ param ^. paramName
385− when (not (null values) || param ^. paramKind /= Flag) $
386− putStrLn $ " - **Values**: *" ++ intercalate ", " values ++ "*"
387− putStrLn $ " - **Description**: " ++ param ^. paramDesc
388− when (param ^. paramKind == List) $
389− putStrLn $ " - This parameter is a **list**. All GET parameters with the name "
390− ++ param ^. paramName ++ "[] will forward their values in a list to the handler."
391− when (param ^. paramKind == Flag) $
392− putStrLn $ " - This parameter is a **flag**. This means no value is expected to be associated to this parameter."
379+ "- *" ++ (cap ^. capSymbol) ++ "*: " ++ (cap ^. capDesc)
380+
381+ paramsStr :: [DocQueryParam] -> [String]
382+ paramsStr [] = []
383+ paramsStr l =
384+ "**GET Parameters**: " :
385+ "" :
386+ map paramStr l ++
387+ "" :
388+ []
389+ paramStr param = unlines $
390+ (" - " ++ param ^. paramName) :
391+ (if (not (null values) || param ^. paramKind /= Flag)
392+ then [" - **Values**: *" ++ intercalate ", " values ++ "*"]
393+ else []) ++
394+ (" - **Description**: " ++ param ^. paramDesc) :
395+ (if (param ^. paramKind == List)
396+ then [" - This parameter is a **list**. All GET parameters with the name "
397+ ++ param ^. paramName ++ "[] will forward their values in a list to the handler."]
398+ else []) ++
399+ (if (param ^. paramKind == Flag)
400+ then [" - This parameter is a **flag**. This means no value is expected to be associated to this parameter."]
401+ else []) ++
402+ []
393403
394404 where values = param ^. paramValues
395405
396− rqbodyStr :: Maybe ByteString -> IO ()
397− rqbodyStr Nothing = return ()
398− rqbodyStr (Just b) = do
399− putStrLn "**Request Body**: "
406+ rqbodyStr :: Maybe ByteString -> [String]
407+ rqbodyStr Nothing = []
408+ rqbodyStr (Just b) =
409+ "**Request Body**: " :
400410 jsonStr b
401411
402− jsonStr b = do
403− putStrLn ""
404− putStrLn "``` javascript"
405− LB.putStrLn b
406− putStrLn "```"
407− putStrLn ""
408−
409− responseStr :: Response -> IO ()
410− responseStr resp = do
411− putStrLn $ "**Response**: "
412− putStrLn $ ""
413− putStrLn $ " - Status code " ++ show (resp ^. respStatus)
414− resp ^. respBody &
415− maybe (putStrLn " - No response body\n")
416− (\b -> putStrLn " - Response body as below." >> jsonStr b)
417−
412+ jsonStr b =
413+ "" :
414+ "``` javascript" :
415+ cs b :
416+ "```" :
417+ "" :
418+ []
419+
420+ responseStr :: Response -> [String]
421+ responseStr resp =
422+ "**Response**: " :
423+ "" :
424+ (" - Status code " ++ show (resp ^. respStatus)) :
425+ (resp ^. respBody &
426+ maybe [" - No response body\n"]
427+ (\b -> " - Response body as below." : jsonStr b))
src/Servant/Utils/StaticFiles.hsnew file+33
@@ -0,0 +1,33 @@
1+module Servant.Utils.StaticFiles (
2+ serveDirectory,
3+ serveDocumentation,
4+ ) where
5+
6+import Data.Proxy
7+import Data.String.Conversions
8+import Filesystem.Path.CurrentOS (decodeString)
9+import Network.HTTP.Types
10+import Network.Wai
11+import Network.Wai.Application.Static
12+
13+import Servant.API
14+import Servant.Docs
15+import Servant.Server
16+
17+serveDirectory :: FilePath -> Server Raw
18+serveDirectory documentRoot =
19+ staticApp (defaultFileServerSettings (decodeString (documentRoot ++ "/")))
20+
21+serveDocumentation :: HasDocs api => Proxy api -> Server Raw
22+serveDocumentation proxy _request respond =
23+ respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
24+
25+toHtml :: String -> String
26+toHtml markdown =
27+ "<html>" ++
28+ "<body>" ++
29+ "<verbatim>" ++
30+ markdown ++
31+ "</verbatim>" ++
32+ "</body>" ++
33+ "</html>"
test/Servant/ServerSpec.hs+3
@@ -29,6 +29,7 @@ import Servant.API.QueryParam
2929import Servant.API.Raw
3030import Servant.API.Sub
3131import Servant.API.Alternative
32+import Servant.Docs
3233import Servant.Server
3334
3435
@@ -42,6 +43,8 @@ data Person = Person {
4243
4344instance ToJSON Person
4445instance FromJSON Person
46+instance ToSample Person where
47+ toSample _proxy = Just $ encode alice
4548
4649alice :: Person
4750alice = Person "Alice" 42
test/Servant/Utils/StaticFilesSpec.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeOperators #-}
5+{-# OPTIONS_GHC -fno-warn-orphans #-}
6+module Servant.Utils.StaticFilesSpec where
7+
8+import Control.Exception
9+import Data.Foldable
10+import Data.List
11+import Data.Proxy
12+import Data.String.Conversions
13+import Network.Wai
14+import Network.Wai.Test
15+import System.Directory
16+import System.IO.Temp
17+import Test.Hspec hiding (pending)
18+import Test.Hspec.Wai
19+
20+import Servant.API.Alternative
21+import Servant.API.Capture
22+import Servant.API.Get
23+import Servant.API.Raw
24+import Servant.API.Sub
25+import Servant.Docs
26+import Servant.Server
27+import Servant.ServerSpec
28+import Servant.Utils.StaticFiles
29+
30+type Api =
31+ "dummy_api" :> Capture "person_name" String :> Get Person
32+ :<|> "static" :> Raw
33+ :<|> "documentation" :> Raw
34+
35+instance ToCapture (Capture "person_name" String) where
36+ toCapture _proxy = DocCapture "person_name" "person_name_doc"
37+
38+api :: Proxy Api
39+api = Proxy
40+
41+app :: Application
42+app = serve api server
43+
44+server :: Server Api
45+server =
46+ (\ name -> return (Person name 42))
47+ :<|> serveDirectory "static"
48+ :<|> serveDocumentation api
49+
50+withStaticFiles :: IO () -> IO ()
51+withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir ->
52+ bracket (setup tmpDir) teardown (const action)
53+ where
54+ setup tmpDir = do
55+ outer <- getCurrentDirectory
56+ setCurrentDirectory tmpDir
57+ createDirectory "static"
58+ writeFile "static/foo.txt" "bar"
59+ writeFile "static/index.html" "index"
60+ return outer
61+
62+ teardown outer = do
63+ setCurrentDirectory outer
64+
65+spec :: Spec
66+spec = do
67+ around_ withStaticFiles $ with (return app) $ do
68+ describe "serveDirectory" $ do
69+ it "successfully serves files" $ do
70+ get "/static/foo.txt" `shouldRespondWith` "bar"
71+
72+ it "serves the contents of index.html when requesting the root of a directory" $ do
73+ get "/static" `shouldRespondWith` "index"
74+
75+ describe "serveDocumentation" $ do
76+ it "serves documentation about the expose API" $ do
77+ response <- get "/documentation"
78+ liftIO $ forM_ ["person_name" :: String, "static", "dummy_api", "person_name_doc"] $
79+ \ snippet ->
80+ (snippet, cs (simpleBody response)) `shouldSatisfy` uncurry isInfixOf