packages feed

yesod-core 1.2.6.7 → 1.2.7

raw patch · 9 files changed

+216/−19 lines, 9 filesdep +asyncdep +criteriondep +networkdep ~basedep ~blaze-htmldep ~bytestring

Dependencies added: async, criterion, network, network-conduit

Dependency ranges changed: base, blaze-html, bytestring, hamlet, text, transformers

Files

Yesod/Core/Handler.hs view
@@ -89,6 +89,9 @@     , sendResponseStatus     , sendResponseCreated     , sendWaiResponse+#if MIN_VERSION_wai(2, 1, 0)+    , sendRawResponse+#endif       -- * Different representations       -- $representations     , selectRep@@ -170,7 +173,7 @@ import qualified Data.ByteString.Lazy          as L import qualified Data.Map                      as Map -import Data.Conduit (Source)+import Data.Conduit (Source, Sink) import           Control.Arrow                 ((***)) import qualified Data.ByteString.Char8         as S8 import           Data.Maybe                    (mapMaybe)@@ -198,6 +201,9 @@ #if MIN_VERSION_wai(2, 0, 0) import qualified System.PosixCompat.Files as PC #endif+#if MIN_VERSION_wai(2, 1, 0)+import Control.Monad.Trans.Control (MonadBaseControl, control)+#endif  get :: MonadHandler m => m GHState get = liftHandlerT $ HandlerT $ I.readIORef . handlerState@@ -546,6 +552,23 @@ -- you don't. sendWaiResponse :: MonadHandler m => W.Response -> m b sendWaiResponse = handlerError . HCWai++#if MIN_VERSION_wai(2, 1, 0)+-- | Send a raw response. This is used for cases such as WebSockets. Requires+-- WAI 2.1 or later, and a web server which supports raw responses (e.g.,+-- Warp).+--+-- Since 1.2.7+sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)+                => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())+                -> m a+sendRawResponse raw = control $ \runInIO ->+    runInIO $ sendWaiResponse $ flip W.responseRaw fallback+    $ \src sink -> runInIO (raw src sink) >> return ()+  where+    fallback = W.responseLBS H.status500 [("Content-Type", "text/plain")]+        "sendRawResponse: backend does not support raw responses"+#endif  -- | Return a 404 not found page. Also denotes no handler available. notFound :: MonadHandler m => m a
Yesod/Core/Internal/Response.hs view
@@ -47,9 +47,20 @@     case a of         ResponseSource s hs w -> return $ ResponseSource s hs $ \f ->             w f `finally` closeInternalState is-        _ -> do+        ResponseBuilder{} -> do             closeInternalState is             return a+        ResponseFile{} -> do+            closeInternalState is+            return a+#if MIN_VERSION_wai(2, 1, 0)+        -- Ignore the fallback provided, in case it refers to a ResourceT state+        -- in a ResponseSource.+        ResponseRaw raw _ -> return $ ResponseRaw+            (\f -> raw f `finally` closeInternalState is)+            (responseLBS H.status500 [("Content-Type", "text/plain")]+                "yarToResponse: backend does not support raw responses")+#endif #else yarToResponse (YRWai a) _ _ _ = return a #endif@@ -128,7 +139,9 @@ evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do     let lbs = toLazyByteString b-    L.length lbs `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen)+        len = L.length lbs+        mlen' = maybe (Just $ fromIntegral len) Just mlen+    len `seq` return (Right $ ContentBuilder (fromLazyByteString lbs) mlen')   where     f :: SomeException -> IO (Either ErrorResponse Content)     f = return . Left . InternalError . T.pack . show
Yesod/Core/Json.hs view
@@ -10,6 +10,7 @@       -- * Convert to a JSON value     , parseJsonBody     , parseJsonBody_+    , requireJsonBody        -- * Produce JSON values     , J.Value (..)@@ -99,7 +100,13 @@ -- | Same as 'parseJsonBody', but return an invalid args response on a parse -- error. parseJsonBody_ :: (MonadHandler m, J.FromJSON a) => m a-parseJsonBody_ = do+parseJsonBody_ = requireJsonBody+{-# DEPRECATED parseJsonBody_ "Use requireJsonBody instead" #-}++-- | Same as 'parseJsonBody', but return an invalid args response on a parse+-- error.+requireJsonBody :: (MonadHandler m, J.FromJSON a) => m a+requireJsonBody = do     ra <- parseJsonBody     case ra of         J.Error s -> invalidArgs [pack s]
+ bench/widget.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}+-- | BigTable benchmark implemented using Hamlet.+--+{-# LANGUAGE QuasiQuotes #-}+module Main where++import Criterion.Main+import Text.Hamlet+import Numeric (showInt)+import qualified Data.ByteString.Lazy as L+import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8+import Data.Monoid (mconcat)+import Text.Blaze.Html5 (table, tr, td)+import Text.Blaze.Html (toHtml)+import Yesod.Core.Widget+import Control.Monad.Trans.Writer+import Control.Monad.Trans.RWS+import Data.Functor.Identity+import Yesod.Core.Types+import Data.Monoid+import Data.IORef++main = defaultMain+    [ bench "bigTable html" $ nf bigTableHtml bigTableData+    , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData+    , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)+    , bench "bigTable blaze" $ nf bigTableBlaze bigTableData+    ]+  where+    rows :: Int+    rows = 1000++    bigTableData :: [[Int]]+    bigTableData = replicate rows [1..10]+    {-# NOINLINE bigTableData #-}++bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|]++bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|]++bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|+<table>+    $forall row <- rows+        <tr>+            $forall cell <- row+                <td>#{show cell}+|])+  where+  render _ _ = "foo"+  run (WidgetT w) = do+    (_, GWData { gwdBody = Body x }) <- w undefined+    return x++bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t+  where+    row r = tr $ mconcat $ map (td . toHtml . show) r
test/YesodCoreTest.hs view
@@ -14,6 +14,7 @@ import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json+import qualified YesodCoreTest.RawResponse as RawResponse import qualified YesodCoreTest.Streaming as Streaming import qualified YesodCoreTest.Reps as Reps import qualified YesodCoreTest.Auth as Auth@@ -37,6 +38,7 @@       JsLoader.specs       RequestBodySize.specs       Json.specs+      RawResponse.specs       Streaming.specs       Reps.specs       Auth.specs
test/YesodCoreTest/ErrorHandling.hs view
@@ -13,6 +13,8 @@ import qualified Data.ByteString.Char8 as S8 import Control.Exception (SomeException, try) import Network.HTTP.Types (mkStatus)+import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)+import Data.Monoid (mconcat)  data App = App @@ -29,6 +31,8 @@ /builder BuilderR GET /file-bad-len FileBadLenR GET /file-bad-name FileBadNameR GET++/good-builder GoodBuilderR GET |]  overrideStatus = mkStatus 15 "OVERRIDE"@@ -88,6 +92,12 @@ getFileBadNameR :: Handler TypedContent getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing +goodBuilderContent :: Builder+goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n"++getGoodBuilderR :: Handler TypedContent+getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent+ errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do       it "says not found" caseNotFound@@ -99,6 +109,7 @@       it "builder" caseBuilder       it "file with bad len" caseFileBadLen       it "file with bad name" caseFileBadName+      it "builder includes content-length" caseGoodBuilder  runner :: Session () -> IO () runner f = toWaiApp App >>= runSession f@@ -175,3 +186,11 @@     res <- request defaultRequest { pathInfo = ["file-bad-name"] }     assertStatus 500 res     assertBodyContains "filebadname" res++caseGoodBuilder :: IO ()+caseGoodBuilder = runner $ do+    res <- request defaultRequest { pathInfo = ["good-builder"] }+    assertStatus 200 res+    let lbs = toLazyByteString goodBuilderContent+    assertBody lbs res+    assertHeader "content-length" (S8.pack $ show $ L.length lbs) res
+ test/YesodCoreTest/RawResponse.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-}+module YesodCoreTest.RawResponse (specs, Widget) where++import Yesod.Core+import Test.Hspec+import qualified Data.Map as Map+import Network.Wai.Test+import Data.Text (Text)+import Data.ByteString.Lazy (ByteString)+import qualified Data.Conduit.List as CL+import qualified Data.ByteString.Char8 as S8+import Data.Conduit+import qualified Data.Conduit.Binary as CB+import Data.Char (toUpper)+import Control.Exception (try, IOException)+import Data.Conduit.Network+import Network.Socket (sClose)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (withAsync)+import Control.Monad.Trans.Resource (register)+import Data.IORef++data App = App++mkYesod "App" [parseRoutes|+/ HomeR GET+|]++instance Yesod App++getHomeR :: Handler ()+getHomeR = do+    ref <- liftIO $ newIORef 0+    _ <- register $ writeIORef ref 1+    sendRawResponse $ \src sink -> liftIO $ do+        val <- readIORef ref+        yield (S8.pack $ show val) $$ sink+        src $$ CL.map (S8.map toUpper) =$ sink++getFreePort :: IO Int+getFreePort = do+    loop 43124+  where+    loop port = do+        esocket <- try $ bindPort port "*"+        case esocket of+            Left (_ :: IOException) -> loop (succ port)+            Right socket -> do+                sClose socket+                return port++specs :: Spec+specs = describe "RawResponse" $ do+    it "works" $ do+        port <- getFreePort+        withAsync (warp port App) $ \_ -> do+            threadDelay 100000+            runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do+                yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad+                (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")+                yield "WORLd" $$ appSink ad+                (appSource ad $$ await) >>= (`shouldBe` Just "WORLD")
− test/YesodCoreTest/WaiSubsiteSub.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}-module YesodCoreTest.WaiSubsiteSub where--import Yesod.Core--data NonWaiSubsite = NonWaiSubsite--mkYesodSubData "NonWaiSubsite" [parseRoutes|-/ SubHomeR GET-/waisub WaiSubsite2R WaiSubsite getApp-|]--getSubHomeR :: HandlerT NonWaiSubsite (HandlerT parent IO) ()-getSubHomeR = return ()
yesod-core.cabal view
@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.2.6.7+version:         1.2.7 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -122,8 +122,25 @@                   , containers                   , lifted-base                   , resourcet+                  , network-conduit+                  , network+                  , async     ghc-options:     -Wall     extensions: TemplateHaskell++benchmark widgets+    type: exitcode-stdio-1.0+    hs-source-dirs: bench+    build-depends:  base+                  , criterion+                  , bytestring+                  , text+                  , hamlet+                  , transformers+                  , yesod-core+                  , blaze-html+    main-is:        widget.hs+    ghc-options:    -Wall -O2  source-repository head   type:     git