add Web.Scotty.Trans.Strict

Web/Scotty.hs

@@ -50,7 +50,7 @@
 import Data.Aeson (FromJSON, ToJSON)
 import qualified Data.ByteString as BS
 import Data.ByteString.Lazy.Char8 (ByteString)
-import Data.Text.Lazy (Text)
+import Data.Text.Lazy (Text, toStrict)
 
 import Network.HTTP.Types (Status, StdMethod, ResponseHeaders)
 import Network.Socket (Socket)
@@ -170,12 +170,12 @@
 --
 -- > raise JustKidding `catch` (\msg -> text msg)
 rescue :: E.Exception e => ActionM a -> (e -> ActionM a) -> ActionM a
 rescue = Trans.rescue
 {-# DEPRECATED rescue "Use catch instead" #-}
 
 -- | Like 'liftIO', but catch any IO exceptions and turn them into Scotty exceptions.
 liftAndCatchIO :: IO a -> ActionM a
 liftAndCatchIO = Trans.liftAndCatchIO
 {-# DEPRECATED liftAndCatchIO "Use liftIO instead" #-}
 
 -- | Redirect to given URL. Like throwing an uncatchable exception. Any code after the call to redirect
@@ -227,7 +227,7 @@
 --   This means captures are somewhat typed, in that a route won't match if a correctly typed
 --   capture cannot be parsed.
 param :: Trans.Parsable a => Text -> ActionM a
-param = Trans.param
+param = Trans.param . toStrict
 {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-}
 
 -- | Get a capture parameter.
@@ -238,7 +238,7 @@
 --
 -- /Since: 0.20/
 captureParam :: Trans.Parsable a => Text -> ActionM a
-captureParam = Trans.captureParam
+captureParam = Trans.captureParam . toStrict
 
 -- | Get a form parameter.
 --
@@ -248,7 +248,7 @@
 --
 -- /Since: 0.20/
 formParam :: Trans.Parsable a => Text -> ActionM a
-formParam = Trans.formParam
+formParam = Trans.formParam . toStrict
 
 -- | Get a query parameter.
 --
@@ -258,7 +258,7 @@
 --
 -- /Since: 0.20/
 queryParam :: Trans.Parsable a => Text -> ActionM a
-queryParam = Trans.queryParam
+queryParam = Trans.queryParam . toStrict
 
 
 -- | Look up a capture parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
@@ -268,30 +268,30 @@
 --
 -- /Since: FIXME/
 captureParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)
-captureParamMaybe = Trans.captureParamMaybe
+captureParamMaybe = Trans.captureParamMaybe . toStrict
 
 -- | Look up a form parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --
 -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.
 --
 -- /Since: FIXME/
 formParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)
-formParamMaybe = Trans.formParamMaybe
+formParamMaybe = Trans.formParamMaybe . toStrict
 
 -- | Look up a query parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --
 -- NB : Doesn't throw exceptions, so developers must 'raiseStatus' or 'throw' to signal something went wrong.
 --
 -- /Since: FIXME/
 queryParamMaybe :: (Trans.Parsable a) => Text -> ActionM (Maybe a)
-queryParamMaybe = Trans.queryParamMaybe
+queryParamMaybe = Trans.queryParamMaybe . toStrict
 
 
 
 
 -- | Get all parameters from capture, form and query (in that order).
 params :: ActionM [Param]
 params = Trans.params
 {-# DEPRECATED params "(#204) Not a good idea to treat all parameters identically. Use captureParams, formParams and queryParams instead. "#-}
 
 -- | Get capture parameters

Web/Scotty/Action.hs

@@ -16,6 +16,7 @@
     , header
     , headers
     , html
+    , htmlLazy
     , liftAndCatchIO
     , json
     , jsonData
@@ -44,11 +45,13 @@
     , status
     , stream
     , text
+    , textLazy
     , getResponseStatus
     , getResponseHeaders
     , getResponseContent
     , Param
     , Parsable(..)
+    , ActionT
       -- private to Scotty
     , runAction
     ) where
@@ -70,10 +73,10 @@
 import qualified Data.CaseInsensitive       as CI
 import           Data.Int
 import           Data.Maybe                 (maybeToList)
-import qualified Data.Text                  as ST
-import qualified Data.Text.Encoding         as STE
-import qualified Data.Text.Lazy             as T
-import           Data.Text.Lazy.Encoding    (encodeUtf8)
+import qualified Data.Text                  as T
+import           Data.Text.Encoding         as STE
+import qualified Data.Text.Lazy             as TL
+import qualified Data.Text.Lazy.Encoding    as TLE
 import           Data.Word
 
 import           Network.HTTP.Types
@@ -86,10 +89,8 @@
 import           Numeric.Natural
 
 import           Web.Scotty.Internal.Types
