servant-snap 0.8.3.2 → 0.8.4

raw patch · 12 files changed

+503/−561 lines, 12 filesdep −eitherdep −snap-corsdep ~digestive-functorsdep ~servantdep ~snap-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: either, snap-cors

Dependency ranges changed: digestive-functors, servant, snap-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−7
• example/greet.hs +9/−9
• servant-snap.cabal +10/−15
• src/Servant.hs +2/−2
• src/Servant/Server/Internal.hs +82/−106
• src/Servant/Server/Internal/RoutingApplication.hs +3/−3
• src/Servant/Server/Internal/SnapShims.hs +2/−1
• test/Servant/Server/CORSSpec.hs +108/−0
• test/Servant/ServerSpec.hs +89/−190
• test/Servant/StreamingSpec.hs +0/−158
• test/Servant/Utils/SnapTestUtils.hs +193/−0
• test/Servant/Utils/StaticFilesSpec.hs +0/−70

@@ -1,12 +1,10 @@-0.8.3.2--------Include the changes intended for 0.8.3.1 in git and the release sdist--0.8.3.1+0.8.4 ----- -Backport the response header fix from 0.8.4 (we can now use it with servant 0.14)+Support servant 0.15 and 0.16, which have a new `Stream` combinator+Drop support for servant < 0.15+Correct the way imperativelly added headers in request/response are managed (fixing CORS issue)+More CORS test coverage  0.8.3 -----

@@ -15,7 +15,7 @@ import           GHC.Generics import qualified Heist.Interpreted as I import           Snap.Core hiding (GET)-import           Snap.CORS+import           Snap.Util.CORS import           Snap.Snaplet import           Snap.Snaplet.Auth import           Snap.Snaplet.Session@@ -25,7 +25,9 @@ import           Snap.Http.Server (defaultConfig)  import           Servant.API+import qualified Servant.API.Stream as Stream import           Servant (serveSnap, Server, serveDirectory)+import qualified Servant.Types.SourceT as S  -- * Example @@ -37,7 +39,7 @@ instance ToJSON Greet  -- API specification-type TestApi m f =+type TestApi =    -- GET /hello/:name?capital={true, false}  returns a Greet as JSON   "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet@@ -52,7 +54,7 @@   -- DELETE /greet/:greetid   :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () -  :<|> "stream" :> StreamGet NetstringFraming JSON (f Greet)+  :<|> "stream" :> StreamGet NetstringFraming JSON (Stream.SourceIO Greet)    :<|> "files" :> Raw   :<|> "doraw" :> Raw@@ -71,7 +73,7 @@  type AppHandler = Handler App App -testApi :: Proxy (TestApi AppHandler StreamGenerator)+testApi :: Proxy TestApi testApi = Proxy  @@ -82,7 +84,7 @@ -- -- Each handler runs in the 'AppHandler' monad. -server :: Server (TestApi AppHandler StreamGenerator) '[] AppHandler+server :: Server TestApi '[] AppHandler server = helloH     :<|> helloH'     :<|> postGreetH@@ -107,10 +109,8 @@          deleteGreetH _ = return () -        doStream = return $ StreamGenerator $ \sendFirst sendRest -> do-          sendFirst (Greet "hi")-          sendRest  (Greet "tao")-          sendRest  (Greet "Howareya")+        doStream :: Handler App App (Stream.SourceIO Greet)+        doStream = return $ S.source [Greet "Hi", Greet "Tao", Greet "Howareya"]          doRaw = with auth $ do           u <- currentUser

@@ -1,5 +1,5 @@ name:                servant-snap-version:             0.8.3.2+version:             0.8.4 synopsis:            A family of combinators for defining webservices APIs and serving them description:   Interpret a Servant API as a Snap server, using any Snaplets you like.@@ -51,7 +51,6 @@       , bytestring         >= 0.10 && < 0.11       , case-insensitive   >= 1.2  && < 1.3       , containers         >= 0.5  && < 0.7-      , either             >= 4.3  && < 5.1       , filepath           >= 1    && < 1.5       , http-media         >= 0.7.1.2 && < 0.8       , http-types         >= 0.8  && < 0.13@@ -60,13 +59,13 @@       , network-uri        >= 2.6  && < 2.7       , mtl                >= 2.0  && < 2.3       , mmorph             >= 1    && < 1.2-      , servant            >= 0.14 && < 0.15-      , string-conversions >= 0.3  && < 0.5-      , text               >= 1.2  && < 1.3+      , servant            >= 0.15 && < 0.17       , snap               >= 1.0  && < 1.2-      , snap-core          >= 1.0.2  && < 1.2+      , snap-core          >= 1.0  && < 1.1       , snap-server        >= 1.0  && < 1.2+      , string-conversions >= 0.3  && < 0.5       , tagged             >= 0.8.5 && < 0.9+      , text               >= 1.2  && < 1.3       , transformers       >= 0.3  && < 0.6       , word8              >= 0.1  && < 0.2   hs-source-dirs: src@@ -82,7 +81,6 @@       aeson     , base     , bytestring-    , either     , errors     , heist     , http-client@@ -90,7 +88,6 @@     , servant     , servant-client     , servant-snap-    , snap-cors     , map-syntax     , snap     , snap-core@@ -106,9 +103,9 @@   hs-source-dirs: test   main-is: Spec.hs   other-modules:+    Servant.Utils.SnapTestUtils     Servant.ServerSpec-    Servant.StreamingSpec-    Servant.Utils.StaticFilesSpec+    Servant.Server.CORSSpec   build-depends:       base               == 4.*     , aeson@@ -117,17 +114,15 @@     , case-insensitive     , containers     , directory-    , either     , exceptions     , hspec              >= 2.4.3   && < 2.8+    , hspec-core         >= 2.4.3   && < 2.8+    , hspec-snap         >= 1.0.1.0 && < 1.1     , io-streams     , lens     , process-    , digestive-functors >= 0.8.1.0 && < 0.9+    , digestive-functors >= 0.8.4.0 && < 0.9     , time-    , hspec-snap         >= 1.0.1.0 && < 1.1-    , hspec-core         >= 2.4.3   && < 2.8-    , snap-cors     , http-types     , HUnit              >= 1.4     , mtl

