Spock-core 0.12.0.0 → 0.13.0.0
raw patch · 7 files changed
+175/−65 lines, 7 filesdep +monad-controldep +transformers-basedep ~mtldep ~reroutePVP ok
version bump matches the API change (PVP)
Dependencies added: monad-control, transformers-base
Dependency ranges changed: mtl, reroute
API changes (from Hackage documentation)
- Web.Spock.Core: spockLimT :: forall m. MonadIO m => Maybe Word64 -> (forall a. m a -> IO a) -> SpockT m () -> IO Middleware
- Web.Spock.Core: subcomponent :: (RouteM t, Monad m) => Path '[] Open -> t ctx m () -> t ctx m ()
- Web.Spock.Routing: inSubcomponent :: (RouteM t, Monad m) => Path '[] Open -> t ctx m () -> t ctx m ()
+ Web.Spock.Core: MethodAny :: SpockMethod
+ Web.Spock.Core: [sc_logError] :: SpockConfig -> Text -> IO ()
+ Web.Spock.Core: hookAnyAll :: (RouteM t, Monad m) => ([Text] -> ActionCtxT ctx m ()) -> t ctx m ()
+ Web.Spock.Core: hookRouteAll :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
- Web.Spock.Core: (<//>) :: Path as Open -> Path bs ps -> Path (Append as bs) ps
+ Web.Spock.Core: (<//>) :: Path as 'Open -> Path bs ps -> Path (Append as bs) ps
- Web.Spock.Core: SpockConfig :: Maybe Word64 -> (Status -> ActionCtxT () IO ()) -> SpockConfig
+ Web.Spock.Core: SpockConfig :: Maybe Word64 -> (Status -> ActionCtxT () IO ()) -> (Text -> IO ()) -> SpockConfig
- Web.Spock.Core: renderRoute :: AllHave ToHttpApiData as => Path as Open -> HVectElim as Text
+ Web.Spock.Core: renderRoute :: AllHave ToHttpApiData as => Path as 'Open -> HVectElim as Text
- Web.Spock.Core: root :: Path ([] *) Open
+ Web.Spock.Core: root :: Path [] * Open
- Web.Spock.Core: static :: String -> Path ([] *) Open
+ Web.Spock.Core: static :: String -> Path [] * Open
- Web.Spock.Core: type Var a = Path ((:) * a ([] *)) Open
+ Web.Spock.Core: type Var a = Path (:) * a [] * Open
- Web.Spock.Core: var :: (Typeable * a, FromHttpApiData a) => Path ((:) * a ([] *)) Open
+ Web.Spock.Core: var :: (Typeable * a, FromHttpApiData a) => Path (:) * a [] * Open
- Web.Spock.Core: wildcard :: Path ((:) * Text ([] *)) Closed
+ Web.Spock.Core: wildcard :: Path (:) * Text [] * Closed
Files
- Spock-core.cabal +7/−3
- src/Web/Spock/Core.hs +32/−36
- src/Web/Spock/Internal/Config.hs +10/−3
- src/Web/Spock/Internal/Wire.hs +65/−18
- src/Web/Spock/Routing.hs +4/−5
- test/Web/Spock/FrameworkSpecHelper.hs +8/−0
- test/Web/Spock/SafeSpec.hs +49/−0
Spock-core.cabal view
@@ -1,5 +1,5 @@ name: Spock-core-version: 0.12.0.0+version: 0.13.0.0 synopsis: Another Haskell web framework for rapid development description: Barebones high performance type safe web framework Homepage: https://www.spock.li@@ -41,22 +41,24 @@ hashable >=1.2, http-types >=0.8, hvect >= 0.4,+ monad-control >= 1.0, mtl >=2.1, http-api-data >= 0.2, old-locale >=1.0,- reroute >=0.3.1,+ reroute >=0.5, resourcet >= 0.4, stm >=2.4, superbuffer >= 0.2, text >= 0.11.3.1, time >=1.4, transformers >=0.3,+ transformers-base >=0.4, unordered-containers >=0.2, vault >=0.3, wai >=3.0, wai-extra >=3.0, warp >=3.0- ghc-options: -auto-all -Wall -fno-warn-orphans+ ghc-options: -Wall -fno-warn-orphans test-suite spockcoretests type: exitcode-stdio-1.0@@ -75,11 +77,13 @@ hspec >= 2.0, hspec-wai >= 0.6, http-types,+ monad-control, Spock-core, reroute, text, time, transformers >=0.3,+ transformers-base, unordered-containers, wai
src/Web/Spock/Core.hs view
@@ -10,14 +10,16 @@ ( -- * Lauching Spock runSpock, runSpockNoBanner, spockAsApp -- * Spock's route definition monad- , spockT, spockLimT, spockConfigT, SpockT, SpockCtxT+ , spockT, spockConfigT, SpockT, SpockCtxT -- * Defining routes , Path, root, Var, var, static, (<//>), wildcard -- * Rendering routes , renderRoute -- * Hooking routes- , subcomponent, prehook+ , prehook , get, post, getpost, head, put, delete, patch, hookRoute, hookRouteCustom, hookAny, hookAnyCustom+ , hookRouteAll+ , hookAnyAll , Http.StdMethod (..) -- * Adding Wai.Middleware , middleware@@ -38,9 +40,9 @@ import Control.Applicative import Control.Monad.Reader import Data.HVect hiding (head)-import Data.Word import Network.HTTP.Types.Method import Prelude hiding (head, uncurry, curry)+import System.IO import Web.HttpApiData import Web.Routing.Combinators hiding (renderRoute) import Web.Routing.Router (swapMonad)@@ -73,12 +75,15 @@ instance RouteM SpockCtxT where addMiddleware = SpockCtxT . AR.middleware- inSubcomponent p (SpockCtxT subapp) =- SpockCtxT $ AR.subcomponent (toInternalPath p) subapp wireAny m action = SpockCtxT $ do hookLift <- lift $ asks unLiftHooked- AR.hookAny m (hookLift . action)+ case m of+ MethodAny ->+ do forM_ allStdMethods $ \mReg ->+ AR.hookAny mReg (hookLift . action)+ AR.hookAnyMethod (hookLift . action)+ _ -> AR.hookAny m (hookLift . action) withPrehook = withPrehookImpl wireRoute = wireRouteImpl @@ -101,13 +106,20 @@ do hookLift <- lift $ asks unLiftHooked let actionPacker :: HVectElim xs (ActionCtxT ctx m ()) -> HVect xs -> ActionCtxT () m () actionPacker act captures = hookLift (uncurry act captures)- AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ case m of+ MethodAny ->+ do forM_ allStdMethods $ \mReg ->+ AR.hookRoute mReg (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ AR.hookRouteAnyMethod (toInternalPath path) (HVectElim' $ curry $ actionPacker action)+ _ -> AR.hookRoute m (toInternalPath path) (HVectElim' $ curry $ actionPacker action) +allStdMethods :: [SpockMethod]+allStdMethods = MethodStandard <$> [minBound .. maxBound] -- | Run a Spock application. Basically just a wrapper around 'Warp.run'. runSpock :: Warp.Port -> IO Wai.Middleware -> IO () runSpock port mw =- do putStrLn ("Spock is running on port " ++ show port)+ do hPutStrLn stderr ("Spock is running on port " ++ show port) app <- spockAsApp mw Warp.run port app @@ -120,7 +132,7 @@ -- | Convert a middleware to an application. All failing requests will -- result in a 404 page spockAsApp :: IO Wai.Middleware -> IO Wai.Application-spockAsApp = liftM W.middlewareToApp+spockAsApp = fmap W.middlewareToApp -- | Create a raw spock application with custom underlying monad -- Use 'runSpock' to run the app or 'spockAsApp' to create a @Wai.Application@@@ -131,17 +143,6 @@ -> IO Wai.Middleware spockT = spockConfigT defaultSpockConfig --- | Like 'spockT', but first argument is request size limit in bytes. Set to 'Nothing' to disable.-{-# DEPRECATED spockLimT "Consider using spockConfigT instead" #-}-spockLimT :: forall m .MonadIO m- => Maybe Word64- -> (forall a. m a -> IO a)- -> SpockT m ()- -> IO Wai.Middleware-spockLimT mSizeLimit =- let spockConfigWithLimit = defaultSpockConfig { sc_maxRequestSize = mSizeLimit }- in spockConfigT spockConfigWithLimit- -- | Like 'spockT', but with additional configuration for request size and error -- handlers passed as first parameter. spockConfigT :: forall m .MonadIO m@@ -149,10 +150,10 @@ -> (forall a. m a -> IO a) -> SpockT m () -> IO Wai.Middleware-spockConfigT (SpockConfig maxRequestSize errorAction) liftFun app =+spockConfigT (SpockConfig maxRequestSize errorAction logError) liftFun app = W.buildMiddleware internalConfig liftFun (baseAppHook app) where- internalConfig = W.SpockConfigInternal maxRequestSize errorHandler+ internalConfig = W.SpockConfigInternal maxRequestSize errorHandler logError errorHandler status = spockAsApp $ W.buildMiddleware W.defaultSpockConfigInternal id $ baseAppHook $ errorApp status errorApp status = mapM_ (\method -> hookAny method $ \_ -> errorAction' status) [minBound .. maxBound] errorAction' status = setStatus status >> errorAction status@@ -200,6 +201,10 @@ hookRoute :: (HasRep xs, RouteM t, Monad m) => StdMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m () hookRoute = hookRoute' . MethodStandard . W.HttpMethod +-- | Specify an action that will be run regardless of the HTTP verb+hookRouteAll :: (HasRep xs, RouteM t, Monad m) => Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()+hookRouteAll = hookRoute' MethodAny+ -- | Specify an action that will be run when a custom HTTP verb and the given route match hookRouteCustom :: (HasRep xs, RouteM t, Monad m) => T.Text -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m () hookRouteCustom = hookRoute' . MethodCustom@@ -213,6 +218,11 @@ hookAny :: (RouteM t, Monad m) => StdMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m () hookAny = hookAny' . MethodStandard . W.HttpMethod +-- | Specify an action that will be run regardless of the HTTP verb and no defined route matches.+-- The full path is passed as an argument+hookAnyAll :: (RouteM t, Monad m) => ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()+hookAnyAll = hookAny' MethodAny+ -- | Specify an action that will be run when a custom HTTP verb matches but no defined route matches. -- The full path is passed as an argument hookAnyCustom :: (RouteM t, Monad m) => T.Text -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()@@ -222,20 +232,6 @@ -- The full path is passed as an argument hookAny' :: (RouteM t, Monad m) => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m () hookAny' = wireAny---- | Define a subcomponent. Usage example:------ > subcomponent "site" $--- > do get "home" homeHandler--- > 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-subcomponent :: (RouteM t, Monad m) => Path '[] 'Open -> t ctx m () -> t ctx m ()-subcomponent = inSubcomponent-{-# DEPRECATED subcomponent "Subcomponents will be removed in the next major release. They break route rendering and should not be used. Consider creating helper functions for reusable route components" #-} -- | Hook wai middleware into Spock middleware :: (RouteM t, Monad m) => Wai.Middleware -> t ctx m ()
src/Web/Spock/Internal/Config.hs view
@@ -1,10 +1,14 @@ {-# LANGUAGE RankNTypes #-} module Web.Spock.Internal.Config where +import qualified Web.Spock.Internal.Wire as W+ import Data.Word import Network.HTTP.Types.Status+import System.IO import Web.Spock.Internal.CoreAction-import qualified Web.Spock.Internal.Wire as W+import qualified Data.Text as T+import qualified Data.Text.IO as T data SpockConfig@@ -14,11 +18,14 @@ , sc_errorHandler :: Status -> W.ActionCtxT () IO () -- ^ Error handler. Given status is set in response by default, but you -- can always override it with `setStatus`+ , sc_logError :: T.Text -> IO ()+ -- ^ Function that should be called to log errors. } -- | Default Spock configuration. No restriction on maximum request size; error--- handler simply prints status message as plain text.+-- handler simply prints status message as plain text and all errors are logged+-- to stderr. defaultSpockConfig :: SpockConfig-defaultSpockConfig = SpockConfig Nothing defaultHandler+defaultSpockConfig = SpockConfig Nothing defaultHandler (T.hPutStrLn stderr) where defaultHandler = bytes . statusMessage
src/Web/Spock/Internal/Wire.hs view
@@ -4,13 +4,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} module Web.Spock.Internal.Wire where import Control.Applicative@@ -18,17 +21,20 @@ import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Exception-import Control.Monad.RWS.Strict+import Control.Monad.Base+import Control.Monad.RWS.Strict hiding ((<>)) #if MIN_VERSION_mtl(2,2,0) import Control.Monad.Except #else import Control.Monad.Error #endif import Control.Monad.Reader.Class ()+import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Data.Hashable import Data.IORef import Data.Maybe+import Data.Semigroup import Data.Typeable import Data.Word import GHC.Generics@@ -41,6 +47,7 @@ import Prelude hiding (catch) #endif import System.Directory+import System.IO import Web.Routing.Router import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL@@ -50,24 +57,27 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T import qualified Data.Vault.Lazy as V import qualified Network.Wai as Wai import qualified Network.Wai.Parse as P newtype HttpMethod = HttpMethod { unHttpMethod :: StdMethod }- deriving (Show, Eq, Generic)+ deriving (Show, Eq, Bounded, Enum, Generic) instance Hashable HttpMethod where hashWithSalt = hashUsing (fromEnum . unHttpMethod) --- | The 'SpockMethod' allows safe use of http verbs via the 'MethodStandard' constructor and 'StdMethod',--- and custom verbs via the 'MethodCustom' constructor.+-- | The 'SpockMethod' allows safe use of http verbs via the 'MethodStandard'+-- constructor and 'StdMethod', and custom verbs via the 'MethodCustom' constructor. data SpockMethod -- | Standard HTTP Verbs from 'StdMethod' = MethodStandard !HttpMethod -- | Custom HTTP Verbs using 'T.Text' | MethodCustom !T.Text+ -- | Match any HTTP verb+ | MethodAny deriving (Eq, Generic) instance Hashable SpockMethod@@ -183,9 +193,11 @@ HM.fromList $ flip map allHeaders $ \mh -> (multiHeaderCI mh, mh) where- -- this is a nasty hack until we know more about the origin of- -- uncaught exception: ErrorCall (toEnum{MultiHeader}: tag (-12565) is outside of enumeration's range (0,12))- -- see: https://ghc.haskell.org/trac/ghc/ticket/10792 and https://github.com/agrafix/Spock/issues/44+ -- this is a nasty hack until we know more about the origin of uncaught+ -- exception: ErrorCall (toEnum{MultiHeader}: tag (-12565) is outside of+ -- enumeration's range (0,12)) see:+ -- https://ghc.haskell.org/trac/ghc/ticket/10792 and+ -- https://github.com/agrafix/Spock/issues/44 allHeaders = [ MultiHeaderCacheControl , MultiHeaderConnection@@ -224,15 +236,25 @@ | ActionApplication !(IO Wai.Application) deriving Typeable +instance Semigroup ActionInterupt where+ _ <> a = a+ instance Monoid ActionInterupt where mempty = ActionDone- mappend _ a = a+ mappend = (<>) #if MIN_VERSION_mtl(2,2,0) type ErrorT = ExceptT+ runErrorT :: ExceptT e m a -> m (Either e a) runErrorT = runExceptT++toErrorT :: m (Either e a) -> ErrorT e m a+toErrorT = ExceptT #else+toErrorT :: m (Either e a) -> ErrorT e m a+toErrorT = ErrorT+ instance Error ActionInterupt where noMsg = ActionError "Unkown Internal Action Error" strMsg = ActionError@@ -251,18 +273,38 @@ instance MonadTrans (ActionCtxT ctx) where lift = ActionCtxT . lift . lift +instance MonadTransControl (ActionCtxT ctx) where+ type StT (ActionCtxT ctx) a = (Either ActionInterupt a, ResponseState, ())+ liftWith f =+ ActionCtxT . toErrorT . RWST $ \requestInfo responseState ->+ fmap+ (\x -> (pure x, responseState, ()))+ (f $ \(ActionCtxT lala) -> runRWST (runErrorT lala) requestInfo responseState)+ restoreT mSt = ActionCtxT . toErrorT $ RWST (\_ _ -> mSt)++instance MonadBase b m => MonadBase b (ActionCtxT ctx m) where+ liftBase = liftBaseDefault++instance MonadBaseControl b m => MonadBaseControl b (ActionCtxT ctx m) where+ type StM (ActionCtxT ctx m) a = ComposeSt (ActionCtxT ctx) m a+ liftBaseWith = defaultLiftBaseWith+ restoreM = defaultRestoreM+ data SpockConfigInternal = SpockConfigInternal { sci_maxRequestSize :: Maybe Word64 , sci_errorHandler :: Status -> IO Wai.Application+ , sci_logError :: T.Text -> IO () } defaultSpockConfigInternal :: SpockConfigInternal-defaultSpockConfigInternal = SpockConfigInternal Nothing defaultErrorHandler- where- defaultErrorHandler status = return $ \_ respond -> do- let errorMessage = "Error handler failed with status code " ++ (show $ statusCode status)- respond $ Wai.responseLBS status500 [] $ BSLC.pack errorMessage+defaultSpockConfigInternal =+ SpockConfigInternal Nothing defaultErrorHandler (T.hPutStrLn stderr)+ where+ defaultErrorHandler status = return $ \_ respond ->+ do let errorMessage =+ "Error handler failed with status code " ++ show (statusCode status)+ respond $ Wai.responseLBS status500 [] $ BSLC.pack errorMessage respStateToResponse :: ResponseVal -> Wai.Response respStateToResponse (ResponseValState (ResponseState headers multiHeaders status (ResponseBody body))) =@@ -277,7 +319,7 @@ errorResponse :: Status -> BSL.ByteString -> ResponseVal errorResponse s e =- ResponseValState $+ ResponseValState ResponseState { rs_responseHeaders = HM.singleton "Content-Type" "text/html"@@ -318,7 +360,8 @@ fallbackApp _ respond = respond notFound notFound = respStateToResponse $ errorResponse status404 "404 - File not found" -makeActionEnvironment :: InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault, IO ())+makeActionEnvironment ::+ InternalState -> SpockMethod -> Wai.Request -> IO (RequestInfo (), TVar V.Vault, IO ()) makeActionEnvironment st stdMethod req = do vaultVar <- liftIO $ newTVarIO (Wai.vault req) let vaultIf =@@ -417,8 +460,10 @@ Left ActionTryNext -> applyAction config req env xs Left (ActionError errorMsg) ->- do liftIO $ putStrLn $ "Spock Error while handling "- ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg+ do liftIO $ sci_logError config $+ T.pack $+ "Spock Error while handling "+ ++ show (Wai.pathInfo req) ++ ": " ++ errorMsg return $ Just $ getErrorHandler config status500 Left ActionDone -> return $ Just (ResponseValState respState)@@ -469,7 +514,9 @@ [ Handler $ \(_ :: SizeException) -> return (Just $ getErrorHandler config status413) , Handler $ \(e :: SomeException) ->- do putStrLn $ "Spock Error while handling " ++ show (Wai.pathInfo req) ++ ": " ++ show e+ do sci_logError config $ T.pack $+ "Spock Error while handling " ++ show (Wai.pathInfo req)+ ++ ": " ++ show e return $ Just $ getErrorHandler config status500 ] cleanUp
src/Web/Spock/Routing.hs view
@@ -7,14 +7,13 @@ import Control.Monad.Trans import Data.HVect hiding (head) import Web.Routing.Combinators-import qualified Network.Wai as Wai import qualified Data.Text as T+import qualified Network.Wai as Wai class RouteM t where addMiddleware :: Monad m => Wai.Middleware -> t ctx m ()- inSubcomponent :: Monad m => Path '[] 'Open -> t ctx m () -> t ctx m () withPrehook :: MonadIO m => ActionCtxT ctx m ctx' -> t ctx' m () -> t ctx m ()- wireAny ::- Monad m => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m ()+ wireAny :: Monad m => SpockMethod -> ([T.Text] -> ActionCtxT ctx m ()) -> t ctx m () wireRoute ::- (Monad m, HasRep xs) => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()+ (Monad m, HasRep xs)+ => SpockMethod -> Path xs ps -> HVectElim xs (ActionCtxT ctx m ()) -> t ctx m ()
test/Web/Spock/FrameworkSpecHelper.hs view
@@ -8,7 +8,10 @@ import Test.Hspec.Wai.Matcher #endif +#if MIN_VERSION_base(4,11,0)+#else import Data.Monoid+#endif import Data.Word import Network.HTTP.Types.Header import Network.HTTP.Types.Method@@ -83,6 +86,11 @@ post "/raw-body" "raw" `shouldRespondWith` "raw" { matchStatus = 200 } it "allows empty raw body" $ post "/raw-body" "" `shouldRespondWith` "" { matchStatus = 200 }+ it "matches regardless of the VERB" $+ do get "/all/verbs" `shouldRespondWith` "ok" { matchStatus = 200 }+ post "/all/verbs" "" `shouldRespondWith` "ok" { matchStatus = 200 }+ request "FIZZBUZZ" "/all/verbs" [] "" `shouldRespondWith` "ok" { matchStatus = 200 }+ request "NOTIFY" "/all/verbs" [] "" `shouldRespondWith` "ok" { matchStatus = 200 } it "routes different HTTP-verbs to different actions" $ do verbTest get "GET" verbTest (`post` "") "POST"
test/Web/Spock/SafeSpec.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-} module Web.Spock.SafeSpec (spec) where import Web.Spock.Core@@ -9,11 +11,18 @@ import Control.Exception.Base import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Trans.Reader import Data.Aeson+#if MIN_VERSION_base(4,11,0)+#else import Data.Monoid+#endif import GHC.Generics import Network.HTTP.Types.Status import Test.Hspec+import qualified Control.Exception as Exception import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -86,6 +95,7 @@ do setStatus status401 text "err" in requireBasicAuth "Foo" checker $ \() -> text "ok"+ hookRouteAll ("all" <//> "verbs") $ text "ok" hookRouteCustom "NOTIFY" ("notify" <//> var) $ \notification -> text notification hookAny GET $ text . T.intercalate "/" hookAnyCustom "MYVERB" $ text . T.intercalate "/"@@ -112,6 +122,44 @@ let r3 = "blog" <//> (var :: Var Int) <//> (var :: Var T.Text) renderRoute r3 2 "BIIM" `shouldBe` "/blog/2/BIIM" +data InstancesTestException = InstancesTestException deriving Show+instance Exception InstancesTestException++instancesApp :: SpockCtxT () (ReaderT T.Text IO) ()+instancesApp =+ do get ("instances" <//> "monad-base") $ text =<< liftBase (pure "ok")+ get ("instances" <//> "monad-base-control") $+ do res <-+ catch'+ (throwIO' InstancesTestException)+ (\(_ :: InstancesTestException) -> pure "ok")+ text res+ get ("instances" <//> "monad-trans-control") $+ do res <- liftWith (\run -> ask >>= run . text)+ restoreT $ pure res+ where+ -- This is 'catch' from 'Control.Exception.Lifted'.+ catch' :: (MonadBaseControl IO m, Exception e) => m a -> (e -> m a) -> m a+ catch' a handler =+ control $ \runInIO ->+ Exception.catch (runInIO a) (\e -> runInIO $ handler e)++ -- This is 'throwIO' from 'Control.Exception.Lifted'.+ throwIO' :: (MonadBase IO m, Exception e) => e -> m a+ throwIO' = liftBase . Exception.throwIO+++instancesSpec :: Spec+instancesSpec =+ describe "Instances for ActionT are correct" $+ Test.with (spockAsApp $ spockT (flip runReaderT "ok") instancesApp) $+ do it "MonadBase" $+ Test.request "GET" "/instances/monad-base" [] "" `Test.shouldRespondWith` "ok"+ it "MonadBaseControl" $+ Test.request "GET" "/instances/monad-base-control" [] "" `Test.shouldRespondWith` "ok"+ it "MonadTransControl" $+ Test.request "GET" "/instances/monad-trans-control" [] "" `Test.shouldRespondWith` "ok"+ ctxApp :: SpockT IO () ctxApp = prehook hook $@@ -138,6 +186,7 @@ describe "SafeRouting" $ do frameworkSpec (spockAsApp $ spockT id app) ctxSpec+ instancesSpec routeRenderingSpec sizeLimitSpec $ \lim -> spockAsApp $ spockConfigT (defaultSpockConfig { sc_maxRequestSize = Just lim }) id $ post "size" $ body >>= bytes