-import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText)
-
-import UnliftIO.Exception (Handler(..), catch, catches)
-
+import           Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
+import           UnliftIO.Exception (Handler(..), catch, catches)
 
 import Network.Wai.Internal (ResponseReceived(..))
 
@@ -118,7 +119,7 @@
   StatusError s e -> do
     status s
     let code = T.pack $ show $ statusCode s
-    let msg = T.fromStrict $ STE.decodeUtf8 $ statusMessage s
+    let msg = decodeUtf8Lenient $ statusMessage s
     html $ mconcat ["<h1>", code, " ", msg, "</h1>", e]
 
 -- | Exception handler in charge of 'ActionError'. Rethrowing 'Next' here is caught by 'tryNext'.
@@ -220,14 +221,14 @@
 header :: (Monad m) => T.Text -> ActionT m (Maybe T.Text)
 header k = do
     hs <- requestHeaders <$> request
-    return $ fmap strictByteStringToLazyText $ lookup (CI.mk (lazyTextToStrictByteString k)) hs
+    return $ fmap decodeUtf8Lenient $ lookup (CI.mk (encodeUtf8 k)) hs
 
 -- | Get all the request headers. Header names are case-insensitive.
 headers :: (Monad m) => ActionT m [(T.Text, T.Text)]
 headers = do
     hs <- requestHeaders <$> request
