haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

LiteApp uses a Writer monad

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-27 08:51:03 +02:00
parent 13173f65c6
commit d4422b656b
4 changed files with 26 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
demo/lite/lite.hs
View File

@ -7,9 +7,9 @@ import Data.Text (Text, pack)
people :: [(Text, Int)] people :: [(Text, Int)]
people = [("Alice", 25), ("Bob", 43), ("Charlie", 37)] people = [("Alice", 25), ("Bob", 43), ("Charlie", 37)]
main = warp 3000 $ main = warp 3000 $ liteApp $ do
onStatic "people" (dispatchTo getPeople) <> onStatic "people" $ dispatchTo getPeople
onStatic "person" (withDynamic $ dispatchTo . getPerson) onStatic "person" $ withDynamic $ dispatchTo . getPerson
getPeople = return $ toJSON $ map fst people getPeople = return $ toJSON $ map fst people

32
yesod-core/Yesod/Core/Internal/LiteApp.hs
View File

@ -16,6 +16,7 @@ import Yesod.Core.Internal.Run
import Network.HTTP.Types (Method) import Network.HTTP.Types (Method)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.Monad.Trans.Writer
newtype LiteApp = LiteApp newtype LiteApp = LiteApp
{ unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent) { unLiteApp :: Method -> [Text] -> Maybe (LiteHandler TypedContent)
@ -47,32 +48,35 @@ instance Monoid LiteApp where
type LiteHandler = HandlerT LiteApp IO type LiteHandler = HandlerT LiteApp IO
type LiteWidget = WidgetT LiteApp IO type LiteWidget = WidgetT LiteApp IO
dispatchTo :: ToTypedContent a => LiteHandler a -> LiteApp liteApp :: Writer LiteApp () -> LiteApp
dispatchTo handler = LiteApp $ \_ ps -> liteApp = execWriter
dispatchTo :: ToTypedContent a => LiteHandler a -> Writer LiteApp ()
dispatchTo handler = tell $ LiteApp $ \_ ps ->
if null ps if null ps
then Just $ fmap toTypedContent handler then Just $ fmap toTypedContent handler
else Nothing else Nothing
onMethod :: Method -> LiteApp -> LiteApp onMethod :: Method -> Writer LiteApp () -> Writer LiteApp ()
onMethod method (LiteApp f) = LiteApp $ \m ps -> onMethod method f = tell $ LiteApp $ \m ps ->
if method == m if method == m
then f m ps then unLiteApp (liteApp f) m ps
else Nothing else Nothing
onStatic :: Text -> LiteApp -> LiteApp onStatic :: Text -> Writer LiteApp () -> Writer LiteApp ()
onStatic p0 (LiteApp f) = LiteApp $ \m ps0 -> onStatic p0 f = tell $ LiteApp $ \m ps0 ->
case ps0 of case ps0 of
p:ps | p == p0 -> f m ps p:ps | p == p0 -> unLiteApp (liteApp f) m ps
_ -> Nothing _ -> Nothing
withDynamic :: PathPiece p => (p -> LiteApp) -> LiteApp withDynamic :: PathPiece p => (p -> Writer LiteApp ()) -> Writer LiteApp ()
withDynamic f = LiteApp $ \m ps0 -> withDynamic f = tell $ LiteApp $ \m ps0 ->
case ps0 of case ps0 of
p:ps | Just v <- fromPathPiece p -> unLiteApp (f v) m ps p:ps | Just v <- fromPathPiece p -> unLiteApp (liteApp $ f v) m ps
_ -> Nothing _ -> Nothing
withDynamicMulti :: PathMultiPiece ps => (ps -> LiteApp) -> LiteApp withDynamicMulti :: PathMultiPiece ps => (ps -> Writer LiteApp ()) -> Writer LiteApp ()
withDynamicMulti f = LiteApp $ \m ps -> withDynamicMulti f = tell $ LiteApp $ \m ps ->
case fromPathMultiPiece ps of case fromPathMultiPiece ps of
Nothing -> Nothing Nothing -> Nothing
Just v -> unLiteApp (f v) m [] Just v -> unLiteApp (liteApp $ f v) m []

9
yesod-core/test/YesodCoreTest/LiteApp.hs
View File

@ -6,14 +6,13 @@ import Network.Wai.Test
import Network.Wai import Network.Wai
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T import qualified Data.Text as T
import Data.Monoid
import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.Char8 as L8
iapp :: IO Application iapp :: IO Application
iapp = toWaiApp $ iapp = toWaiApp $ liteApp $ do
onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage") <> onMethod (S8.pack "GET") (dispatchTo $ return "GetHomepage")
onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage") <> onMethod (S8.pack "POST") (dispatchTo $ return "PostHomepage")
onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text))) <> onStatic (T.pack "string") (withDynamic (\t -> dispatchTo $ return (t :: T.Text)))
onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text))) onStatic (T.pack "multi") (withDynamicMulti (\[_, y] -> dispatchTo $ return (y :: T.Text)))
test :: String -- ^ method test :: String -- ^ method

2
yesod-core/test/YesodCoreTest/Streaming.hs
View File

@ -8,7 +8,7 @@ import Data.Text (Text)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
app :: LiteApp app :: LiteApp
app = dispatchTo $ respondSource typeHtml $ do app = liteApp $ dispatchTo $ respondSource typeHtml $ do
sendChunk ("Hello " :: String) sendChunk ("Hello " :: String)
sendChunk ("World" :: ByteString) sendChunk ("World" :: ByteString)
sendChunk ("!\n" :: Text) sendChunk ("!\n" :: Text)