packages feed

yesod-core 1.6.28.1 → 1.6.29.0

raw patch · 11 files changed

+324/−66 lines, 11 filesdep +encoding

Dependencies added: encoding

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # ChangeLog for yesod-core +## 1.6.29.0++* When showing HandlerContent, include a content snippet [#1864](https://github.com/yesodweb/yesod/pull/1864)+ ## 1.6.28.1  * Add type arguments to the sub routes [#1866](https://github.com/yesodweb/yesod/pull/1866)
src/Yesod/Core/Content.hs view
@@ -32,6 +32,7 @@       -- * Utilities     , simpleContentType     , contentTypeTypes+    , typedContentToSnippet       -- * Evaluation strategy     , DontFullyEvaluate (..)       -- * Representations@@ -51,10 +52,12 @@  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8Builder) import qualified Data.Text.Lazy as TL+ import Data.ByteString.Builder (Builder, byteString, lazyByteString, stringUtf8) import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)@@ -69,8 +72,12 @@ import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript)+import qualified Network.Wai.Parse as NWP+import qualified Data.Int as I import Data.Word8 (_semicolon, _slash) import Control.Arrow (second)+import Control.Exception (Exception)+import Data.Maybe  -- | Zero-length enumerator. emptyContent :: Content
src/Yesod/Core/Types.hs view
@@ -1,16 +1,25 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-} -module Yesod.Core.Types where+module Yesod.Core.Types (+    module Yesod.Core.Types+  , module Yesod.Core.Types.ErrorResponse+  , module Yesod.Core.Types.Content+  , module Yesod.Core.Types.TypedContent+  , module Yesod.Core.Types.HandlerContents +  , module Yesod.Core.Internal.Util+  , module Yesod.Routes.Class+  , module Yesod.Core.TypeCache+  ) where+ import Data.Aeson (ToJSON) import qualified Data.ByteString.Builder            as BB import           Control.Arrow                      (first)@@ -34,9 +43,11 @@ import           Data.String                        (IsString (fromString)) import           Data.Text                          (Text) import qualified Data.Text                          as T+import           Data.Text.Encoding import qualified Data.Text.Lazy.Builder             as TBuilder import           Data.Time                          (UTCTime) import           GHC.Generics                       (Generic)+import qualified GHC.Int                            as I import           Language.Haskell.TH.Syntax         (Loc) import qualified Network.HTTP.Types                 as H import           Network.Wai                        (FilePart,@@ -57,6 +68,11 @@ import Control.Monad.Logger (MonadLoggerIO (..)) import UnliftIO (MonadUnliftIO (..), SomeException) +import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.Content+import Yesod.Core.Types.TypedContent+import Yesod.Core.Types.HandlerContents+ -- Sessions type SessionMap = Map Text ByteString @@ -297,21 +313,12 @@     , pageBody        :: !(HtmlUrl url)     } -data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.-             | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())-             | ContentFile !FilePath !(Maybe FilePart)-             | ContentDontEvaluate !Content--data TypedContent = TypedContent !ContentType !Content- type RepHtml = Html {-# DEPRECATED RepHtml "Please use Html instead" #-} newtype RepJson = RepJson Content newtype RepPlain = RepPlain Content newtype RepXml = RepXml Content -type ContentType = ByteString -- FIXME Text?- -- | Wrapper around types so that Handlers can return a domain type, even when -- the data will eventually be encoded as JSON. -- Example usage in a type signature:@@ -332,34 +339,6 @@ -- Since 1.1.0 newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } --- | Responses to indicate some form of an error occurred.-data ErrorResponse =-      NotFound-        -- ^ The requested resource was not found.-        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.-        -- HTTP status: 404.-    | InternalError !Text-        -- ^ Some sort of unexpected exception.-        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.-        -- HTTP status: 500.-    | InvalidArgs ![Text]-        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.-        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.-        -- HTTP status: 400.-    | NotAuthenticated-        -- ^ Indicates the user is not logged in.-        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.-        -- HTTP code: 401.-    | PermissionDenied !Text-        -- ^ Indicates the user doesn't have permission to access the requested resource.-        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.-        -- HTTP code: 403.-    | BadMethod !H.Method-        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)-        -- HTTP code: 405.-    deriving (Show, Eq, Generic)-instance NFData ErrorResponse- ----- header stuff -- | Headers to be added to a 'Result'. data Header =@@ -422,25 +401,6 @@         (unionWith mappend a6 b6)         (mappend a7 b7)         (mappend a8 b8)--data HandlerContents =-      HCContent !H.Status !TypedContent-    | HCError !ErrorResponse-    | HCSendFile !ContentType !FilePath !(Maybe FilePart)-    | HCRedirect !H.Status !Text-    | HCCreated !Text-    | HCWai !W.Response-    | HCWaiApp !W.Application--instance Show HandlerContents where-    show (HCContent status (TypedContent t _)) = "HCContent " ++ show (status, t)-    show (HCError e) = "HCError " ++ show e-    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)-    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)-    show (HCCreated t) = "HCCreated " ++ show t-    show (HCWai _) = "HCWai"-    show (HCWaiApp _) = "HCWaiApp"-instance Exception HandlerContents  -- Instances for WidgetFor instance Applicative (WidgetFor site) where
+ src/Yesod/Core/Types/Content.hs view
@@ -0,0 +1,21 @@+module Yesod.Core.Types.Content where++import qualified Data.ByteString.Builder as BB+import Control.Monad.Trans.Resource (ResourceT)+import Data.Conduit (Flush, ConduitT)+import Network.Wai (FilePart)++data Content+    = ContentBuilder !BB.Builder !(Maybe Int)+    -- ^ The content and optional content length.+    --+    -- Note that, despite @Builder@'s laziness, this is entirely forced+    -- into memory by default in order to catch imprecise exceptions+    -- before beginning to respond. If you are confident you don't have+    -- imprecise exceptions, you may disable this by wrapping the+    -- `ToContent` data in `DontFullyEvaluate`.-+    | ContentSource !(ConduitT () (Flush BB.Builder) (ResourceT IO) ())+    | ContentFile !FilePath !(Maybe FilePart)+    | ContentDontEvaluate !Content+    -- ^ Used internally to wrap @ContentBuilder@s to disable forcing+    -- them. No effect on other @Content@.
+ src/Yesod/Core/Types/ErrorResponse.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}++module Yesod.Core.Types.ErrorResponse where++import GHC.Generics (Generic)+import Data.Text+import Control.DeepSeq (NFData)+import qualified Network.HTTP.Types as H++-- | Responses to indicate some form of an error occurred.+data ErrorResponse =+      NotFound+        -- ^ The requested resource was not found.+        -- Examples of when this occurs include when an incorrect URL is used, or @yesod-persistent@'s 'get404' doesn't find a value.+        -- HTTP status: 404.+    | InternalError !Text+        -- ^ Some sort of unexpected exception.+        -- If your application uses `throwIO` or `error` to throw an exception, this is the form it would take.+        -- HTTP status: 500.+    | InvalidArgs ![Text]+        -- ^ Indicates some sort of invalid or missing argument, like a missing query parameter or malformed JSON body.+        -- Examples Yesod functions that send this include 'requireCheckJsonBody' and @Yesod.Auth.GoogleEmail2@.+        -- HTTP status: 400.+    | NotAuthenticated+        -- ^ Indicates the user is not logged in.+        -- This is thrown when 'isAuthorized' returns 'AuthenticationRequired'.+        -- HTTP code: 401.+    | PermissionDenied !Text+        -- ^ Indicates the user doesn't have permission to access the requested resource.+        -- This is thrown when 'isAuthorized' returns 'Unauthorized'.+        -- HTTP code: 403.+    | BadMethod !H.Method+        -- ^ Indicates the URL would have been valid if used with a different HTTP method (e.g. a GET was used, but only POST is handled.)+        -- HTTP code: 405.+    deriving (Show, Eq, Generic)++instance NFData ErrorResponse
+ src/Yesod/Core/Types/HandlerContents.hs view
@@ -0,0 +1,39 @@+module Yesod.Core.Types.HandlerContents+  (+    HandlerContents (..)+  ) where++import Control.Exception (Exception)+import Data.Maybe+import Data.Text+import qualified Data.Text.Lazy as TL+import qualified Network.HTTP.Types as H+import qualified Network.Wai as W+import Yesod.Core.Types.ErrorResponse+import Yesod.Core.Types.TypedContent (ContentType, TypedContent (..), typedContentToSnippet)++data HandlerContents =+      HCContent !H.Status !TypedContent+    | HCError !ErrorResponse+    | HCSendFile !ContentType !FilePath !(Maybe W.FilePart)+    | HCRedirect !H.Status !Text+    | HCCreated !Text+    | HCWai !W.Response+    | HCWaiApp !W.Application++instance Show HandlerContents where+    show (HCContent status tc@(TypedContent t _))+      = mconcat [ "HCContent "+                , show (status, t)+                , " ("+                , fromMaybe "" $ TL.unpack <$> typedContentToSnippet tc 1000+                , ")"+                ]+    show (HCError e) = "HCError " ++ show e+    show (HCSendFile ct fp mfp) = "HCSendFile " ++ show (ct, fp, mfp)+    show (HCRedirect s t) = "HCRedirect " ++ show (s, t)+    show (HCCreated t) = "HCCreated " ++ show t+    show (HCWai _) = "HCWai"+    show (HCWaiApp _) = "HCWaiApp"++instance Exception HandlerContents
+ src/Yesod/Core/Types/TypedContent.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Yesod.Core.Types.TypedContent+  (+    ContentType+  , TypedContent (..)+  , typedContentToSnippet+  ) where++import Control.Applicative ((<|>))+import Control.Monad (void, guard)+import Data.Maybe (fromMaybe)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Builder as BB++import qualified Data.Int as I++#if MIN_VERSION_text(2,1,0)+import qualified Data.Text.Encoding as TE (decodeASCIIPrefix)+#else+import qualified Data.Text.Encoding as TE (decodeLatin1)+#endif+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as LE (decodeUtf8With, decodeLatin1)+import qualified Data.Text.Encoding.Error as EE (lenientDecode)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++import qualified Network.Wai.Parse as NWP++import Yesod.Core.Types.Content (Content (..))++type ContentType = B.ByteString -- FIXME Text?+data TypedContent = TypedContent !ContentType !Content++decoderForCharset :: Maybe B.ByteString -> L.ByteString -> TL.Text+decoderForCharset (Just encodingSymbol)+  | encodingSymbol == "utf-8" =+      LE.decodeUtf8With EE.lenientDecode+  | encodingSymbol == "US-ASCII" =+#if MIN_VERSION_text(2,1,0)+      TL.fromStrict . fst . TE.decodeASCIIPrefix . L.toStrict+#else+      TL.fromStrict . TE.decodeLatin1 . L.toStrict+#endif+  | encodingSymbol == "latin1" =+      LE.decodeLatin1+  | encodingSymbol == "GB18030" =+      TL.pack . Enc.decodeLazyByteString Enc.GB18030+  | encodingSymbol == "windows-1251" =+      TL.pack . Enc.decodeLazyByteString Enc.CP1251+  | encodingSymbol == "Shift_JIS" =+      TL.pack . Enc.decodeLazyByteString Enc.ShiftJIS+  | encodingSymbol == "Windows-31J" =+      TL.pack . Enc.decodeLazyByteString Enc.CP932+  | otherwise =+      LE.decodeUtf8With EE.lenientDecode+decoderForCharset Nothing = LE.decodeUtf8With EE.lenientDecode++decodeForContentType :: ContentType -> L.ByteString -> Maybe TL.Text+decodeForContentType ct bytes = do+  let (t, params) =+        NWP.parseContentType ct+      charset =+        lookup "charset" params+      typeIsText =+        B.isPrefixOf "text" t+            || B.isPrefixOf "application/json" t+            || B.isPrefixOf "application/rss"  t+            || B.isPrefixOf "application/atom" t+      decoder = decoderForCharset charset+  void charset <|> guard typeIsText+  pure $ decoder bytes++contentToSnippet :: Content -> I.Int64 -> Maybe L.ByteString+contentToSnippet (ContentBuilder builder maybeLength) maxLength =+  pure $ truncatedText <> excessLengthMsg+  where+    truncatedText = L.take maxLength $ BB.toLazyByteString builder+    excessLength = fromMaybe 0 $ (subtract $ fromIntegral maxLength) <$> maybeLength+    excessLengthMsg = case excessLength > 0 of+      False -> ""+      True -> "...+ " <> BB.toLazyByteString (BB.intDec excessLength)+contentToSnippet (ContentSource _) _ = Nothing+contentToSnippet (ContentFile _ _) _ = Nothing+contentToSnippet (ContentDontEvaluate _) _ = Nothing++-- | Represents TypedContent as a String, rendering at most a specified number of+-- bytes of the content, and annotating it with the remaining length. Returns Nothing+-- if the content type indicates the content is binary data.+--+-- @since 1.6.28.0+typedContentToSnippet :: TypedContent -> I.Int64 -> Maybe TL.Text+typedContentToSnippet (TypedContent t c) maxLength = decodeForContentType t =<< contentToSnippet c maxLength
test/YesodCoreTest.hs view
@@ -22,6 +22,7 @@ import qualified YesodCoreTest.JsLoader as JsLoader import qualified YesodCoreTest.RequestBodySize as RequestBodySize import qualified YesodCoreTest.Json as Json+import qualified YesodCoreTest.Content as Content  -- Skip on Windows, see https://github.com/yesodweb/yesod/issues/1523#issuecomment-398278450 #ifndef WINDOWS@@ -70,3 +71,4 @@       Csrf.csrfSpec       breadcrumbTest       metaTest+      Content.specs
+ test/YesodCoreTest/Content.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module YesodCoreTest.Content (specs) where++import Test.Hspec++import Yesod.Core+import Yesod.Core.Types (TypedContent, typedContentToSnippet)+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8)+import Data.ByteString (ByteString)++import qualified Data.Encoding as Enc+import qualified Data.Encoding.GB18030 as Enc+import qualified Data.Encoding.CP1251 as Enc+import qualified Data.Encoding.ShiftJIS as Enc+import qualified Data.Encoding.CP932 as Enc++fakeContent :: (String -> ByteString) -> String -> String -> TypedContent+fakeContent encode contentTypeString contentString =+  TypedContent+  (encode contentTypeString)+  (toContent $ encode contentString)++fakeUtf8Content :: String -> String -> TypedContent+fakeUtf8Content = fakeContent (encodeUtf8 . pack)++fakeGB18030Content :: String -> String -> TypedContent+fakeGB18030Content = fakeContent $ Enc.encodeStrictByteString Enc.GB18030++fakeCP1251Content :: String -> String -> TypedContent+fakeCP1251Content = fakeContent $ Enc.encodeStrictByteString Enc.CP1251++fakeShiftJISContent :: String -> String -> TypedContent+fakeShiftJISContent = fakeContent $ Enc.encodeStrictByteString Enc.ShiftJIS++fakeCP932Content :: String -> String -> TypedContent+fakeCP932Content = fakeContent $ Enc.encodeStrictByteString Enc.CP932++specs :: Spec+specs = describe "typedContentToSnippet" $ do+    it "does not serialize content that is apparently binary data" $ do+      let content = fakeUtf8Content "application/octet-stream" "fake"+      (typedContentToSnippet content 100) `shouldBe` Nothing++    it "serializes UTF-8 encoded JSON" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes text with no specified encoding" $ do+      let content = fakeUtf8Content "text/css" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes RSS with no specified encoding" $ do+      let content = fakeUtf8Content "application/rss" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "serializes Atom feeds with no specified encoding" $ do+      let content = fakeUtf8Content "application/atom" "fake"+      (typedContentToSnippet content 100) `shouldBe` (Just "fake")++    it "truncates long snippets" $ do+      let content = fakeUtf8Content "application/json; charset=utf-8" "[1,2,3]"+      (typedContentToSnippet content 2) `shouldBe` (Just "[1...+ 5")++    it "serializes GB18030 text" $ do+      let content = fakeGB18030Content "application/json; charset=GB18030" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP1251 text" $ do+      let content = fakeCP1251Content "application/json; charset=windows-1251" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes ShiftJIS text" $ do+      let content = fakeShiftJISContent "application/json; charset=Shift_JIS" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")++    it "serializes CP932 text" $ do+      let content = fakeCP932Content "application/json; charset=Windows-31J" "[1,2,3]"+      (typedContentToSnippet content 100) `shouldBe` (Just "[1,2,3]")
test/YesodCoreTest/Exceptions.hs view
@@ -14,7 +14,7 @@ import Test.Hspec  import Yesod.Core-import Yesod.Core.Types (HandlerContents (HCError))+import Yesod.Core.Types (TypedContent, HandlerContents (HCError)) import Control.Exception (throwIO) import Network.Wai import Network.Wai.Test
yesod-core.cabal view
@@ -1,5 +1,5 @@ name:            yesod-core-version:         1.6.28.1+version:         1.6.29.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -41,6 +41,7 @@                    , cookie                >= 0.4.3    && < 0.6                    , data-default                    , deepseq               >= 1.3+                   , encoding                    , entropy                    , fast-logger           >= 2.2                    , http-types            >= 0.7@@ -89,6 +90,10 @@                      Yesod.Core.Class.Dispatch                      Yesod.Core.Class.Breadcrumbs                      Yesod.Core.TypeCache+                     Yesod.Core.Types.Content+                     Yesod.Core.Types.ErrorResponse+                     Yesod.Core.Types.HandlerContents+                     Yesod.Core.Types.TypedContent                      Paths_yesod_core                       Yesod.Routes.TH@@ -129,6 +134,7 @@                  , hspec                  , containers                  , bytestring+                 , encoding                  , template-haskell                  , text                  , random@@ -147,6 +153,7 @@                    YesodCoreTest.Breadcrumb                    YesodCoreTest.Cache                    YesodCoreTest.CleanPath+                   YesodCoreTest.Content                    YesodCoreTest.Header                    YesodCoreTest.Csrf                    YesodCoreTest.ErrorHandling@@ -196,6 +203,7 @@                   , conduit-extra                   , containers                   , cookie >= 0.4.1    && < 0.6+                  , encoding                   , hspec >= 1.3                   , hspec-expectations                   , http-types