diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 95e3b4f1..6d510850 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -28,6 +28,15 @@ module Yesod.Core.Dispatch , mkDefaultMiddlewares -- * WAI subsites , WaiSubsite (..) + -- * Simpler apps + , SimpleApp + , SimpleHandler + , SimpleWidget + , serveHandler + , onMethod + , onStatic + , withDynamic + , withDynamicMulti ) where import Prelude hiding (exp) @@ -47,11 +56,13 @@ import qualified Blaze.ByteString.Builder import Network.HTTP.Types (status301) import Yesod.Routes.Parse import Yesod.Core.Types +import Yesod.Core.Content import Yesod.Core.Class.Yesod import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Safe (readMay) import System.Environment (getEnvironment) +import Data.Monoid (Monoid (..)) import Network.Wai.Middleware.Autohead import Network.Wai.Middleware.AcceptOverride @@ -178,3 +189,28 @@ warpEnv site = do case readMay portS of Nothing -> error $ "warpEnv: invalid PORT environment variable: " ++ show portS Just port -> warp port site + +data SimpleApp = SimpleApp + +instance Yesod SimpleApp +instance YesodDispatch SimpleApp + +instance Monoid SimpleApp where + +type SimpleHandler = HandlerT SimpleApp IO +type SimpleWidget = WidgetT SimpleApp IO + +serveHandler :: ToTypedContent a => SimpleHandler a -> SimpleApp +serveHandler = error "serveHandler" + +onMethod :: Text -> SimpleApp -> SimpleApp +onMethod = error "onMethod" + +onStatic :: Text -> SimpleApp -> SimpleApp +onStatic = error "onStatic" + +withDynamic :: PathPiece p => (p -> SimpleApp) -> SimpleApp +withDynamic = error "withDynamic" + +withDynamicMulti :: PathMultiPiece ps => (ps -> SimpleApp) -> SimpleApp +withDynamicMulti = error "withDynamicMulti" diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index dc220d33..7b239ecf 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -16,6 +16,7 @@ import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth +import qualified YesodCoreTest.SimpleApp as SimpleApp import Test.Hspec @@ -37,3 +38,4 @@ specs = do Json.specs Reps.specs Auth.specs + SimpleApp.specs diff --git a/yesod-core/test/YesodCoreTest/SimpleApp.hs b/yesod-core/test/YesodCoreTest/SimpleApp.hs new file mode 100644 index 00000000..a803a8f3 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/SimpleApp.hs @@ -0,0 +1,39 @@ +module YesodCoreTest.SimpleApp (specs) where + +import Yesod.Core +import Test.Hspec +import Network.Wai.Test +import Network.Wai +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Text as T +import Data.Monoid +import qualified Data.ByteString.Lazy.Char8 as L8 + +iapp :: IO Application +iapp = toWaiApp $ + onMethod (T.pack "GET") (serveHandler $ return "GetHomepage") <> + onMethod (T.pack "POST") (serveHandler $ return "PostHomepage") <> + onStatic (T.pack "string") (withDynamic (\t -> serveHandler $ return (t :: T.Text))) + +test :: String -- ^ method + -> [String] -- ^ path + -> (Either Int String) -- ^ status code or body + -> Spec +test method path expected = it (method ++ " " ++ show path) $ do + app <- iapp + flip runSession app $ do + sres <- request defaultRequest + { requestMethod = S8.pack method + , pathInfo = map T.pack path + } + case expected of + Left i -> assertStatus i sres + Right b -> assertBody (L8.pack b) sres + +specs :: Spec +specs = describe "SimpleApp" $ do + test "GET" [] $ Right "GetHomepage" + test "POST" [] $ Right "PostHomepage" + test "PUT" [] $ Left 405 + test "GET" ["string", "foo"] $ Right "foo" + test "GET" ["string!", "foo"] $ Left 404 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 53464884..7324e3a3 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -35,6 +35,7 @@ extra-source-files: test/YesodCoreTest/Widget.hs test/YesodCoreTest/YesodTest.hs test/YesodCoreTest/Auth.hs + test/YesodCoreTest/SimpleApp.hs test/en.msg test/test.hs