yesod-core 1.4.20.1 → 1.4.20.2
raw patch · 12 files changed
+111/−25 lines, 12 filesdep ~shakespearedep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: shakespeare, template-haskell
API changes (from Hackage documentation)
- Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1bdq -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1bdq; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1bdr, msg_a1bds) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1bdr); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1bds); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1bdq; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ 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 makeSessionBackend _ = fmap 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
+ Yesod.Core: class RenderRoute site => Yesod site where approot = ApprootRelative errorHandler = defaultErrorHandler defaultLayout w = do { p <- widgetToPageContent w; msgs <- getMessages; withUrlRenderer (\ _render_a1bfJ -> do { id ((preEscapedText . pack) "<!DOCTYPE html>\n\ \<html><head><title>"); id (toHtml (pageTitle p)); id ((preEscapedText . pack) "</title>"); asHtmlUrl (pageHead p) _render_a1bfJ; id ((preEscapedText . pack) "</head><body>"); mapM_ (\ (status_a1bfK, msg_a1bfL) -> do { id ((preEscapedText . pack) "<p class=\"message "); id (toHtml status_a1bfK); id ((preEscapedText . pack) "\">"); id (toHtml msg_a1bfL); id ((preEscapedText . pack) "</p>") }) msgs; asHtmlUrl (pageBody p) _render_a1bfJ; id ((preEscapedText . pack) "</body></html>") }) } urlRenderOverride _ _ = Nothing isAuthorized _ _ = return Authorized isWriteRequest _ = do { wai <- waiRequest; return $ 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 makeSessionBackend _ = fmap 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
Files
- ChangeLog.md +4/−0
- Yesod/Core/Internal/TH.hs +15/−3
- Yesod/Routes/TH/Dispatch.hs +2/−1
- Yesod/Routes/TH/ParseRoute.hs +9/−1
- Yesod/Routes/TH/RenderRoute.hs +42/−13
- Yesod/Routes/TH/RouteAttrs.hs +9/−1
- bench/widget.hs +1/−0
- test/Hierarchy.hs +5/−0
- test/RouteSpec.hs +4/−0
- test/YesodCoreTest/Exceptions.hs +1/−1
- test/YesodCoreTest/WaiSubsite.hs +17/−4
- yesod-core.cabal +2/−1
ChangeLog.md view
@@ -1,3 +1,7 @@+## 1.4.20.2++* GHC 8 support+ ## 1.4.20.1 * Log a warning when a CSRF error occurs [#1200](https://github.com/yesodweb/yesod/pull/1200)
Yesod/Core/Internal/TH.hs view
@@ -9,7 +9,7 @@ import Prelude hiding (exp) import Yesod.Core.Handler -import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH hiding (cxt, instanceD) import Language.Haskell.TH.Syntax import qualified Network.Wai as W@@ -86,8 +86,13 @@ case info of TyConI dec -> case dec of+#if MIN_VERSION_template_haskell(2,11,0)+ DataD _ _ vs _ _ _ -> length vs+ NewtypeD _ _ vs _ _ _ -> length vs+#else DataD _ _ vs _ _ -> length vs NewtypeD _ _ vs _ _ -> length vs+#endif _ -> 0 _ -> 0 _ -> return 0@@ -101,7 +106,7 @@ case arg of Left t -> ( ConT (mkName t):xs, n:ns, cs ) Right ts -> ( VarT n :xs, ns- , fmap (\t -> + , fmap (\t -> #if MIN_VERSION_template_haskell(2,10,0) AppT (ConT $ mkName t) (VarT n) #else@@ -164,7 +169,7 @@ mkDispatchInstance master cxt f res = do clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res let thisDispatch = FunD 'yesodDispatch [clause']- return [InstanceD cxt yDispatch [thisDispatch]]+ return [instanceD cxt yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master @@ -181,3 +186,10 @@ [innerFun] ] return $ LetE [fun] (VarE helper)++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif
Yesod/Routes/TH/Dispatch.hs view
@@ -176,9 +176,10 @@ subDispatcherE <- mdsSubDispatcher runHandlerE <- mdsRunHandler sub <- newName "sub"+ let allDyns = extraParams ++ dyns sroute <- newName "sroute" let sub2 = LamE [VarP sub]- (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns)+ (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns) let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp route' = foldl' AppE (ConE (mkName name)) dyns route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons
Yesod/Routes/TH/ParseRoute.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Yesod.Routes.TH.ParseRoute ( -- ** ParseRoute@@ -27,7 +28,7 @@ (map removeMethods ress) helper <- newName "helper" fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]- return $ InstanceD [] (ConT ''ParseRoute `AppT` typ)+ return $ instanceD [] (ConT ''ParseRoute `AppT` typ) [ FunD 'parseRoute $ return $ Clause [] (NormalB $ fixer `AppE` VarE helper)@@ -42,3 +43,10 @@ fixDispatch (Methods x _) = Methods x [] fixDispatch x = x++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif
Yesod/Routes/TH/RenderRoute.hs view
@@ -8,6 +8,9 @@ ) where import Yesod.Routes.TH.Types+#if MIN_VERSION_template_haskell(2,11,0)+import Language.Haskell.TH (conT)+#endif import Language.Haskell.TH.Syntax import Data.Maybe (maybeToList) import Control.Monad (replicateM)@@ -15,19 +18,20 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class #if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>)) import Data.Monoid (mconcat) #endif -- | Generate the constructors of a route data type.-mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec])-mkRouteCons =- mconcat . map mkRouteCon+mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec])+mkRouteCons rttypes =+ mconcat <$> mapM mkRouteCon rttypes where mkRouteCon (ResourceLeaf res) =- ([con], [])+ return ([con], []) where con = NormalC (mkName $ resourceName res)- $ map (\x -> (NotStrict, x))+ $ map (\x -> (notStrict, x)) $ concat [singles, multi, sub] singles = concatMap toSingle $ resourcePieces res toSingle Static{} = []@@ -39,14 +43,19 @@ case resourceDispatch res of Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ] _ -> []- mkRouteCon (ResourceParent name _check pieces children) =- ([con], dec : decs)++ mkRouteCon (ResourceParent name _check pieces children) = do+ (cons, decs) <- mkRouteCons children+#if MIN_VERSION_template_haskell(2,11,0)+ dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq]+#else+ let dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq]+#endif+ return ([con], dec : decs) where- (cons, decs) = mkRouteCons children con = NormalC (mkName name)- $ map (\x -> (NotStrict, x))+ $ map (\x -> (notStrict, x)) $ concat [singles, [ConT $ mkName name]]- dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] singles = concatMap toSingle pieces toSingle Static{} = []@@ -143,10 +152,30 @@ mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance' cxt typ ress = do cls <- mkRenderRouteClauses ress- let (cons, decs) = mkRouteCons ress- return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)- [ DataInstD [] ''Route [typ] cons clazzes+ (cons, decs) <- mkRouteCons ress+#if MIN_VERSION_template_haskell(2,11,0)+ did <- DataInstD [] ''Route [typ] Nothing cons <$> mapM conT clazzes+#else+ let did = DataInstD [] ''Route [typ] cons clazzes+#endif+ return $ instanceD cxt (ConT ''RenderRoute `AppT` typ)+ [ did , FunD (mkName "renderRoute") cls ] : decs where clazzes = [''Show, ''Eq, ''Read]++#if MIN_VERSION_template_haskell(2,11,0)+notStrict :: Bang+notStrict = Bang NoSourceUnpackedness NoSourceStrictness+#else+notStrict :: Strict+notStrict = NotStrict+#endif++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif
Yesod/Routes/TH/RouteAttrs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs@@ -13,7 +14,7 @@ mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec mkRouteAttrsInstance typ ress = do clauses <- mapM (goTree id) ress- return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ)+ return $ instanceD [] (ConT ''RouteAttrs `AppT` typ) [ FunD 'routeAttrs $ concat clauses ] @@ -36,3 +37,10 @@ [] where toText s = VarE 'pack `AppE` LitE (StringL s)++instanceD :: Cxt -> Type -> [Dec] -> Dec+#if MIN_VERSION_template_haskell(2,11,0)+instanceD = InstanceD Nothing+#else+instanceD = InstanceD+#endif
bench/widget.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} -- | BigTable benchmark implemented using Hamlet. -- {-# LANGUAGE QuasiQuotes #-}
test/Hierarchy.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-} module Hierarchy ( hierarchy , Dispatcher (..)@@ -124,7 +125,11 @@ , mdsUnwrapper = return } resources return+#if MIN_VERSION_template_haskell(2,11,0)+ $ InstanceD Nothing+#else $ InstanceD+#endif [] (ConT ''Dispatcher `AppT` ConT ''Hierarchy
test/RouteSpec.hs view
@@ -95,7 +95,11 @@ , mdsUnwrapper = return } ress return+#if MIN_VERSION_template_haskell(2,11,0)+ $ InstanceD Nothing+#else $ InstanceD+#endif [] (ConT ''Dispatcher `AppT` ConT ''MyApp
test/YesodCoreTest/Exceptions.hs view
@@ -41,7 +41,7 @@ case500 = runner $ do res <- request defaultRequest assertStatus 500 res- assertBody "FOOBAR" res+ assertBodyContains "FOOBAR" res caseRedirect :: IO () caseRedirect = runner $ do
test/YesodCoreTest/WaiSubsite.hs view
@@ -1,22 +1,30 @@-{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-} module YesodCoreTest.WaiSubsite (specs, Widget) where import YesodCoreTest.YesodTest import Yesod.Core import qualified Network.HTTP.Types as H+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as B (concat)+import qualified Data.ByteString.Lazy.Char8 as B8 (pack) -myApp :: Application-myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI"+myApp :: ByteString -> Application+myApp s _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] s getApp :: a -> WaiSubsite-getApp _ = WaiSubsite myApp+getApp _ = WaiSubsite $ myApp "WAI" +getAppArgs :: a -> Int -> Int -> WaiSubsite+getAppArgs _ i j = WaiSubsite $ myApp $ B.concat ["WAI - ", B8.pack $ show i, " - ", B8.pack $ show j ]+ data Y = Y mkYesod "Y" [parseRoutes| / RootR GET /sub WaiSubsiteR WaiSubsite getApp /nested NestedR: /sub NestedWaiSubsiteR WaiSubsite getApp+/nestedargs/#Int NestedArgsR:+ /sub/#Int NestedArgsWaiSubsiteR WaiSubsite getAppArgs |] instance Yesod Y@@ -43,3 +51,8 @@ res <- request defaultRequest { pathInfo = ["nested", "sub", "foo"] } assertStatus 200 res assertBodyContains "WAI" res++ it "nested subsite with arguments" $ app $ do+ res <- request defaultRequest { pathInfo = ["nestedargs", "1", "sub", "2", "foo"] }+ assertStatus 200 res+ assertBodyContains "WAI - 1 - 2" res
yesod-core.cabal view
@@ -1,5 +1,5 @@ name: yesod-core-version: 1.4.20.1+version: 1.4.20.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -177,6 +177,7 @@ , transformers , yesod-core , blaze-html+ , shakespeare main-is: widget.hs ghc-options: -Wall -O2