SimpleApp

yesod-core/Yesod/Core.hs

@@ -57,6 +57,8 @@ module Yesod.Core
     , yesodVersion
     , yesodRender
     , runFakeHandler
+      -- * SimpleApp
+    , module Yesod.Core.Internal.SimpleApp
       -- * Re-exports
     , module Yesod.Core.Content
     , module Yesod.Core.Dispatch
@@ -96,6 +98,7 @@ import Yesod.Routes.Class
 import Control.Monad.IO.Class (MonadIO (..))
 import Control.Monad.Base (MonadBase (..))
 import Control.Monad.Trans.Control (MonadBaseControl (..))
+import Yesod.Core.Internal.SimpleApp
 
 -- | Return an 'Unauthorized' value, with the given i18n message.
 unauthorizedI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m AuthResult

yesod-core/Yesod/Core/Dispatch.hs

@@ -28,15 +28,6 @@ module Yesod.Core.Dispatch
     , mkDefaultMiddlewares
       -- * WAI subsites
     , WaiSubsite (..)
-      -- * Simpler apps
-    , SimpleApp
-    , SimpleHandler
-    , SimpleWidget
-    , serveHandler
-    , onMethod
-    , onStatic
-    , withDynamic
-    , withDynamicMulti
     ) where
 
 import Prelude hiding (exp)
@@ -60,6 +51,7 @@ import Yesod.Core.Content
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
+import Yesod.Routes.Class
 import Safe (readMay)
 import System.Environment (getEnvironment)
 import Data.Monoid (Monoid (..))
@@ -189,28 +181,3 @@ 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/Yesod/Core/Internal/SimpleApp.hs

@@ -0,0 +1,82 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternGuards #-}
+module Yesod.Core.Internal.SimpleApp where
+
+import Yesod.Routes.Dispatch
+import Yesod.Routes.Class
+import Data.Monoid
+import Yesod.Core.Class.Yesod
+import Yesod.Core.Class.Dispatch
+import Yesod.Core.Types
+import Yesod.Core.Content
+import Data.Text (Text)
+import Web.PathPieces
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.ByteString (ByteString)
+import Network.Wai
+import Yesod.Core.Handler
+import Yesod.Core.Internal.Run
+import Network.HTTP.Types (Method)
+import Data.Maybe (fromMaybe)
+import Control.Applicative ((<|>))
+
+newtype SimpleApp = SimpleApp
+    { unSimpleApp :: Method -> [Text] -> Maybe (SimpleHandler TypedContent)
+    }
+
+instance Yesod SimpleApp
+
+instance YesodDispatch SimpleApp where
+    yesodDispatch yre req =
+        yesodRunner
+            (fromMaybe notFound $ f (requestMethod req) (pathInfo req))
+            yre
+            (Just $ SimpleAppRoute $ pathInfo req)
+            req
+      where
+        SimpleApp f = yreSite yre
+
+instance RenderRoute SimpleApp where
+    data Route SimpleApp = SimpleAppRoute [Text]
+        deriving (Show, Eq, Read, Ord)
+    renderRoute (SimpleAppRoute x) = (x, [])
+instance ParseRoute SimpleApp where
+    parseRoute (x, _) = Just $ SimpleAppRoute x
+
+instance Monoid SimpleApp where
+    mempty = SimpleApp $ \_ _ -> Nothing
+    mappend (SimpleApp x) (SimpleApp y) = SimpleApp $ \m ps -> x m ps <|> y m ps
+
+type SimpleHandler = HandlerT SimpleApp IO
+type SimpleWidget = WidgetT SimpleApp IO
+
+dispatchTo :: ToTypedContent a => SimpleHandler a -> SimpleApp
+dispatchTo handler = SimpleApp $ \_ ps ->
+    if null ps
+        then Just $ fmap toTypedContent handler
+        else Nothing
+
+onMethod :: Method -> SimpleApp -> SimpleApp
+onMethod method (SimpleApp f) = SimpleApp $ \m ps ->
+    if method == m
+        then f m ps
+        else Nothing
+
+onStatic :: Text -> SimpleApp -> SimpleApp
+onStatic p0 (SimpleApp f) = SimpleApp $ \m ps0 ->
+    case ps0 of
+        p:ps | p == p0 -> f m ps
+        _ -> Nothing
+
+withDynamic :: PathPiece p => (p -> SimpleApp) -> SimpleApp
+withDynamic f = SimpleApp $ \m ps0 ->
+    case ps0 of
+        p:ps | Just v <- fromPathPiece p -> unSimpleApp (f v) m ps
+        _ -> Nothing
+
+withDynamicMulti :: PathMultiPiece ps => (ps -> SimpleApp) -> SimpleApp
+withDynamicMulti f = SimpleApp $ \m ps ->
+    case fromPathMultiPiece ps of
+        Nothing -> Nothing
+        Just v -> unSimpleApp (f v) m []

yesod-core/test/YesodCoreTest/SimpleApp.hs

@@ -11,9 +11,10 @@ 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)))
+    onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage") <>
+    onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage") <>
+    onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text))) <>
+    onStatic (T.pack "multi") (withDynamicMulti (\[x, y] -> dispatchTo $ return (y :: T.Text)))
 
 test :: String -- ^ method
      -> [String] -- ^ path
@@ -34,6 +35,9 @@ specs :: Spec
 specs = describe "SimpleApp" $ do
     test "GET" [] $ Right "GetHomepage"
     test "POST" [] $ Right "PostHomepage"
-    test "PUT" [] $ Left 405
+    -- test "PUT" [] $ Left 405
     test "GET" ["string", "foo"] $ Right "foo"
+    test "DELETE" ["string", "bar"] $ Right "bar"
     test "GET" ["string!", "foo"] $ Left 404
+    test "GET" ["multi", "foo", "bar"] $ Right "bar"
+    test "GET" ["multi", "foo", "bar", "baz"] $ Left 500

yesod-core/yesod-core.cabal

@@ -107,6 +107,7 @@ library
                      Yesod.Core.Internal.Response
                      Yesod.Core.Internal.Run
                      Yesod.Core.Internal.TH
+                     Yesod.Core.Internal.SimpleApp
                      Yesod.Core.Class.Yesod
                      Yesod.Core.Class.Dispatch
                      Yesod.Core.Class.Breadcrumbs