-    return [ ( strictByteStringToLazyText (CI.original k)
-             , strictByteStringToLazyText v)
+    return [ ( decodeUtf8Lenient (CI.original k)
+             , decodeUtf8Lenient v)
            | (k,v) <- hs ]
 
 -- | Get the request body.
@@ -282,7 +283,7 @@
     val <- ActionT $ (lookup k . getParams) <$> ask
     case val of
         Nothing -> raiseStatus status500 $ "Param: " <> k <> " not found!" -- FIXME
-        Just v  -> either (const next) return $ parseParam v
+        Just v  -> either (const next) return $ parseParam (TL.fromStrict v)
 {-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-}
 
 -- | Look up a capture parameter.
@@ -364,7 +365,7 @@
         let handleParseError = \case
               CaptureParam -> next
               _ -> raiseStatus err (T.unwords ["Cannot parse", v, "as a", T.pack (show ty), "parameter"])
-        in either (const $ handleParseError ty) return $ parseParam v
+        in either (const $ handleParseError ty) return $ parseParam $ TL.fromStrict v
 
 -- | Look up a parameter. Returns 'Nothing' if the parameter is not found or cannot be parsed at the right type.
 --
@@ -379,7 +380,7 @@
     val <- ActionT $ (lookup k . f) <$> ask
     case val of
       Nothing -> pure Nothing
-      Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam v
+      Just v -> either (const $ pure Nothing) (pure . Just) $ parseParam $ TL.fromStrict v
 
 -- | Get all parameters from capture, form and query (in that order).
 params :: Monad m => ActionT m [Param]
@@ -420,39 +421,39 @@
 -- | Minimum implemention: 'parseParam'
 class Parsable a where
     -- | Take a 'T.Text' value and parse it as 'a', or fail with a message.
-    parseParam :: T.Text -> Either T.Text a
+    parseParam :: TL.Text -> Either TL.Text a
 
     -- | Default implementation parses comma-delimited lists.
     --
     -- > parseParamList t = mapM parseParam (T.split (== ',') t)
-    parseParamList :: T.Text -> Either T.Text [a]
-    parseParamList t = mapM parseParam (T.split (== ',') t)
+    parseParamList :: TL.Text -> Either TL.Text [a]
+    parseParamList t = mapM parseParam (TL.split (== ',') t)
 
 -- No point using 'read' for Text, ByteString, Char, and String.
-instance Parsable T.Text where parseParam = Right
-instance Parsable ST.Text where parseParam = Right . T.toStrict
+instance Parsable T.Text where parseParam = Right . TL.toStrict
+instance Parsable TL.Text where parseParam = Right
 instance Parsable B.ByteString where parseParam = Right . lazyTextToStrictByteString
-instance Parsable BL.ByteString where parseParam = Right . encodeUtf8
+instance Parsable BL.ByteString where parseParam = Right . TLE.encodeUtf8
 -- | Overrides default 'parseParamList' to parse String.
 instance Parsable Char where
-    parseParam t = case T.unpack t of
+    parseParam t = case TL.unpack t of
                     [c] -> Right c
                     _   -> Left "parseParam Char: no parse"
-    parseParamList = Right . T.unpack -- String
+    parseParamList = Right . TL.unpack -- String
 -- | Checks if parameter is present and is null-valued, not a literal '()'.
 -- If the URI requested is: '/foo?bar=()&baz' then 'baz' will parse as (), where 'bar' will not.
 instance Parsable () where
-    parseParam t = if T.null t then Right () else Left "parseParam Unit: no parse"
+    parseParam t = if TL.null t then Right () else Left "parseParam Unit: no parse"
 
 instance (Parsable a) => Parsable [a] where parseParam = parseParamList
 
 instance Parsable Bool where
-    parseParam t = if t' == T.toCaseFold "true"
+    parseParam t = if t' == TL.toCaseFold "true"
                    then Right True
-                   else if t' == T.toCaseFold "false"
+                   else if t' == TL.toCaseFold "false"
                         then Right False
                         else Left "parseParam Bool: no parse"
-        where t' = T.toCaseFold t
+        where t' = TL.toCaseFold t
 
 instance Parsable Double where parseParam = readEither
 instance Parsable Float where parseParam = readEither
@@ -474,8 +475,8 @@
 -- | Useful for creating 'Parsable' instances for things that already implement 'Read'. Ex:
 --
 -- > instance Parsable Int where parseParam = readEither
-readEither :: Read a => T.Text -> Either T.Text a
-readEither t = case [ x | (x,"") <- reads (T.unpack t) ] of
+readEither :: Read a => TL.Text -> Either TL.Text a
+readEither t = case [ x | (x,"") <- reads (TL.unpack t) ] of
                 [x] -> Right x
                 []  -> Left "readEither: no parse"
                 _   -> Left "readEither: ambiguous parse"
@@ -489,7 +490,7 @@
              => (CI.CI B.ByteString -> B.ByteString -> [(HeaderName, B.ByteString)] -> [(HeaderName, B.ByteString)])
              -> T.Text -> T.Text -> ActionT m ()
 changeHeader f k =
-  modifyResponse . setHeaderWith . f (CI.mk $ lazyTextToStrictByteString k) . lazyTextToStrictByteString
+  modifyResponse . setHeaderWith . f (CI.mk $ encodeUtf8 k) . encodeUtf8
 
 -- | Add to the response headers. Header names are case-insensitive.
 addHeader :: MonadIO m => T.Text -> T.Text -> ActionT m ()
@@ -505,14 +506,28 @@
 text :: (MonadIO m) => T.Text -> ActionT m ()
 text t = do
     changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"
-    raw $ encodeUtf8 t
+    raw $ BL.fromStrict $ encodeUtf8 t
+
+-- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
+-- header to \"text/plain; charset=utf-8\" if it has not already been set.
+textLazy :: (MonadIO m) => TL.Text -> ActionT m ()
+textLazy t = do
+    changeHeader addIfNotPresent "Content-Type" "text/plain; charset=utf-8"
+    raw $ TLE.encodeUtf8 t
 
 -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
 -- header to \"text/html; charset=utf-8\" if it has not already been set.
 html :: (MonadIO m) => T.Text -> ActionT m ()
 html t = do
     changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"
-    raw $ encodeUtf8 t
+    raw $ BL.fromStrict $ encodeUtf8 t
+
+  -- | Set the body of the response to the given 'T.Text' value. Also sets \"Content-Type\"
+-- header to \"text/html; charset=utf-8\" if it has not already been set.
+htmlLazy :: (MonadIO m) => TL.Text -> ActionT m ()
+htmlLazy t = do
+    changeHeader addIfNotPresent "Content-Type" "text/html; charset=utf-8"
+    raw $ TLE.encodeUtf8 t
 
 -- | Send a file as the response. Doesn't set the \"Content-Type\" header, so you probably
 -- want to do that on your own with 'setHeader'. Setting a status code will have no effect

Web/Scotty/Body.hs

@@ -20,7 +20,7 @@
 import qualified Network.Wai.Parse as W (File, Param, getRequestBodyType, BackEnd, lbsBackEnd, sinkRequestBody)
 import           Web.Scotty.Action (Param)
 import           Web.Scotty.Internal.Types (BodyInfo(..), BodyChunkBuffer(..), BodyPartiallyStreamed(..), RouteOptions(..))
-import           Web.Scotty.Util (readRequestBody, strictByteStringToLazyText)
+import           Web.Scotty.Util (readRequestBody, strictByteStringToLazyText, decodeUtf8Lenient)
 
 -- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.
 newBodyInfo :: (MonadIO m) => Request -> m BodyInfo
@@ -47,7 +47,7 @@
       bs <- getBodyAction bodyInfo opts
       let wholeBody = BL.toChunks bs
       (formparams, fs) <- parseRequestBody wholeBody W.lbsBackEnd req -- NB this loads the whole body into memory
-      let convert (k, v) = (strictByteStringToLazyText k, strictByteStringToLazyText v)
+      let convert (k, v) = (decodeUtf8Lenient k, decodeUtf8Lenient v)
       return (convert <$> formparams, fs)
     else
     return ([], [])

Web/Scotty/Cookie.hs

@@ -79,21 +79,23 @@ import qualified Data.ByteString.Lazy as BSL (toStrict)
 -- cookie
 import Web.Cookie (SetCookie, setCookieName , setCookieValue, setCookiePath, setCookieExpires, setCookieMaxAge, setCookieDomain, setCookieHttpOnly, setCookieSecure, setCookieSameSite, renderSetCookie, defaultSetCookie, CookiesText, parseCookiesText, SameSiteOption, sameSiteStrict, sameSiteNone, sameSiteLax)
 -- scotty
-import Web.Scotty.Trans (ActionT, addHeader, header)
+import Web.Scotty.Action (ActionT, addHeader, header)
 -- time
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
 -- text
 import Data.Text (Text)
 import qualified Data.Text.Encoding as T (encodeUtf8)
-import qualified Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)
-
-
+import Web.Scotty.Util (decodeUtf8Lenient)
 
 -- | Set a cookie, with full access to its options (see 'SetCookie')
 setCookie :: (MonadIO m)
           => SetCookie
           -> ActionT m ()