@@ -6,7 +6,7 @@   -- | For implementing servers for servant APIs.   module Servant.Server,   -- | Utilities on top of the servant core-  module Servant.Utils.Links,+  module Servant.Links,   module Servant.Utils.StaticFiles,   -- | Useful re-exports   Proxy(..),@@ -15,5 +15,5 @@ import Data.Proxy import Servant.API import Servant.Server-import Servant.Utils.Links+import Servant.Links import Servant.Utils.StaticFiles

@@ -10,10 +10,12 @@ {-# LANGUAGE RankNTypes                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeApplications           #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE UndecidableInstances       #-} {-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE UndecidableInstances       #-}  #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-}@@ -65,18 +67,15 @@                                               getResponse, route,                                               method, withRequest) import           Servant.API                 ((:<|>) (..), (:>), BasicAuth,-                                              BoundaryStrategy(..),-                                              Capture', CaptureAll,-                                              Description, EmptyAPI,-                                              FramingRender (..),-                                              Header', If, IsSecure(..),-                                              QueryFlag, QueryParam',-                                              QueryParams, Raw, RemoteHost,-                                              ReqBody', ReflectMethod(..),-                                              SBool(..), SBoolI,-                                              Stream, Summary,-                                              ToStreamGenerator (..), Vault,-                                              Verb, getStreamGenerator, sbool)+                                              Capture',+                                              CaptureAll, Description, FramingRender (..), EmptyAPI,+                                              Header', IsSecure(..), If, QueryFlag, IsSecure(..),+                                              QueryParam', QueryParams, Raw,+                                              RemoteHost, ReqBody',+                                              ReflectMethod(..), SBool(..), SBoolI, Stream, Summary,+                                              Verb, sbool+                                             )+import         Servant.API.Stream            (ToSourceIO(..)) import           Servant.API.ContentTypes    (AcceptHeader (..),                                               AllCTRender (..),                                               AllCTUnrender (..), AllMime(..),@@ -86,6 +85,7 @@                                               RequestArgument, unfoldRequestArgument) import           Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,                                               getHeaders)+import qualified Servant.Types.SourceT       as S import qualified System.IO.Streams           as IOS  import           Servant.Server.Internal.BasicAuth@@ -289,84 +289,8 @@   -instance {-# OVERLAPPABLE #-} (MimeRender ctype a,-                               ReflectMethod method,-                               KnownNat status,-                               FramingRender framing ctype,-                               ToStreamGenerator b a)-  => HasServer (Stream method status framing ctype b) context m where-  type ServerT (Stream method status framing ctype b) context m = m b-  hoistServerWithContext _ _ nt s = nt s -  route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)-    where method = reflectMethod (Proxy :: Proxy method)-          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) --instance {-# OVERLAPPABLE #-} (MimeRender ctype a,-                               ReflectMethod method,-                               KnownNat status,-                               FramingRender framing ctype,-                               ToStreamGenerator b a,-                               GetHeaders (Headers h b))-  => HasServer (Stream method status framing ctype (Headers h b)) context m where--  type ServerT (Stream method status framing ctype (Headers h b)) context m = m (Headers h b)-  hoistServerWithContext _ _ nt s = nt s--  route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)-    where method = reflectMethod (Proxy :: Proxy method)-          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)--streamRouter :: (MimeRender ctype a,-                 FramingRender framing ctype,-                 ToStreamGenerator b a,-                 MonadSnap m-                ) =>-                (c -> ([(HeaderName, B.ByteString)], b))-             -> Method-             -> Status-             -> Proxy framing-             -> Proxy ctype-             -> Delayed m env (m c)-             -> Router m env-streamRouter splitHeaders method (Status code msg) framingproxy ctypeproxy action = leafRouter $ \env request respond ->-          let accH    = fromMaybe ct_wildcard $ getHeader hAccept request-              cmediatype = NHM.matchAccept [contentType ctypeproxy] accH-              accCheck = when (isNothing cmediatype) $ delayedFail err406-              contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)-          in runAction (action `addMethodCheck` methodCheck method request-                               `addAcceptCheck` accCheck-                       ) env request respond $ \ output ->-                let (headerz, fa) = splitHeaders output-                    k = getStreamGenerator . toStreamGenerator $ fa in-                Route $ setResponseStatus code msg-                      $ (\r -> foldl' (\r' (h,h') -> addHeader h h' r') r $ contentHeader : headerz)-                      $ flip setResponseBody emptyResponse $ \outStream -> do-                        let writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream-                        writeAndFlush (BB.lazyByteString $ header framingproxy ctypeproxy)-                        case boundary framingproxy ctypeproxy of-                             BoundaryStrategyBracket f ->-                                      let go x = let bs = mimeRender ctypeproxy x-                                                     (before, after) = f bs-                                                 in writeAndFlush (   BB.lazyByteString before-                                                                   <> BB.lazyByteString bs-                                                                   <> BB.lazyByteString after)-                                      in k go go-                             BoundaryStrategyIntersperse sep -> k-                               (\x -> do-                                  writeAndFlush . BB.lazyByteString $ mimeRender ctypeproxy x-                               )-                               (\x -> do-                                  writeAndFlush . (BB.lazyByteString sep <>) . BB.lazyByteString $ mimeRender ctypeproxy x-                               )-                             BoundaryStrategyGeneral f ->-                                      let go = writeAndFlush . BB.lazyByteString . f . mimeRender ctypeproxy-                                      in  k go go-                        IOS.write (Just . BB.lazyByteString $ trailer framingproxy ctypeproxy) outStream-                        return outStream-- -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by 'Header'.@@ -726,41 +650,93 @@    hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s ++-- newtype BasicAuthCheck m usr =+--   BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) }+--   deriving (Functor, Generic)++data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr+  deriving (Functor, Eq, Read, Show, Generic)+ -- * helpers -- ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP-{- -instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype a, -- ToStreamGenerator m (f a),-           FramingRender framing ctype -- , ToStreamGenerator f a-         ) => HasServer (Stream method status framing ctype (f a)) context m where-  type ServerT (Stream method status framing ctype (f a)) context m = m (f a)+instance forall ctype chunk method status framing m context a.+         ( MimeRender ctype chunk, ReflectMethod method, KnownNat status,+           FramingRender framing, MonadSnap m, ToSourceIO chunk a+         ) => HasServer (Stream method status framing ctype a) context m where+  type ServerT (Stream method status framing ctype a) context m = m a -  route Proxy _ action = streamRouter ([],) method (Proxy) (Proxy :: Proxy framing) (Proxy :: Proxy ctype) action+  hoistServerWithContext _ _ nt s = nt s+  route Proxy _ action = streamRouter ([],) method status+                                      (Proxy :: Proxy framing)+                                      (Proxy :: Proxy ctype) action     where method = reflectMethod (Proxy :: Proxy method)-          -- status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)+          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -instance ( MimeRender ctype a, ReflectMethod method, MimeRender ctype (f a), -- ToStreamGenerator m (f a),-           FramingRender framing ctype, {- ToStreamGenerator f a, -} GetHeaders (Headers h (f a))-         ) => HasServer (Stream method status framing ctype (Headers h (f a))) context m where-  type ServerT (Stream method status framing ctype (Headers h (f a))) context m = m (Headers h (f a))+instance ( MimeRender ctype chunk, ReflectMethod method, MimeRender ctype a, KnownNat status, MonadSnap m,+           FramingRender framing, ToSourceIO chunk a, GetHeaders (Headers h a)+         ) => HasServer (Stream method status framing ctype (Headers h a)) context m where+  type ServerT (Stream method status framing ctype (Headers h a)) context m = m (Headers h a) +  hoistServerWithContext _ _ nt s = nt s   route Proxy _ action =     streamRouter (\x -> (getHeaders x, getResponse x))                  method-                 Proxy+                 status                  (Proxy :: Proxy framing)                  (Proxy :: Proxy ctype)                  action     where method = reflectMethod (Proxy :: Proxy method)+          status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)   --- newtype BasicAuthCheck m usr =---   BasicAuthCheck { unBasicAuthCheck :: BasicAuthData -> m (BasicAuthResult usr) }---   deriving (Functor, Generic)+streamRouter :: forall ctype a c chunk env framing m+               .(MimeRender ctype chunk,+                 FramingRender framing,+                 -- ToSourceIO chunk (m a),+                 ToSourceIO chunk a,+                 MonadSnap m+                ) =>+                (c -> ([(HeaderName, B.ByteString)], a))+             -> Method+             -> Status+             -> Proxy framing+             -> Proxy ctype+             -> Delayed m env (m c)+             -> Router m env+streamRouter splitHeaders method status framingproxy ctypeproxy action =+  leafRouter $ \env request respond ->+    let accH    = fromMaybe ct_wildcard $ getHeader hAccept request+        cmediatype = NHM.matchAccept [contentType ctypeproxy] accH+        accCheck = when (isNothing cmediatype) $ delayedFail err406+        contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)+    in runAction (action `addMethodCheck` methodCheck method request+                         `addAcceptCheck` accCheck+                 ) env request respond $ \ output ->+          let (headers', fa) = splitHeaders output+              sourceT = toSourceIO fa+              S.SourceT kStepLBS =+                framingRender framingproxy+                              (mimeRender ctypeproxy :: chunk -> BL.ByteString)+                              sourceT+              response = setResponseStatus (statusCode status) (statusMessage status)+                         $ setHeaders (contentHeader:headers') emptyResponse+          in+          Route $ flip setResponseBody response $ \outStream -> do+            let+                writeAndFlush bb = IOS.write (Just $ bb <> BB.flush) outStream+                justFlush = IOS.write (Just BB.flush) outStream+                loop :: S.StepT IO BL.ByteString -> IO (IOS.OutputStream BB.Builder)+                loop S.Stop = justFlush >> return outStream+                loop (S.Error err) = fail err -- TODO: Provide a better error message+                loop (S.Skip s)    = loop s+                loop (S.Effect ms) = ms >>= loop+                loop (S.Yield lbs s) = do+                  writeAndFlush (BB.lazyByteString lbs)+                  loop s -data BasicAuthResult usr = Unauthorized | BadPassword | NoSuchUser | Authorized usr-  deriving (Functor, Eq, Read, Show, Generic)--}+            kStepLBS loop

@@ -49,9 +49,9 @@ toApplication :: forall m. MonadSnap m => RoutingApplication m -> Application m toApplication ra request respond = do -  snapReq <- getRequest-  r       <- ra (request `addHeaders` headers snapReq) routingRespond-  rspnd   <- respond r+  snapReq  <- getRequest+  r        <- ra (request `addHeaders` headers snapReq) routingRespond+  rspnd <- respond r    -- liftIO $ putStrLn $ unlines [   --   "----------"

@@ -2,6 +2,7 @@  module Servant.Server.Internal.SnapShims where +import           Control.Monad.IO.Class import qualified Data.ByteString.Char8 as B import           Data.List             (foldl') import           Data.IORef@@ -23,7 +24,7 @@  applicationToSnap :: MonadSnap m => Application m -> m () applicationToSnap app = do-  req <- getRequest+  req      <- getRequest   snapResp <- getResponse   r <- fmap (`addHeaders` headers snapResp) $ app req return   putResponse r

@@ -0,0 +1,108 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators     #-}++module Servant.Server.CORSSpec where++import           Control.Monad.IO.Class      (liftIO)+import           Data.List                   (foldl')+import           Data.Proxy+import           Servant.API                 ((:<|>) (..), (:>), BasicAuth,+                                              Capture, CaptureAll, Header (..),+                                              Headers, IsSecure (..), JSON,+                                              NoContent (..), NoFraming,+                                              OctetStream, PlainText, QueryFlag,+                                              QueryParam, QueryParams, Raw,+                                              RemoteHost, ReqBody, SourceIO,+                                              Stream, addHeader)+import           Servant.API.Verbs           (Delete, Get, Patch, Post, Put,+                                              Verb)+import           Servant.Server              hiding (route)+import           Servant.Server.Internal     (HasServer)+import           Snap+import qualified Snap.Core                   as SC+import qualified Snap.Test                   as ST+import qualified Snap.Util.CORS              as CORS+import           Test.Hspec++import           Servant.Utils.SnapTestUtils++-- TODO: Cleanup+spec :: Spec+spec = do+  corsSanitySpec++corsSanitySpec :: Spec+corsSanitySpec = do+  let handler = CORS.applyCORS CORS.defaultOptions bareEndpoint+      bareEndpoint = return ()++      servantEndpoint :: Snap ()+      servantEndpoint = do+        let printHeaders m r = liftIO $ putStrLn m >> print (headers r)+        respA <- SC.getResponse+        serveSnap (Proxy :: Proxy ("int" :> Get '[JSON] Int)) (return  5 :: Snap Int)++      servantSnapletInit :: SnapletInit () ()+      servantSnapletInit = makeSnaplet "servant-test" "Testing servant" Nothing $ do+        addRoutes [+                   ("other", SC.writeText "other route")+                  ,("", servantSnapletHandler)+                  ]+        wrapSite (CORS.applyCORS CORS.defaultOptions)+        return ()++      servantSnapletHandler :: Handler () () ()+      servantSnapletHandler = do+        let printHeaders m r = liftIO $ putStrLn m >> print (headers r)+        respA <- SC.getResponse+        serveSnap (Proxy :: Proxy ("int" :> Get '[JSON] Int)) (return  5 :: Handler () () Int)++      forwardHeaders :: Snap ()+      forwardHeaders = do+          req  <- SC.getRequest+          resp <- SC.getResponse+          putResponse $ foldl' (\r (hk, hv) -> SC.setHeader hk hv r) resp (listHeaders req)++      req :: ST.RequestBuilder IO ()+      req = do+        ST.setRequestType $ ST.RequestWithRawBody GET ""+        ST.setRequestPath "/"+        ST.setHeader "Origin" "http://origin.org"++      req' :: ST.RequestBuilder IO ()+      req' = do+        ST.setRequestType $ ST.RequestWithRawBody GET ""+        ST.setRequestPath "int"+        ST.setHeader "Origin" "http://origin.org"++      req'' :: ST.RequestBuilder IO ()+      req'' = do+        ST.setRequestType $ ST.RequestWithRawBody GET ""+        ST.setRequestPath "other"+        ST.setHeader "Origin" "http://origin.org"++  it "Sets CORS and forwards req headers for Snap non-servant handler" $ do+    resp <- ST.runHandler req (forwardHeaders >> handler)+    Right resp `shouldHaveStatus` 200+    Right resp `shouldHaveHeaders` [("Origin", "http://origin.org")+                                   ,("Access-Control-Allow-Origin", "http://origin.org")]+  it "Sets CORS and forwards req headers for Snap handler" $ do+    resp <- ST.runHandler req' (CORS.applyCORS CORS.defaultOptions $ forwardHeaders >> servantEndpoint)+    Right resp `shouldHaveStatus` 200+    Right resp `shouldDecodeTo`   (5 :: Int)+    Right resp `shouldHaveHeaders` [("Origin", "http://origin.org")+                                   ,("Access-Control-Allow-Origin", "http://origin.org")+                                   ]+  it "Sets CORS and forwards req headers for Snaplet servant handler with wrapSite" $ do+    resp <- testSnaplet servantSnapletInit req'+    resp `shouldHaveStatus` 200+    resp `shouldDecodeTo`   (5 :: Int)+    resp `shouldHaveHeaders` [("Access-Control-Allow-Origin", "http://origin.org")+                       ]++  it "Sets CORS and forwards req headers for Snaplet not-servant handler with wrapSite" $ do+    resp <- testSnaplet servantSnapletInit req''+    resp `shouldHaveStatus` 200+    resp `shouldHaveHeaders` [("Access-Control-Allow-Origin", "http://origin.org")+                             ]

@@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds            #-} {-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE KindSignatures       #-} {-# LANGUAGE LambdaCase           #-} {-# LANGUAGE OverloadedStrings    #-}@@ -17,90 +17,76 @@   --------------------------------------------------------------------------------import           Control.Lens               (makeLenses)-import           Control.Monad              (forM_, unless, void, when)-import           Control.Monad.IO.Class     (liftIO)-import           Data.Aeson                 (FromJSON, ToJSON)-import qualified Data.Aeson                 as A-import qualified Data.ByteString.Base64     as B64-import qualified Data.ByteString.Char8      as B8-import qualified Data.ByteString.Lazy       as BL-import           Data.CaseInsensitive       (mk)-import           Data.Char                  (toUpper)-import           Data.Functor               ((<$>))-import           Data.Maybe                 (fromMaybe)+import           Control.Lens                                (makeLenses)+import           Control.Monad                               (forM_, unless,+                                                              void, when)+import           Control.Monad.IO.Class                      (liftIO)+import           Data.Aeson                                  (FromJSON, ToJSON)+import qualified Data.Aeson                                  as A+import qualified Data.ByteString.Base64                      as B64+import qualified Data.ByteString.Char8                       as B8+import qualified Data.ByteString.Lazy                        as BL+import           Data.CaseInsensitive                        (mk)+import           Data.Char                                   (toUpper)+import           Data.Functor                                ((<$>))+import           Data.List                                   (foldl')+import           Data.Maybe                                  (fromMaybe) import           Data.Monoid-import           Data.Proxy                 (Proxy (Proxy))-import qualified Data.Set                   as Set-import qualified Data.Text                  as T-import qualified Data.Text.Lazy             as TL-import qualified Data.Text.Encoding         as T-import qualified Data.Text.Lazy.Encoding    as TL-import           GHC.Generics               (Generic)-import           Network.HTTP.Types         (hAccept, hContentType)+import           Data.Proxy                                  (Proxy (Proxy))+import qualified Data.Set                                    as Set+import qualified Data.Text                                   as T+import qualified Data.Text.Encoding                          as T+import qualified Data.Text.Lazy                              as TL+import qualified Data.Text.Lazy.Encoding                     as TL+import           GHC.Generics                                (Generic)+import           Network.HTTP.Types                          (hAccept,+                                                              hContentType) import qualified Network.HTTP.Types-import           Snap.Core                  hiding (Headers, addHeader)-import qualified Snap.Core                  as SC-import           Snap.CORS+import           Snap.Core                                   hiding (Headers,+                                                              addHeader)+import qualified Snap.Core                                   as SC import           Snap.Snaplet-import qualified Snap.Snaplet.Test          as SST-import qualified Snap.Test                  as ST+import qualified Snap.Snaplet.Test                           as SST+import qualified Snap.Test                                   as ST+import qualified Snap.Util.CORS                              as CORS --------------------------------------------------------------------------------import           Test.Hspec-import           Test.Hspec.Snap            hiding (NotFound)-import qualified Test.Hspec.Snap            as THS-import qualified Test.HUnit                 as HU-import           Servant.API                ((:<|>) (..), (:>),-                                             addHeader, BasicAuth, Capture,-                                             CaptureAll, Header (..), Headers,-                                             IsSecure(..), JSON, NoContent(..),-                                             PlainText, QueryFlag, QueryParam,-                                             QueryParams, Raw, RemoteHost,-                                             ReqBody)-import           Servant.API.Verbs          (Verb, Get, Post, Put, Delete,-                                             Patch)-import qualified Servant.API.Verbs          as V-import           Servant.Server              hiding (route)-import           Servant.Server.Internal     (HasServer)+import           Servant.API                                 ((:<|>) (..), (:>),+                                                              BasicAuth,+                                                              Capture,+                                                              CaptureAll,+                                                              Header (..),+                                                              Headers,+                                                              IsSecure (..),+                                                              JSON,+                                                              NoContent (..),+                                                              NoFraming,+                                                              OctetStream,+                                                              PlainText,+                                                              QueryFlag,+                                                              QueryParam,+                                                              QueryParams, Raw,+                                                              RemoteHost,+                                                              ReqBody, SourceIO,+                                                              Stream, addHeader)+import           Servant.API.Verbs                           (Delete, Get,+                                                              Patch, Post, Put,+                                                              Verb)+import qualified Servant.API.Verbs                           as V+import           Servant.Server                              hiding (route)+import           Servant.Server.Internal                     (HasServer) import           Servant.Server.Internal.BasicAuth import           Servant.Server.Internal.Context+import qualified Servant.Types.SourceT                       as S+import           Servant.Utils.SnapTestUtils import           Snap.Snaplet.Auth import           Snap.Snaplet.Auth.Backends.JsonFile-import qualified Snap.Util.CORS as CORS import           Snap.Snaplet.Session import           Snap.Snaplet.Session.Backends.CookieSession------------------------------------------------------------------------------------ * test data types--data App = App { _auth :: Snaplet (AuthManager App)-               , _sess :: Snaplet SessionManager}-makeLenses 'App--type AppHandler = Handler App App--app :: SnapletInit App App-app = app' []--app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App-app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do-  s <- nestSnaplet "sess" sess $-           initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)-  a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"-  addRoutes rs-  wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h)-  return (App a s)--createTestUserIfMissing :: Handler App App ()-createTestUserIfMissing =-  with auth $ usernameExists testLogin >>= \case-    True  -> return ()-    False -> void $ createUser testLogin testPassword--testLogin    = "greg"-testPassword = "p@ssword"---------------------------------------------------------------------------------+import qualified Snap.Util.CORS                              as CORS+import           Test.Hspec+import           Test.Hspec.Snap                             hiding (NotFound)+import qualified Test.Hspec.Snap                             as THS+import qualified Test.HUnit                                  as HU   -- * Specs@@ -124,6 +110,7 @@ -- * verbSpec {{{ ------------------------------------------------------------------------------ + type VerbApi method status     =                Verb method status '[JSON] Person  :<|> "noContent" :> Verb method status '[JSON] NoContent@@ -132,6 +119,7 @@  :<|> "accept"    :> (    Verb method status '[JSON] Person                      :<|> Verb method status '[PlainText] String                      )+ :<|> "stream"    :> Stream method status NoFraming OctetStream (SourceIO B8.ByteString)   verbSpec :: Spec@@ -142,6 +130,7 @@           :<|> return (addHeader 5 alice)           :<|> return (addHeader 10 NoContent)           :<|> (return alice :<|> return "B")+          :<|> return (S.source ["bytestring"])       get200     = Proxy :: Proxy (VerbApi 'V.GET 200)       post210    = Proxy :: Proxy (VerbApi 'V.POST 210)       put203     = Proxy :: Proxy (VerbApi 'V.PUT 203)@@ -179,9 +168,10 @@             liftIO $ statusIs response status `shouldBe` True          let sInit = app' verbRoutes-            runUrl p = SST.runHandler Nothing-                       (mkRequest method p "" [] "")-                       (serveSnap api server) sInit+            runUrl p = testSnaplet sInit (mkRequest method p "" [] "")+            -- runUrl p = SST.runHandler Nothing+            --            (mkRequest method p "" [] "")+            --            (serveSnap api server) sInit          -- This group is run with hspec directly @@ -203,9 +193,9 @@                   (serveSnap api server) sInit           shouldHaveHeaders resp  [("H","5")] +        -- TODO: Why doesn't this test pass?         it "returs CORS headers" $ do-          (_, snapm, _) <- runSnaplet Nothing sInit-          resp <- fmap Right $ ST.runHandler (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") snapm+          resp  <- testSnaplet sInit (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "")           shouldHaveHeaders resp  [("access-control-allow-origin"                                   ,"http://example.com")] @@ -223,6 +213,13 @@             resp `shouldHaveStatus` status             resp `shouldHaveBody` "B" +        unless (method == SC.HEAD) $ it "works for Stream as for Result" $ do+          resp <- SST.runHandler Nothing+                                 (mkRequest method "/stream" "" [] "")+                                 (serveSnap api server) sInit+          resp `shouldHaveStatus` status+          resp `shouldHaveBody`   "bytestring"+   test "GET 200" get200 (routes get200 EmptyContext server) SC.GET 200   test "POST 210" post210 (routes post210 EmptyContext server) SC.POST 210   test "PUT 203" put203 (routes put203 EmptyContext server) SC.PUT 203@@ -253,10 +250,10 @@ captureServer2 :: Server CaptureApi2 '[] AppHandler captureServer2 _ = do   rq <- getRequest-  writeBS (SC.rqPathInfo rq) +  writeBS (SC.rqPathInfo rq)  captureSpec :: Spec-captureSpec = do -- snap (route (routes captureApi captureServer)) app $  +captureSpec = do -- snap (route (routes captureApi captureServer)) app $    let ( sInit , _ ) = mkInitAndServer captureApi  EmptyContext captureServer       ( sInit2, _ ) = mkInitAndServer captureApi2 EmptyContext captureServer2@@ -359,7 +356,7 @@         qpCapitalize True  = return alice { name = map toUpper (name alice) }          queryParamServer (Just name_) = return alice{name = name_}-        queryParamServer Nothing = return alice+        queryParamServer Nothing      = return alice  queryParamSpec :: Spec queryParamSpec = do@@ -696,7 +693,7 @@    where versionHandler = return :: HttpVersion -> AppHandler HttpVersion         secureHandler :: IsSecure -> AppHandler String-        secureHandler Secure = return "secure"+        secureHandler Secure    = return "secure"         secureHandler NotSecure = return "not secure"         hostHandler = return . B8.unpack  :: B8.ByteString -> AppHandler String @@ -766,7 +763,7 @@       authHeader un pw = "Basic " <> B64.encode (T.encodeUtf8 un <> ":" <> pw)    describe "Checks auth" $ do-    +     it "returns 401 when not logged  in" $ do       response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" "" [] ""       response `shouldHaveStatus` 401@@ -818,120 +815,22 @@ ------------------------------------------------------------------------------  getStatus :: TestResponse -> Maybe Int-getStatus (Html (RespCode s) _) = Just s-getStatus (Json (RespCode s) _) = Just s-getStatus THS.NotFound = Nothing+getStatus (Html (RespCode s) _)     = Just s+getStatus (Json (RespCode s) _)     = Just s+getStatus THS.NotFound              = Nothing getStatus (Redirect (RespCode s) _) = Just s-getStatus (Other (RespCode s)) = Just s-getStatus Empty = Nothing+getStatus (Other (RespCode s))      = Just s+getStatus Empty                     = Nothing  statusIs :: TestResponse -> Int -> Bool statusIs r s = getStatus r == Just s  decodesTo :: (FromJSON a, Eq a) => TestResponse -> a -> Bool decodesTo (Json _ bs) a = A.decode' bs == Just a-decodesTo _ _ = False+decodesTo _ _           = False  bodyIs :: TestResponse -> TL.Text -> Bool bodyIs (Html _ t) target = t == TL.toStrict target bodyIs (Json _ b) target = b == TL.encodeUtf8 target-bodyIs _ _ = False----------------------------------------------------------------------------------- * hspec helpers---------------------------------------------------------------------------------shouldHaveBody :: Either T.Text Response -> T.Text -> IO ()-shouldHaveBody (Left e) _ = HU.assertFailure $-                            "Failed to respond: " ++ T.unpack e-shouldHaveBody (Right r) a = do-  bod <- ST.getResponseBody r-  bod `shouldBe` T.encodeUtf8 a--shouldHaveStatus :: Either T.Text Response -> Int -> IO ()-shouldHaveStatus (Left e) _ = HU.assertFailure $-                              "Failed to respond: " ++ T.unpack e-shouldHaveStatus (Right r) a = do-  SC.rspStatus r `shouldBe` a---shouldDecodeTo :: (FromJSON a, Eq a, Show a)-               => Either T.Text Response-               -> a-               -> IO ()-shouldDecodeTo (Left e) _ = HU.assertFailure $-                            "Failed to respond: " ++ T.unpack e-shouldDecodeTo (Right resp) a = do-  bod <- ST.getResponseBody resp-  case A.decode' $ BL.fromStrict bod of-    Just x | x == a -> return ()-    Just _ -> HU.assertFailure $-              "Failed to decode response to " ++ show a ++-              " from body: " ++ B8.unpack bod-    Nothing -> HU.assertFailure $ "Failed to decode respone from body: " ++-               B8.unpack bod ++ "\nResponse: " ++ show resp-    -shouldHaveHeaders :: Either T.Text Response-                  -> [(B8.ByteString, B8.ByteString)]-                  -> Expectation-shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e-shouldHaveHeaders (Right resp) hs = do-  let respHs  = Set.fromList $ SC.listHeaders resp-      hs'     = Set.fromList $  (\(k,v) -> (mk k,v)) <$> hs-      missing = Set.toList $ Set.difference hs' respHs-  case missing of-    [] -> return ()-    _  -> expectationFailure $-     "These expected headers and values were missing: " ++ show missing ++-     " from the response's: " ++ show (Set.toList respHs)------------------------------------------------------------------------------------ * Assorted Snap helpers---------------------------------------------------------------------------------mkInitAndServer :: (HasServer api context m, m ~ AppHandler)-                => Proxy (api :: *)-                -> Context context-                -> Server api context AppHandler-                -> (SnapletInit App App, AppHandler ())-mkInitAndServer api ctx serv =-  let sRoute = serveSnapWithContext api ctx serv-  in  (app' [("", sRoute)], sRoute)---mkRequest :: Method-          -> B8.ByteString-          -> B8.ByteString-          -> [Network.HTTP.Types.Header]-          -> B8.ByteString-          -> ST.RequestBuilder IO ()-mkRequest mth pth qs hds bdy = do-  let ct = fromMaybe "" (Prelude.lookup hContentType hds)-  ST.postRaw pth ct bdy-  ST.setQueryStringRaw qs-  unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy)-  forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v)-  -- req <- State.get -- Useful for debugging-  -- liftIO $ print req--runReqOnApi :: (HasServer api context m, m ~ AppHandler)-            => Proxy (api :: *)-            -> Context context-            -> Server api context AppHandler-            -> Method-            -> B8.ByteString-            -> B8.ByteString-            -> [Network.HTTP.Types.Header]-            -> B8.ByteString-            -> IO (Either T.Text Response)-runReqOnApi api ctx serv method route qs hds bod =-  let (sInit, serv') = mkInitAndServer api ctx serv-  in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit+bodyIs _ _               = False -routes :: (HasServer api context m, m ~ AppHandler)-       => Proxy (api :: *)-       -> Context context-       -> Server api context AppHandler-       -> [(B8.ByteString, AppHandler ())]-routes p ctx s = [("", serveSnapWithContext p ctx s)]

@@ -1,158 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}---- | This module tests whether streaming works from client to server--- with a server implemented with servant-server.-module Servant.StreamingSpec where--import           Control.Concurrent-import           Control.Exception hiding (Handler)-import           Control.Monad.IO.Class-import qualified Data.ByteString as Strict-import Control.Monad.State (modify)-import qualified Data.ByteString.Lazy as Lazy-import           Network.HTTP.Types--- import           Network.Wai--- import           Network.Wai.Internal-import           Prelude--- import           Prelude.Compat-import           Servant-import           Snap.Core-import           Snap.Internal.Http.Types-import           Snap.Test-import           Snap-import qualified System.Timeout-import qualified System.IO.Streams as IOS-import           Test.Hspec--type TestAPI =-  ReqBody '[OctetStream] Lazy.ByteString :> Post '[JSON] NoContent--testAPI :: Proxy TestAPI-testAPI = Proxy--spec :: Spec-spec = return ()--- TODO: This test fails-{--spec :: Spec-spec = do-  -- The idea of this test is this:-  ---  -- - The mock client will-  --   - send some data in the request body, but not all,-  --   - wait for the server to acknowledge (outside of http, through an MVar)-  --     that the server received some data,-  --   - send the rest of the request body.-  -- - The mock server will-  --   - receive some data,-  --   - notify the client that it received some data,-  --   - receive the rest of the data,-  --   - respond with an empty result.-  it "client to server can stream lazy ByteStrings" $ timeout $ do-    serverReceivedFirstChunk <- newWaiter--    -- - streams some test data-    -- - waits for serverReceivedFirstChunk-    -- - streams some more test data-    streamTestData <- do-      mvar :: MVar [IO Strict.ByteString] <- newMVar $-        map return (replicate 1000 "foo") ++-        (waitFor serverReceivedFirstChunk >> return "foo") :-        map return (replicate 1000 "foo")-      return $ modifyMVar mvar $ \ actions -> case actions of-        (a : r) -> (r, ) <$> a-        [] -> return ([], "")--    rqStream <- IOS.makeInputStream (Just <$> streamTestData)-    rqStream2 <- IOS.makeInputStream (return (Just "foo"))-    let makeRequest :: RequestBuilder IO ()-        makeRequest = do-          postRaw @IO "/" "application/octet-stream" "barbar"-          -- transformRequestBody $ \inStream -> return rqStream-          -- modify $ \rq -> rq { rqBody = rqStream }--    -- - receives the first chunk-    -- - notifies serverReceivedFirstChunk-    -- - receives the rest of the request-    let handler :: Lazy.ByteString -> Snap NoContent-        handler input = do-          liftIO $ putStrLn $ "handler Hello1"-          -- rq <- getRequest-          -- putRequest (rq { rqBody = rqStream })-          -- transformRequestBody $ \_ -> return rqStream2-          liftIO $ putStrLn $ "handler Hello2"-          liftIO $ do-            print "handler Hello3"-            let prefix = Lazy.take 3 input-            prefix `shouldBe` "foo"-            print "handler Hello4"-            notify serverReceivedFirstChunk ()-            print "handler Hello5"-            input `shouldBe` mconcat (replicate 2001 "foo")-            return NoContent--        app = serveSnap testAPI handler-    putStrLn "Hello1"-    response <- executeRequest rqStream makeRequest app-    rspStatus response `shouldBe` 200--executeRequest :: IOS.InputStream Strict.ByteString -> RequestBuilder IO () -> Snap () -> IO Response-executeRequest rqStream makeRequest act = do-  responseMVar <- newEmptyMVar-  putStrLn "Hello2"-  -- evalHandler (buildRequest get (Lazy.replicate "foo" 2001)) (act >> putMVar responseMVar response)-  -- evalHandler makeRequest (act >> get >>= \r -> liftIO (putMVar responseMVar r))-  evalHandler makeRequest $ do-    liftIO $ putStrLn "Hello3"-    -- rq <- getRequest-    liftIO $ putStrLn "Hello3.5"-    -- putRequest (rq { rqBody = rqStream })-    transformRequestBody $ \_ -> return rqStream-    liftIO $ putStrLn "Hello3.7"-    act-    liftIO $ putStrLn "Hello4"-    r <- Snap.getResponse-    liftIO (putMVar responseMVar r)--    -- (act >> get >>= \r -> liftIO (putMVar responseMVar r))-  -- let respond response = do-  --       putMVar responseMVar response-  --       return ResponseReceived-  -- ResponseReceived <- app request respond-  takeMVar responseMVar---- executeRequest :: Application -> Request -> IO Response--- executeRequest app request = do---   responseMVar <- newEmptyMVar---   let respond response = do---         putMVar responseMVar response---         return ResponseReceived---   ResponseReceived <- app request respond---   takeMVar responseMVar--timeout :: IO a -> IO a-timeout action = do-  result <- System.Timeout.timeout 1000000 action-  maybe (throwIO $ ErrorCall "timeout") return result---- * waiter--data Waiter a-  = Waiter {-    notify :: a -> IO (),-    waitFor :: IO a-  }--newWaiter :: IO (Waiter a)-newWaiter = do-  mvar <- newEmptyMVar-  return $ Waiter {-    notify = putMVar mvar,-    waitFor = readMVar mvar-  }--}

@@ -0,0 +1,193 @@+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE KindSignatures    #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Servant.Utils.SnapTestUtils where++import           Control.Lens                                (makeLenses)+import           Control.Monad                               (forM_, unless,+                                                              void, when)+import           Control.Monad.IO.Class                      (liftIO)+import           Data.Aeson+import qualified Data.Aeson                                  as A+import qualified Data.ByteString.Char8                       as B8+import qualified Data.ByteString.Lazy                        as BL+import           Data.CaseInsensitive                        (mk)+import           Data.List                                   (foldl')+import           Data.Maybe                                  (fromMaybe)+import           Data.Proxy+import qualified Data.Set                                    as Set+import qualified Data.Text                                   as T+import qualified Data.Text.Encoding                          as T+import           Network.HTTP.Types                          (hAccept,+                                                              hContentType)+import qualified Network.HTTP.Types+import           Servant.API                                 ((:<|>) (..), (:>),+                                                              BasicAuth,+                                                              Capture,+                                                              CaptureAll,+                                                              Header (..),+                                                              Headers,+                                                              IsSecure (..),+                                                              JSON,+                                                              NoContent (..),+                                                              NoFraming,+                                                              OctetStream,+                                                              PlainText,+                                                              QueryFlag,+                                                              QueryParam,+                                                              QueryParams, Raw,+                                                              RemoteHost,+                                                              ReqBody, SourceIO,+                                                              Stream, addHeader)+import           Servant.API.Verbs                           (Delete, Get,+                                                              Patch, Post, Put,+                                                              Verb)+import           Servant.Server                              hiding (route)+import           Servant.Server.Internal                     (HasServer)+import           Snap+import qualified Snap.Core                                   as SC+import           Snap.Snaplet+import           Snap.Snaplet.Auth+import           Snap.Snaplet.Auth.Backends.JsonFile+import           Snap.Snaplet.Session+import           Snap.Snaplet.Session.Backends.CookieSession+import qualified Snap.Test                                   as ST+import qualified Snap.Util.CORS                              as CORS+import           Test.Hspec+import qualified Test.HUnit                                  as HU+++data App = App { _auth :: Snaplet (AuthManager App)+               , _sess :: Snaplet SessionManager}+makeLenses 'App++type AppHandler = Handler App App++app :: SnapletInit App App+app = app' []++app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App+app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do+  s <- nestSnaplet "sess" sess $+           initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)+  a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"+  addRoutes rs+  wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h)+  return (App a s)++createTestUserIfMissing :: Handler App App ()+createTestUserIfMissing =+  with auth $ usernameExists testLogin >>= \case+    True  -> return ()+    False -> void $ createUser testLogin testPassword++testLogin    = "greg"+testPassword = "p@ssword"+------------------------------------------------------------------------------+-- * Assorted Snap helpers+------------------------------------------------------------------------------+++mkInitAndServer :: (HasServer api context m, m ~ AppHandler)+                => Proxy (api :: *)+                -> Context context+                -> Server api context (AppHandler)+                -> (SnapletInit App App, AppHandler ())+mkInitAndServer api ctx serv =+  let sRoute = serveSnapWithContext api ctx serv+  in  (app' [("", sRoute)], sRoute)+++mkRequest :: Method+          -> B8.ByteString+          -> B8.ByteString+          -> [Network.HTTP.Types.Header]+          -> B8.ByteString+          -> ST.RequestBuilder IO ()+mkRequest mth pth qs hds bdy = do+  let ct = fromMaybe "" (Prelude.lookup hContentType hds)+  ST.postRaw pth ct bdy+  ST.setQueryStringRaw qs+  unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy)+  forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v)+  -- req <- State.get -- Useful for debugging+  -- liftIO $ print req++runReqOnApi :: (HasServer api context m, m ~ AppHandler)+            => Proxy (api :: *)+            -> Context context+            -> Server api context AppHandler+            -> Method+            -> B8.ByteString+            -> B8.ByteString+            -> [Network.HTTP.Types.Header]+            -> B8.ByteString+            -> IO (Either T.Text Response)+runReqOnApi api ctx serv method route qs hds bod =+  let (sInit, serv') = mkInitAndServer api ctx serv+  -- in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit+  in testSnaplet sInit (mkRequest method route qs hds bod)++routes :: (HasServer api context m, m ~ AppHandler)+       => Proxy (api :: *)+       -> Context context+       -> Server api context (AppHandler)+       -> [(B8.ByteString, AppHandler ())]+routes p ctx s = [("", serveSnapWithContext p ctx s)]++testSnaplet :: SnapletInit b b -> ST.RequestBuilder IO () -> IO (Either T.Text Response)+testSnaplet snapletInit req = do+  (_, snapm, _) <- runSnaplet Nothing snapletInit+  fmap Right $ ST.runHandler req snapm++------------------------------------------------------------------------------+-- * hspec helpers+------------------------------------------------------------------------------++shouldHaveBody :: Either T.Text Response -> T.Text -> IO ()+shouldHaveBody (Left e) _ = HU.assertFailure $+                            "Failed to respond: " ++ T.unpack e+shouldHaveBody (Right r) a = do+  bod <- ST.getResponseBody r+  bod `shouldBe` T.encodeUtf8 a++shouldHaveStatus :: Either T.Text Response -> Int -> IO ()+shouldHaveStatus (Left e) _ = HU.assertFailure $+                              "Failed to respond: " ++ T.unpack e+shouldHaveStatus (Right r) a = do+  SC.rspStatus r `shouldBe` a+++shouldDecodeTo :: (FromJSON a, Eq a, Show a)+               => Either T.Text Response+               -> a+               -> IO ()+shouldDecodeTo (Left e) _ = HU.assertFailure $+                            "Failed to respond: " ++ T.unpack e+shouldDecodeTo (Right resp) a = do+  bod <- ST.getResponseBody resp+  case A.decode' $ BL.fromStrict bod of+    Just x | x == a -> return ()+    Just _ -> HU.assertFailure $+              "Failed to decode response to " ++ show a +++              " from body: " ++ B8.unpack bod+    Nothing -> HU.assertFailure $ "Failed to decode respone from body: " +++               B8.unpack bod ++ "\nResponse: " ++ show resp++shouldHaveHeaders :: Either T.Text Response+                  -> [(B8.ByteString, B8.ByteString)]+                  -> Expectation+shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e+shouldHaveHeaders (Right resp) hs = do+  let respHs  = Set.fromList $ SC.listHeaders resp+      hs'     = Set.fromList $  (\(k,v) -> (mk k,v)) <$> hs+      missing = Set.toList $ Set.difference hs' respHs+  case missing of+    [] -> return ()+    _  -> expectationFailure $+     "These expected headers and values were missing: " ++ show missing +++     " from the response's: " ++ show (Set.toList respHs)+

@@ -1,70 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Servant.Utils.StaticFilesSpec where--import Control.Exception (bracket)-import Control.Monad.IO.Class (liftIO)-import Data.Proxy (Proxy(Proxy))-import Snap.Core (route)-import Snap.Snaplet (Handler, SnapletInit, makeSnaplet)-import System.Directory (getCurrentDirectory, setCurrentDirectory, createDirectory)-import System.IO.Temp (withSystemTempDirectory)-import Test.Hspec (Spec, describe, it, around_, shouldBe)-import Test.Hspec.Snap (get, snap, TestResponse(..), RespCode(..))--import Servant.API (JSON)-import Servant.API.Alternative ((:<|>)((:<|>)))-import Servant.API.Capture (Capture)-import Servant.API.Verbs-import Servant.API.Raw (Raw)-import Servant.API.Sub ((:>))-import Servant.Server (Server, serveSnap)-import Servant.ServerSpec (Person(Person))-import Servant.Utils.StaticFiles (serveDirectory)--type Api =-       "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person-  :<|> "static" :> Raw--type AppHandler = Handler () ()--api :: Proxy Api-api = Proxy--app :: SnapletInit () ()-app = makeSnaplet "servantsnap" "A test for servant-snap" Nothing (return ())--server :: Server Api '[] AppHandler-server =-       (\ name_ -> return (Person name_ 42))-  :<|> serveDirectory "static"--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 $ snap (route ([("", serveSnap api server)])) app $ do-    describe "serveDirectory" $ do-      it "successfully serves files" $ do-        response <- get "/static/foo.txt"-        liftIO $ response `shouldBe` Html (RespCode 200) "bar"--      it "serves the contents of index.html when requesting the root of a directory" $ do-        response <- get "/static/"-        liftIO $ response `shouldBe` Html (RespCode 200) "index"