Skip to content

Commit

Permalink
use strict Text internally and add Web.Scotty.Trans.Strict
Browse files Browse the repository at this point in the history
  • Loading branch information
fumieval committed Oct 12, 2023
1 parent fab803c commit 00c9a75
Show file tree
Hide file tree
Showing 12 changed files with 195 additions and 58 deletions.
17 changes: 9 additions & 8 deletions Web/Scotty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,8 @@ import qualified Control.Exception as E
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 qualified Data.Text as ST

Check warning on line 52 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.2.8

The qualified import of ‘Data.Text’ is redundant

Check warning on line 52 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.6.2

The qualified import of ‘Data.Text’ is redundant

Check warning on line 52 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.4.6

The qualified import of ‘Data.Text’ is redundant

Check warning on line 52 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 8.10.7

The qualified import of ‘Data.Text’ is redundant

Check warning on line 52 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.0.2

The qualified import of ‘Data.Text’ is redundant

import Network.HTTP.Types (Status, StdMethod, ResponseHeaders)
import Network.Socket (Socket)
Expand Down Expand Up @@ -221,7 +222,7 @@ jsonData = Trans.jsonData
-- 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

Check warning on line 225 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.2.8

In the use of ‘param’

Check warning on line 225 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.6.2

In the use of ‘param’

Check warning on line 225 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.4.6

In the use of ‘param’

Check warning on line 225 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 8.10.7

In the use of ‘param’

Check warning on line 225 in Web/Scotty.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.0.2

In the use of ‘param’
{-# DEPRECATED param "(#204) Not a good idea to treat all parameters identically. Use captureParam, formParam and queryParam instead. "#-}

-- | Get a capture parameter.
Expand All @@ -232,7 +233,7 @@ param = Trans.param
--
-- /Since: 0.20/
captureParam :: Trans.Parsable a => Text -> ActionM a
captureParam = Trans.captureParam
captureParam = Trans.captureParam . toStrict

-- | Get a form parameter.
--
Expand All @@ -242,7 +243,7 @@ captureParam = Trans.captureParam
--
-- /Since: 0.20/
formParam :: Trans.Parsable a => Text -> ActionM a
formParam = Trans.formParam
formParam = Trans.formParam . toStrict

-- | Get a query parameter.
--
Expand All @@ -252,7 +253,7 @@ formParam = Trans.formParam
--
-- /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.
Expand All @@ -262,23 +263,23 @@ queryParam = Trans.queryParam
--
-- /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



Expand Down
75 changes: 46 additions & 29 deletions Web/Scotty/Action.hs
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ module Web.Scotty.Action
, header
, headers
, html
, htmlLazy
, liftAndCatchIO
, json
, jsonData
Expand Down Expand Up @@ -44,11 +45,13 @@ module Web.Scotty.Action
, status
, stream
, text
, textLazy
, getResponseStatus
, getResponseHeaders
, getResponseContent
, Param
, Parsable(..)
, ActionT
-- private to Scotty
, runAction
) where
Expand All @@ -69,10 +72,10 @@ import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.CaseInsensitive as CI
import Data.Int
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 qualified Data.Text.Lazy as TL
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Word

import Network.HTTP.Types
Expand All @@ -85,7 +88,7 @@ import Network.Wai (Request, Response, StreamingBody, Application, req
import Numeric.Natural

import Web.Scotty.Internal.Types
import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, strictByteStringToLazyText)
import Web.Scotty.Util (mkResponse, addIfNotPresent, add, replace, lazyTextToStrictByteString, decodeUtf8Lenient)
import Web.Scotty.Exceptions (Handler(..), catch, catchesOptionally, tryAny)

import Network.Wai.Internal (ResponseReceived(..))
Expand Down Expand Up @@ -117,7 +120,7 @@ statusErrorHandler = Handler $ \case
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'.
Expand Down Expand Up @@ -220,14 +223,14 @@ files = ActionT $ envFiles <$> ask
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.
Expand Down Expand Up @@ -282,7 +285,7 @@ param k = do
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.
Expand Down Expand Up @@ -364,7 +367,7 @@ paramWith ty f err k = do
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.
--
Expand All @@ -379,7 +382,7 @@ paramWithMaybe f k = do
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]
Expand Down Expand Up @@ -420,39 +423,39 @@ getResponseContent = srContent <$> getResponseAction
-- | 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
Expand All @@ -474,8 +477,8 @@ instance Parsable Natural where parseParam = readEither
-- | 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"
Expand All @@ -489,7 +492,7 @@ changeHeader :: MonadIO m
=> (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 ()
Expand All @@ -505,14 +508,28 @@ setHeader = changeHeader replace
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
Expand Down
4 changes: 2 additions & 2 deletions Web/Scotty/Body.hs
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ import Network.Wai (Request(..), getRequestBodyChunk)
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)

Check warning on line 23 in Web/Scotty/Body.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.2.8

The import of ‘strictByteStringToLazyText’

Check warning on line 23 in Web/Scotty/Body.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.6.2

The import of ‘strictByteStringToLazyText’

Check warning on line 23 in Web/Scotty/Body.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.4.6

The import of ‘strictByteStringToLazyText’

Check warning on line 23 in Web/Scotty/Body.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 8.10.7

The import of ‘strictByteStringToLazyText’

Check warning on line 23 in Web/Scotty/Body.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.0.2

The import of ‘strictByteStringToLazyText’

-- | Make a new BodyInfo with readProgress at 0 and an empty BodyChunkBuffer.
newBodyInfo :: (MonadIO m) => Request -> m BodyInfo
Expand All @@ -47,7 +47,7 @@ getFormParamsAndFilesAction req bodyInfo opts = do
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 ([], [])
Expand Down
14 changes: 8 additions & 6 deletions Web/Scotty/Cookie.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand All @@ -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)
Expand Down
2 changes: 1 addition & 1 deletion Web/Scotty/Internal/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
11 changes: 5 additions & 6 deletions Web/Scotty/Route.hs
Original file line number Diff line number Diff line change
Expand Up @@ -15,8 +15,7 @@ import qualified Data.ByteString.Char8 as B

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(..))
Expand All @@ -25,7 +24,7 @@ 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)

Check warning on line 26 in Web/Scotty/Route.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.2.8

The import of ‘ActionT’

Check warning on line 26 in Web/Scotty/Route.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.6.2

The import of ‘ActionT’

Check warning on line 26 in Web/Scotty/Route.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.4.6

The import of ‘ActionT’

Check warning on line 26 in Web/Scotty/Route.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 8.10.7

The import of ‘ActionT’

Check warning on line 26 in Web/Scotty/Route.hs

View workflow job for this annotation

GitHub Actions / ubuntu-latest / ghc 9.0.2

The import of ‘ActionT’
import Web.Scotty.Util (strictByteStringToLazyText)
import Web.Scotty.Util (decodeUtf8Lenient)
import Web.Scotty.Body (cloneBodyInfo, getBodyAction, getBodyChunkAction, getFormParamsAndFilesAction)

-- | get = 'addroute' 'GET'
Expand Down Expand Up @@ -130,21 +129,21 @@ matchRoute (Capture pat) req = go (T.split (=='/') pat) (compress $ T.split (==

-- 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.
Expand Down
Loading

0 comments on commit 00c9a75

Please sign in to comment.