diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013 - 2014, Alexander Thiemann +Copyright (c) 2013 - 2015, Alexander Thiemann All rights reserved. diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,5 +1,5 @@ name: Spock -version: 0.7.6.0 +version: 0.7.7.0 synopsis: Another Haskell web framework for rapid development description: This toolbox provides everything you need to get a quick start into web hacking with haskell: fast routing, middleware, json, sessions, cookies, database helper, csrf-protection Homepage: https://github.com/agrafix/Spock @@ -8,7 +8,7 @@ license-file: LICENSE author: Alexander Thiemann maintainer: Alexander Thiemann -copyright: (c) 2013 - 2014 Alexander Thiemann +copyright: (c) 2013 - 2015 Alexander Thiemann category: Web build-type: Simple cabal-version: >=1.8 diff --git a/src/Web/Spock/Internal/CoreAction.hs b/src/Web/Spock/Internal/CoreAction.hs --- a/src/Web/Spock/Internal/CoreAction.hs +++ b/src/Web/Spock/Internal/CoreAction.hs @@ -8,7 +8,7 @@ , files, params, param, param', setStatus, setHeader, redirect , jumpNext, middlewarePass, modifyVault, queryVault , setCookie, setCookie' - , bytes, lazyBytes, text, html, file, json + , bytes, lazyBytes, text, html, file, json, stream, response , requireBasicAuth , preferredFormat, ClientPreferredFormat(..) ) @@ -24,6 +24,7 @@ import Control.Monad.State hiding (get, put) import Data.Monoid import Data.Time +import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Status import Prelude hiding (head) import System.Locale @@ -209,6 +210,13 @@ , ";" ] +-- | Use a custom 'Wai.Response' generator as response body. +response :: MonadIO m => (Status -> ResponseHeaders -> Wai.Response) -> ActionT m a +response val = + do modify $ \rs -> rs { rs_responseBody = ResponseBody val } + throwError ActionDone +{-# INLINE response #-} + -- | Send a 'ByteString' as response body. Provide your own "Content-Type" bytes :: MonadIO m => BS.ByteString -> ActionT m a bytes val = @@ -218,8 +226,7 @@ -- | Send a lazy 'ByteString' as response body. Provide your own "Content-Type" lazyBytes :: MonadIO m => BSL.ByteString -> ActionT m a lazyBytes val = - do modify $ \rs -> rs { rs_responseBody = ResponseLBS val } - throwError ActionDone + response $ \status headers -> Wai.responseLBS status headers val {-# INLINE lazyBytes #-} -- | Send text as a response body. Content-Type will be "text/plain" @@ -240,8 +247,7 @@ file :: MonadIO m => T.Text -> FilePath -> ActionT m a file contentType filePath = do setHeader "Content-Type" contentType - modify $ \rs -> rs { rs_responseBody = ResponseFile filePath } - throwError ActionDone + response $ \status headers -> Wai.responseFile status headers filePath Nothing {-# INLINE file #-} -- | Send json as response. Content-Type will be "application/json" @@ -250,6 +256,12 @@ do setHeader "Content-Type" "application/json; charset=utf-8" lazyBytes $ A.encode val {-# INLINE json #-} + +-- | Use a 'Wai.StreamingBody' to generate a response. +stream :: MonadIO m => Wai.StreamingBody -> ActionT m a +stream val = + response $ \status headers -> Wai.responseStream status headers val +{-# INLINE stream #-} -- | Basic authentification -- provide a title for the prompt and a function to validate diff --git a/src/Web/Spock/Internal/Wire.hs b/src/Web/Spock/Internal/Wire.hs --- a/src/Web/Spock/Internal/Wire.hs +++ b/src/Web/Spock/Internal/Wire.hs @@ -18,6 +18,7 @@ import Control.Monad.Trans.Resource import Data.Hashable import Data.Maybe +import Network.HTTP.Types.Header (ResponseHeaders) import Network.HTTP.Types.Method import Network.HTTP.Types.Status #if MIN_VERSION_base(4,6,0) @@ -62,18 +63,14 @@ , ri_vaultIf :: VaultIf } -data ResponseBody - = ResponseFile FilePath - | ResponseLBS BSL.ByteString - | ResponseRedirect !T.Text - deriving (Show, Eq) +newtype ResponseBody = ResponseBody (Status -> ResponseHeaders -> Wai.Response) data ResponseState = ResponseState { rs_responseHeaders :: !(HM.HashMap (CI.CI BS.ByteString) BS.ByteString) , rs_status :: !Status , rs_responseBody :: !ResponseBody - } deriving (Show, Eq) + } data ActionInterupt = ActionRedirect !T.Text @@ -95,17 +92,8 @@ lift = ActionT . lift . lift respStateToResponse :: ResponseState -> Wai.Response -respStateToResponse (ResponseState headers status body) = - case body of - ResponseFile fp -> - Wai.responseFile status waiHeaders fp Nothing - ResponseLBS bsl -> - Wai.responseLBS status waiHeaders bsl - ResponseRedirect target -> - Wai.responseLBS status302 (("Location", T.encodeUtf8 target) : waiHeaders) BSL.empty - where - waiHeaders = - HM.toList headers +respStateToResponse (ResponseState headers status (ResponseBody body)) = + body status $ HM.toList headers errorResponse :: Status -> BSL.ByteString -> ResponseState errorResponse s e = @@ -113,8 +101,8 @@ { rs_responseHeaders = HM.singleton "Content-Type" "text/html" , rs_status = s - , rs_responseBody = - ResponseLBS $ + , rs_responseBody = ResponseBody $ \status headers -> + Wai.responseLBS status headers $ BSL.concat [ "" , e , "

