yesod-core 1.4.35.1 → 1.4.36
raw patch · 6 files changed
+131/−3 lines, 6 filesnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Yesod.Core.Handler: replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
- Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1l9I -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1l9I; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1l9J, msg_a1l9K) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1l9J); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1l9K); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1l9I; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route where addParams [] routeBldr = routeBldr addParams nonEmptyParams routeBldr = let routeBS = toByteString routeBldr qsSeparator = fromChar $ if elem '?' routeBS then '&' else '?' valueToMaybe t = if t == "" then Nothing else Just t queryText = map (id *** valueToMaybe) nonEmptyParams in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] } authRoute _ = Nothing cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . null) s dropDash t | all (== '-') t = drop 1 t | otherwise = t joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ encodeUtf8 x addDash t | all (== '-') t = cons '-' t | otherwise = t addStaticContent _ _ _ = return Nothing maximumContentLength _ _ = Just $ 2 * 1024 * 1024 makeLogger _ = defaultMakeLogger messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site jsLoader _ = BottomOfBody jsAttributes _ = [] makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 defaultKeyFile fileUpload _ (KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd shouldLog _ = defaultShouldLog shouldLogIO a b c = return (shouldLog a b c) yesodMiddleware = defaultYesodMiddleware yesodWithInternalState _ _ = bracket createInternalState closeInternalState defaultMessageWidget title body = do { setTitle title; toWidget (\ _render_a1lam -> do { id ((preEscapedText . pack) "<h1>"); id (toHtml title); id ((preEscapedText . pack) "</h1>\n"); asHtmlUrl body _render_a1lam }) }
+ Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1lAp -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1lAp; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1lAq, msg_a1lAr) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1lAq); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1lAr); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1lAp; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route where addParams [] routeBldr = routeBldr addParams nonEmptyParams routeBldr = let routeBS = toByteString routeBldr qsSeparator = fromChar $ if elem '?' routeBS then '&' else '?' valueToMaybe t = if t == "" then Nothing else Just t queryText = map (id *** valueToMaybe) nonEmptyParams in copyByteString routeBS `mappend` qsSeparator `mappend` renderQueryText False queryText isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ W.requestMethod wai `notElem` ["GET", "HEAD", "OPTIONS", "TRACE"] } authRoute _ = Nothing cleanPath _ s = if corrected == s then Right $ map dropDash s else Left corrected where corrected = filter (not . null) s dropDash t | all (== '-') t = drop 1 t | otherwise = t joinPath _ ar pieces' qs' = fromText ar `mappend` encodePath pieces qs where pieces = if null pieces' then [""] else map addDash pieces' qs = map (encodeUtf8 *** go) qs' go "" = Nothing go x = Just $ encodeUtf8 x addDash t | all (== '-') t = cons '-' t | otherwise = t addStaticContent _ _ _ = return Nothing maximumContentLength _ _ = Just $ 2 * 1024 * 1024 makeLogger _ = defaultMakeLogger messageLoggerSource site = defaultMessageLoggerSource $ shouldLogIO site jsLoader _ = BottomOfBody jsAttributes _ = [] makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 defaultKeyFile fileUpload _ (KnownLength size) | size <= 50000 = FileUploadMemory lbsBackEnd fileUpload _ _ = FileUploadDisk tempFileBackEnd shouldLog _ = defaultShouldLog shouldLogIO a b c = return (shouldLog a b c) yesodMiddleware = defaultYesodMiddleware yesodWithInternalState _ _ = bracket createInternalState closeInternalState defaultMessageWidget title body = do { setTitle title; toWidget (\ _render_a1lB3 -> do { id ((preEscapedText . pack) "<h1>"); id (toHtml title); id ((preEscapedText . pack) "</h1>\n"); asHtmlUrl body _render_a1lB3 }) }
Files
- ChangeLog.md +4/−0
- Yesod/Core/Content.hs +9/−1
- Yesod/Core/Handler.hs +37/−1
- test/YesodCoreTest.hs +2/−0
- test/YesodCoreTest/Header.hs +77/−0
- yesod-core.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.4.36++* Add `replaceOrAddHeader` function in Yesod.Core.Handler module. [1416](https://github.com/yesodweb/yesod/issues/1416)+ ## 1.4.35.1 * TH fix for GHC 8.2
Yesod/Core/Content.hs view
@@ -66,7 +66,8 @@ import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J-#if MIN_VERSION_aeson(0, 7, 0)+#if MIN_VERSION_aeson(1, 0, 0)+#elif MIN_VERSION_aeson(0, 7, 0) import Data.Aeson.Encode (encodeToTextBuilder) #else import Data.Aeson.Encode (fromValue)@@ -242,13 +243,20 @@ toContent (DontFullyEvaluate a) = ContentDontEvaluate $ toContent a instance ToContent J.Value where+#if MIN_VERSION_aeson(1, 0, 0) toContent = flip ContentBuilder Nothing+ . J.fromEncoding+ . J.toEncoding+#else+ toContent = flip ContentBuilder Nothing . Blaze.fromLazyText . toLazyText #if MIN_VERSION_aeson(0, 7, 0) . encodeToTextBuilder #else . fromValue+#endif+ #endif #if MIN_VERSION_aeson(0, 11, 0)
Yesod/Core/Handler.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- -- Module : Yesod.Handler@@ -114,6 +115,7 @@ , deleteCookie , addHeader , setHeader+ , replaceOrAddHeader , setLanguage -- ** Content caching and expiration , cacheSeconds@@ -206,7 +208,7 @@ import Data.Aeson (ToJSON(..)) import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as TL import Text.Blaze.Html.Renderer.Utf8 (renderHtml)@@ -786,6 +788,40 @@ setHeader :: MonadHandler m => Text -> Text -> m () setHeader = addHeader {-# DEPRECATED setHeader "Please use addHeader instead" #-}++-- | Replace an existing header with a new value or add a new header+-- if not present.+--+-- Note that, while the data type used here is 'Text', you must provide only+-- ASCII value to be HTTP compliant.+--+-- @since 1.4.36+replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()+replaceOrAddHeader a b =+ modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}+ where+ repHeader = Header (encodeUtf8 a) (encodeUtf8 b)++ sameHeaderName :: Header -> Header -> Bool+ sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)+ sameHeaderName _ _ = False++ replaceIndividualHeader :: [Header] -> [Header]+ replaceIndividualHeader [] = [repHeader]+ replaceIndividualHeader xs = aux xs []+ where+ aux [] acc = acc ++ [repHeader]+ aux (x:xs') acc =+ if sameHeaderName repHeader x+ then acc +++ [repHeader] +++ (filter (\header -> not (sameHeaderName header repHeader)) xs')+ else aux xs' (acc ++ [x])++ replaceHeader :: Endo [Header] -> Endo [Header]+ replaceHeader endo =+ let allHeaders :: [Header] = appEndo endo []+ in Endo (\rest -> replaceIndividualHeader allHeaders ++ rest) -- | Set the Cache-Control header to indicate this response should be cached -- for the given number of seconds.
test/YesodCoreTest.hs view
@@ -6,6 +6,7 @@ import YesodCoreTest.Widget import YesodCoreTest.Media import YesodCoreTest.Links+import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling@@ -27,6 +28,7 @@ specs :: Spec specs = do+ headerTest cleanPathTest exceptionsTest widgetTest
+ test/YesodCoreTest/Header.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes,+ TypeFamilies, MultiParamTypeClasses, ViewPatterns #-}++module YesodCoreTest.Header+ ( headerTest+ , Widget+ , resourcesApp+ ) where++import Data.Text (Text)+import Network.HTTP.Types (decodePathSegments)+import Network.Wai+import Network.Wai.Test+import Test.Hspec+import Yesod.Core++data App =+ App++mkYesod+ "App"+ [parseRoutes|+/header1 Header1R GET+/header2 Header2R GET+/header3 Header3R GET+|]++instance Yesod App++getHeader1R :: Handler RepPlain+getHeader1R = do+ addHeader "hello" "world"+ return $ RepPlain $ toContent ("header test" :: Text)++getHeader2R :: Handler RepPlain+getHeader2R = do+ addHeader "hello" "world"+ replaceOrAddHeader "hello" "sibi"+ return $ RepPlain $ toContent ("header test" :: Text)++getHeader3R :: Handler RepPlain+getHeader3R = do+ addHeader "hello" "world"+ addHeader "michael" "snoyman"+ addHeader "yesod" "framework"+ replaceOrAddHeader "yesod" "book"+ return $ RepPlain $ toContent ("header test" :: Text)++runner :: Session () -> IO ()+runner f = toWaiApp App >>= runSession f++addHeaderTest :: IO ()+addHeaderTest =+ runner $ do+ res <- request defaultRequest {pathInfo = decodePathSegments "/header1"}+ assertHeader "hello" "world" res++multipleHeaderTest :: IO ()+multipleHeaderTest =+ runner $ do+ res <- request defaultRequest {pathInfo = decodePathSegments "/header2"}+ assertHeader "hello" "sibi" res++header3Test :: IO ()+header3Test = do+ runner $ do+ res <- request defaultRequest {pathInfo = decodePathSegments "/header3"}+ assertHeader "hello" "world" res+ assertHeader "michael" "snoyman" res+ assertHeader "yesod" "book" res++headerTest :: Spec+headerTest =+ describe "Test.Header" $ do+ it "addHeader" addHeaderTest+ it "multiple header" multipleHeaderTest+ it "persist headers" header3Test
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.4.35.1+version: 1.4.36 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -150,6 +150,7 @@ YesodCoreTest.Auth YesodCoreTest.Cache YesodCoreTest.CleanPath+ YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling YesodCoreTest.Exceptions