Incomplete SimpleApp

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"

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

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

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