HandlerContents snippet (#1894)

* when showing HandlerContent, include some information from the Content

* add PR link

* change version number

Co-authored-by: Matt Parsons <parsonsmatt@gmail.com>

* truncate lazily and decode as UTF-8

* respect content type better when generating snippets

* handle some rare encodings

* doc string and style

* remove unused imports

* adopt style recommendations from PR review

* rearrange some things to avoid a breaking change

* fix build

* hm

* fix warn

* weird but ok

* warnclean

* ok do it

* Restore commentary

* ok

---------

Co-authored-by: Daniel Powell <dtpowl@gmail.com>
Co-authored-by: Daniel Powell <3739511+dtpowl@users.noreply.github.com>

Author: parsonsmatt

stack-lts-22.yaml

@@ -19,3 +19,4 @@ extra-deps:
   - attoparsec-aeson-2.1.0.0
   - crypton-1.0.0
   - crypton-conduit-0.2.3
+  - encoding-0.10.2

yesod-core/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)

yesod-core/src/Yesod/Core/Content.hs

@@ -32,6 +32,7 @@ module Yesod.Core.Content
       -- * Utilities
     , simpleContentType
     , contentTypeTypes
+    , typedContentToSnippet
       -- * Evaluation strategy
     , DontFullyEvaluate (..)
       -- * Representations
@@ -51,10 +52,12 @@ module Yesod.Core.Content
 
 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 Data.Void (Void, absurd)
 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

yesod-core/src/Yesod/Core/TypedContent.hs

@@ -1,15 +1,24 @@
-{-# 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 (
+    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.Types where
+  , 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
@@ -34,9 +43,11 @@ import           Data.Serialize                     (Serialize (..),
 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 Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
 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 @@ data PageContent url = PageContent
     , 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 @@ data JSONResponse a where
 -- 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 =
@@ -423,25 +402,6 @@ instance Semigroup (GWData a) where
         (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
     pure = WidgetFor . const . pure

yesod-core/src/Yesod/Core/Types.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@.

yesod-core/src/Yesod/Core/Types/Content.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

yesod-core/src/Yesod/Core/Types/ErrorResponse.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

yesod-core/src/Yesod/Core/Types/HandlerContents.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