" @@ -200,7 +188,8 @@ runRWST (runErrorT $ runActionT $ selectedAction) env defResp case r of Left (ActionRedirect loc) -> - return $ Just $ ResponseState (rs_responseHeaders respState) status302 (ResponseRedirect loc) + return $ Just $ ResponseState (rs_responseHeaders respState) status302 $ ResponseBody $ + \status headers -> Wai.responseLBS status (("Location", T.encodeUtf8 loc) : headers) BSL.empty Left ActionTryNext -> applyAction req mkEnv xs Left (ActionError errorMsg) -> diff --git a/src/Web/Spock/Safe.hs b/src/Web/Spock/Safe.hs --- a/src/Web/Spock/Safe.hs +++ b/src/Web/Spock/Safe.hs @@ -111,12 +111,12 @@ -- -- > subcomponent "site" $ -- > do get "home" homeHandler --- > get ("misc" <> var) $ -- ... +-- > get ("misc" var) $ -- ... -- > subcomponent "admin" $ -- > do get "home" adminHomeHandler -- --- The request "/site/home" will be routed to homeHandler and the --- request "/admin/home" will be routed to adminHomeHandler +-- The request \/site\/home will be routed to homeHandler and the +-- request \/admin\/home will be routed to adminHomeHandler subcomponent :: Monad m => Path '[] -> SpockT m () -> SpockT m () subcomponent p (SpockT subapp) = SpockT $ C.subcomponent (SafeRouterPath p) subapp @@ -134,9 +134,8 @@ -- > do runQuery $ deleteUserFromDb i -- > redirect "/user-list" -- > --- > get "/user-details/:userId" $ --- > do userId <- param' "userId" --- > deleteUrl <- safeActionPath (DeleteUser userId) +-- > get ("user-details" var) $ \userId -> +-- > do deleteUrl <- safeActionPath (DeleteUser userId) -- > html $ "Click here to delete user!" -- -- Note that safeActions currently only support GET and POST requests. diff --git a/src/Web/Spock/Shared.hs b/src/Web/Spock/Shared.hs --- a/src/Web/Spock/Shared.hs +++ b/src/Web/Spock/Shared.hs @@ -20,7 +20,7 @@ , params, param, param' -- * Sending responses , setStatus, setHeader, redirect, jumpNext, setCookie, setCookie', bytes, lazyBytes - , text, html, file, json + , text, html, file, json, stream, response -- * Middleware helpers , middlewarePass, modifyVault, queryVault -- * Database diff --git a/src/Web/Spock/Simple.hs b/src/Web/Spock/Simple.hs --- a/src/Web/Spock/Simple.hs +++ b/src/Web/Spock/Simple.hs @@ -26,7 +26,6 @@ where import Web.Spock.Shared -import Web.Spock.Internal.CoreAction import Web.Spock.Internal.Types import qualified Web.Spock.Internal.Core as C @@ -52,8 +51,11 @@ newtype SpockRoute = SpockRoute { _unSpockRoute :: T.Text } - deriving (Eq, Ord, Show, Read, IsString) + deriving (Eq, Ord, Show, Read) +instance IsString SpockRoute where + fromString str = SpockRoute $ combineRoute (T.pack str) "" + -- | Create a spock application using a given db storageLayer and an initial state. -- Spock works with database libraries that already implement connection pooling and -- with those that don't come with it out of the box. For more see the 'PoolOrConn' type. @@ -76,9 +78,15 @@ C.spockAllT TextRouter liftFun app -- | Combine two route components safely --- "/foo" "/bar" ===> "/foo/bar" --- "foo" "bar" ===> "/foo/bar" --- "foo "/bar" ===> "/foo/bar" +-- +-- >>> "/foo" "/bar" +-- "/foo/bar" +-- +-- >>> "foo" "bar" +-- "/foo/bar" +-- +-- >>> "foo "/bar" +-- "/foo/bar" () :: SpockRoute -> SpockRoute -> SpockRoute (SpockRoute t) (SpockRoute t') = SpockRoute $ combineRoute t t' @@ -117,14 +125,14 @@ -- | Define a subcomponent. Usage example: -- --- > subcomponent "/site" $ --- > do get "/home" homeHandler --- > get "/misc/:param" $ -- ... +-- > subcomponent "site" $ +-- > do get "home" homeHandler +-- > get ("misc" ":param") $ -- ... -- > subcomponent "/admin" $ --- > do get "/home" adminHomeHandler +-- > get "home" adminHomeHandler -- --- The request /site/home will be routed to homeHandler and the --- request /admin/home will be routed to adminHomeHandler +-- The request \/site\/home will be routed to homeHandler and the +-- request \/admin\/home will be routed to adminHomeHandler subcomponent :: Monad m => SpockRoute -> SpockT m () -> SpockT m () subcomponent (SpockRoute p) (SpockT subapp) = SpockT $ C.subcomponent (TextRouterPath p) subapp @@ -142,7 +150,7 @@ -- > do runQuery $ deleteUserFromDb i -- > redirect "/user-list" -- > --- > get "/user-details/:userId" $ +-- > get ("user-details" ":userId") $ -- > do userId <- param' "userId" -- > deleteUrl <- safeActionPath (DeleteUser userId) -- > html $ "Click here to delete user!" @@ -169,8 +177,8 @@ , SpockState (SpockAction conn sess st) ~ st) => SpockM conn sess st () hookSafeActions = - do get "/h/:spock-csurf-protection" run - post "/h/:spock-csurf-protection" run + do get ("h" ":spock-csurf-protection") run + post ("h" ":spock-csurf-protection") run where run = do Just h <- param "spock-csurf-protection" diff --git a/test/Web/Spock/FrameworkSpecHelper.hs b/test/Web/Spock/FrameworkSpecHelper.hs --- a/test/Web/Spock/FrameworkSpecHelper.hs +++ b/test/Web/Spock/FrameworkSpecHelper.hs @@ -36,6 +36,11 @@ do get "/askldjas/aklsdj" `shouldRespondWith` "askldjas/aklsdj" { matchStatus = 200 } it "detected the preferred format" $ do request "GET" "/preferred-format" [("Accept", "text/html,application/xml;q=0.9,image/webp,*/*;q=0.8")] "" `shouldRespondWith` "html" { matchStatus = 200 } + it "/test-slash and test-noslash are the same thing" $ + do get "/test-slash" `shouldRespondWith` "ok" { matchStatus = 200 } + get "test-slash" `shouldRespondWith` "ok" { matchStatus = 200 } + get "/test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 } + get "test-noslash" `shouldRespondWith` "ok" { matchStatus = 200 } where verbTest verb verbVerbose = (verb "/verb-test") diff --git a/test/Web/Spock/SafeSpec.hs b/test/Web/Spock/SafeSpec.hs --- a/test/Web/Spock/SafeSpec.hs +++ b/test/Web/Spock/SafeSpec.hs @@ -17,6 +17,8 @@ put "verb-test" $ text "PUT" delete "verb-test" $ text "DELETE" patch "verb-test" $ text "PATCH" + get "test-slash" $ text "ok" + get "/test-noslash" $ text "ok" get ("param-test" var) $ \(i :: Int) -> text $ "int" <> (T.pack $ show i) get ("param-test" "static") $ diff --git a/test/Web/Spock/SimpleSpec.hs b/test/Web/Spock/SimpleSpec.hs --- a/test/Web/Spock/SimpleSpec.hs +++ b/test/Web/Spock/SimpleSpec.hs @@ -17,6 +17,8 @@ put "/verb-test" $ text "PUT" delete "/verb-test" $ text "DELETE" patch "/verb-test" $ text "PATCH" + get "test-slash" $ text "ok" + get "/test-noslash" $ text "ok" get "/param-test/:int" $ do Just (i :: Int) <- param "int" text $ "int" <> (T.pack $ show i)