diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/src/Yesod/Core/Content.hs b/src/Yesod/Core/Content.hs --- a/src/Yesod/Core/Content.hs +++ b/src/Yesod/Core/Content.hs @@ -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 diff --git a/src/Yesod/Core/Types.hs b/src/Yesod/Core/Types.hs --- a/src/Yesod/Core/Types.hs +++ b/src/Yesod/Core/Types.hs @@ -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 diff --git a/src/Yesod/Core/Types/Content.hs b/src/Yesod/Core/Types/Content.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Core/Types/Content.hs @@ -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@. diff --git a/src/Yesod/Core/Types/ErrorResponse.hs b/src/Yesod/Core/Types/ErrorResponse.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Core/Types/ErrorResponse.hs @@ -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 diff --git a/src/Yesod/Core/Types/HandlerContents.hs b/src/Yesod/Core/Types/HandlerContents.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Core/Types/HandlerContents.hs @@ -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 diff --git a/src/Yesod/Core/Types/TypedContent.hs b/src/Yesod/Core/Types/TypedContent.hs new file mode 100644 --- /dev/null +++ b/src/Yesod/Core/Types/TypedContent.hs @@ -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 diff --git a/test/YesodCoreTest.hs b/test/YesodCoreTest.hs --- a/test/YesodCoreTest.hs +++ b/test/YesodCoreTest.hs @@ -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 diff --git a/test/YesodCoreTest/Content.hs b/test/YesodCoreTest/Content.hs new file mode 100644 --- /dev/null +++ b/test/YesodCoreTest/Content.hs @@ -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]") diff --git a/test/YesodCoreTest/Exceptions.hs b/test/YesodCoreTest/Exceptions.hs --- a/test/YesodCoreTest/Exceptions.hs +++ b/test/YesodCoreTest/Exceptions.hs @@ -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 diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -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 @@ -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