-setCookie c = addHeader "Set-Cookie" (TL.decodeUtf8 . toLazyByteString $ renderSetCookie c)
+setCookie c = addHeader "Set-Cookie"
+  $ decodeUtf8Lenient
+  $ BSL.toStrict
+  $ toLazyByteString
+  $ renderSetCookie c
 
 
 -- | 'makeSimpleCookie' and 'setCookie' combined.
@@ -114,7 +116,7 @@ getCookie c = lookup c <$> getCookies
 getCookies :: (Monad m)
            => ActionT m CookiesText
 getCookies = (maybe [] parse) <$> header "Cookie"
-    where parse = parseCookiesText . BSL.toStrict . TL.encodeUtf8
+    where parse = parseCookiesText . T.encodeUtf8
 
 -- | Browsers don't directly delete a cookie, but setting its expiry to a past date (e.g. the UNIX epoch) ensures that the cookie will be invalidated (whether and when it will be actually deleted by the browser seems to be browser-dependent).
 deleteCookie :: (MonadIO m)

Web/Scotty/Internal/Types.hs

@@ -30,7 +30,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS8 (ByteString)
 import           Data.Default.Class (Default, def)
 import           Data.String (IsString(..))
-import           Data.Text.Lazy (Text, pack)
+import           Data.Text (Text, pack)
 import           Data.Typeable (Typeable)
 
 import           Network.HTTP.Types

Web/Scotty/Route.hs

@@ -15,8 +15,7 @@
 
 import           Data.Maybe (fromMaybe)
 import           Data.String (fromString)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text as TS
+import qualified Data.Text as T
 
 import           Network.HTTP.Types
 import           Network.Wai (Request(..))
@@ -24,8 +23,8 @@
 import qualified Text.Regex as Regex
 
 import           Web.Scotty.Action
 import           Web.Scotty.Internal.Types (RoutePattern(..), RouteOptions, ActionEnv(..), ActionT, ScottyState(..), ScottyT(..), ErrorHandler, Middleware, BodyInfo, handler, addRoute, defaultScottyResponse)
-import           Web.Scotty.Util (strictByteStringToLazyText)
+import           Web.Scotty.Util (decodeUtf8Lenient)
 import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)
 
 -- | get = 'addroute' 'GET'
@@ -130,21 +129,21 @@
 
 -- Pretend we are at the top level.
 path :: Request -> T.Text
-path = T.fromStrict . TS.cons '/' . TS.intercalate "/" . pathInfo
+path = T.cons '/' . T.intercalate "/" . pathInfo
 
 -- | Parse the request and construct the initial 'ActionEnv' with a default 200 OK response
 mkEnv :: MonadIO m => BodyInfo -> Request -> [Param] -> RouteOptions -> m ActionEnv
 mkEnv bodyInfo req captureps opts = do
   (formps, bodyFiles) <- liftIO $ getFormParamsAndFilesAction req bodyInfo opts
   let
     queryps = parseEncodedParams $ rawQueryString req
-    bodyFiles' = [ (strictByteStringToLazyText k, fi) | (k,fi) <- bodyFiles ]
+    bodyFiles' = [ (decodeUtf8Lenient k, fi) | (k,fi) <- bodyFiles ]
   responseInit <- liftIO $ newTVarIO defaultScottyResponse
   return $ Env req captureps formps queryps (getBodyAction bodyInfo opts) (getBodyChunkAction bodyInfo) bodyFiles' responseInit
 
 
 parseEncodedParams :: B.ByteString -> [Param]
-parseEncodedParams bs = [ (T.fromStrict k, T.fromStrict $ fromMaybe "" v) | (k,v) <- parseQueryText bs ]
+parseEncodedParams bs = [ (k, fromMaybe "" v) | (k,v) <- parseQueryText bs ]
 
 -- | Match requests using a regular expression.
 --   Named captures are not yet supported.