packages feed

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