diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 1.4.32 + +* Fix warnings +* Route parsing handles CRLF line endings +* Add 'getPostParams' in Yesod.Core.Handler +* Haddock rendering improved. + ## 1.4.31 * Add `parseCheckJsonBody` and `requireCheckJsonBody` diff --git a/Yesod/Core/Class/Handler.hs b/Yesod/Core/Class/Handler.hs --- a/Yesod/Core/Class/Handler.hs +++ b/Yesod/Core/Class/Handler.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT module Yesod.Core.Class.Handler ( MonadHandler (..) , MonadWidget (..) diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -442,10 +442,9 @@ -- headers are ignored over HTTP. -- -- Since 1.4.7 -sslOnlyMiddleware :: Yesod site - => Int -- ^ minutes - -> HandlerT site IO res - -> HandlerT site IO res +sslOnlyMiddleware :: Int -- ^ minutes + -> HandlerT site IO res + -> HandlerT site IO res sslOnlyMiddleware timeout handler = do addHeader "Strict-Transport-Security" $ T.pack $ concat [ "max-age=" @@ -496,8 +495,7 @@ -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14 -csrfCheckMiddleware :: Yesod site - => HandlerT site IO res +csrfCheckMiddleware :: HandlerT site IO res -> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from. @@ -512,7 +510,7 @@ -- The cookie's path is set to @/@, making it valid for your whole website. -- -- Since 1.4.14 -defaultCsrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res +defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. @@ -522,7 +520,7 @@ -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- -- Since 1.4.14 -csrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> SetCookie -> HandlerT site IO res +csrfSetCookieMiddleware :: HandlerT site IO res -> SetCookie -> HandlerT site IO res csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. @@ -546,7 +544,7 @@ defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware -- | Convert a widget to a 'PageContent'. -widgetToPageContent :: (Eq (Route site), Yesod site) +widgetToPageContent :: Yesod site => WidgetT site IO () -> HandlerT site IO (PageContent (Route site)) widgetToPageContent w = do diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -31,6 +31,7 @@ , getsYesod , getUrlRender , getUrlRenderParams + , getPostParams , getCurrentRoute , getRequest , waiRequest @@ -339,6 +340,18 @@ => m (Route (HandlerSite m) -> [(Text, Text)] -> Text) getUrlRenderParams = rheRender <$> askHandlerEnv +-- | Get all the post parameters passed to the handler. To also get +-- the submitted files (if any), you have to use 'runRequestBody' +-- instead of this function. +-- +-- @since 1.4.33 +getPostParams + :: MonadHandler m + => m [(Text, Text)] +getPostParams = do + reqBodyContent <- runRequestBody + return $ fst reqBodyContent + -- | Get the route requested by the user. If this is a 404 response- where the -- user requested an invalid route- this function will return 'Nothing'. getCurrentRoute :: MonadHandler m => m (Maybe (Route (HandlerSite m))) @@ -425,7 +438,7 @@ -- Uses 'handlerToIO', liftResourceT, and resourceForkIO -- for correctness and efficiency -- --- Since 1.2.8 +-- @since 1.2.8 forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler -> HandlerT site IO () -> HandlerT site IO () @@ -617,7 +630,7 @@ -- | Bypass remaining handler code and output the given JSON with the given -- status code. -- --- Since 1.4.18 +-- @since 1.4.18 sendStatusJSON :: (MonadHandler m, ToJSON c) => H.Status -> c -> m a #if MIN_VERSION_aeson(0, 11, 0) sendStatusJSON s v = sendResponseStatus s (toEncoding v) @@ -642,7 +655,7 @@ -- | Switch over to handling the current request with a WAI @Application@. -- --- Since 1.2.17 +-- @since 1.2.17 sendWaiApplication :: MonadHandler m => W.Application -> m b sendWaiApplication = handlerError . HCWaiApp @@ -650,7 +663,7 @@ -- WebSockets. Requires WAI 3.0 or later, and a web server which supports raw -- responses (e.g., Warp). -- --- Since 1.2.16 +-- @since 1.2.16 sendRawResponseNoConduit :: (MonadHandler m, MonadBaseControl IO m) => (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ()) @@ -666,7 +679,7 @@ -- WAI 2.1 or later, and a web server which supports raw responses (e.g., -- Warp). -- --- Since 1.2.7 +-- @since 1.2.7 sendRawResponse :: (MonadHandler m, MonadBaseControl IO m) => (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ()) -> m a @@ -685,7 +698,7 @@ -- | Send a 304 not modified response immediately. This is a short-circuiting -- action. -- --- Since 1.4.4 +-- @since 1.4.4 notModified :: MonadHandler m => m a notModified = sendWaiResponse $ W.responseBuilder H.status304 [] mempty @@ -765,7 +778,7 @@ -- Note that, while the data type used here is 'Text', you must provide only -- ASCII value to be HTTP compliant. -- --- Since 1.2.0 +-- @since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m () addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8 @@ -810,7 +823,7 @@ -- value is a value etag value, no sanity checking is performed by this -- function. -- --- Since 1.4.4 +-- @since 1.4.4 setEtag :: MonadHandler m => Text -> m () setEtag etag = do mmatch <- lookupHeader "if-none-match" @@ -856,7 +869,7 @@ -- | Clear all session variables. -- --- Since: 1.0.1 +-- @since: 1.0.1 clearSession :: MonadHandler m => m () clearSession = modify $ \x -> x { ghsSession = Map.empty } @@ -896,7 +909,7 @@ -- -- > redirect (NewsfeedR :#: storyId) -- --- Since 1.2.9. +-- @since 1.2.9. data Fragment a b = a :#: b deriving (Show, Typeable) instance (RedirectUrl master a, PathPiece b) => RedirectUrl master (Fragment a b) where @@ -960,7 +973,7 @@ -- | Deprecated synonym for 'withUrlRenderer'. -- --- Since 1.2.0 +-- @since 1.2.0 giveUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output @@ -970,7 +983,7 @@ -- | Provide a URL rendering function to the given function and return the -- result. Useful for processing Shakespearean templates. -- --- Since 1.2.20 +-- @since 1.2.20 withUrlRenderer :: MonadHandler m => ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output) -> m output @@ -998,7 +1011,7 @@ -- -- See the original announcement: -- --- Since 1.2.0 +-- @since 1.2.0 cached :: (MonadHandler m, Typeable a) => m a -> m a @@ -1022,7 +1035,7 @@ -- You can turn those parameters into a ByteString cache key. -- For example, caching a lookup of a Link by a token where multiple token lookups might be performed. -- --- Since 1.4.0 +-- @since 1.4.0 cachedBy :: (MonadHandler m, Typeable a) => S.ByteString -> m a -> m a cachedBy k action = do cache <- ghsCacheBy <$> get @@ -1063,13 +1076,13 @@ -- | Lookup a request header. -- --- Since 1.2.2 +-- @since 1.2.2 lookupHeader :: MonadHandler m => CI S8.ByteString -> m (Maybe S8.ByteString) lookupHeader = fmap listToMaybe . lookupHeaders -- | Lookup a request header. -- --- Since 1.2.2 +-- @since 1.2.2 lookupHeaders :: MonadHandler m => CI S8.ByteString -> m [S8.ByteString] lookupHeaders key = do req <- waiRequest @@ -1078,7 +1091,7 @@ -- | Lookup basic authentication data from __Authorization__ header of -- request. Returns user name and password -- --- Since 1.4.9 +-- @since 1.4.9 lookupBasicAuth :: (MonadHandler m) => m (Maybe (Text, Text)) lookupBasicAuth = fmap (>>= getBA) (lookupHeader "Authorization") where @@ -1088,7 +1101,7 @@ -- | Lookup bearer authentication datafrom __Authorization__ header of -- request. Returns bearer token value -- --- Since 1.4.9 +-- @since 1.4.9 lookupBearerAuth :: (MonadHandler m) => m (Maybe Text) lookupBearerAuth = fmap (>>= getBR) (lookupHeader "Authorization") @@ -1119,13 +1132,13 @@ lookupPostParam = fmap listToMaybe . lookupPostParams -- | Lookup for POSTed files. -lookupFile :: (MonadHandler m, MonadResource m) +lookupFile :: MonadHandler m => Text -> m (Maybe FileInfo) lookupFile = fmap listToMaybe . lookupFiles -- | Lookup for POSTed files. -lookupFiles :: (MonadHandler m, MonadResource m) +lookupFiles :: MonadHandler m => Text -> m [FileInfo] lookupFiles pn = do @@ -1162,7 +1175,7 @@ -- | Select a representation to send to the client based on the representations -- provided inside this do-block. Should be used together with 'provideRep'. -- --- Since 1.2.0 +-- @since 1.2.0 selectRep :: MonadHandler m => Writer.Writer (Endo [ProvidedRep m]) () -> m TypedContent @@ -1218,13 +1231,13 @@ -- | Internal representation of a single provided representation. -- --- Since 1.2.0 +-- @since 1.2.0 data ProvidedRep m = ProvidedRep !ContentType !(m Content) -- | Provide a single representation to be used, based on the request of the -- client. Should be used together with 'selectRep'. -- --- Since 1.2.0 +-- @since 1.2.0 provideRep :: (Monad m, HasContentType a) => m a -> Writer.Writer (Endo [ProvidedRep m]) () @@ -1237,7 +1250,7 @@ -- -- > provideRepType "application/x-special-format" "This is the content" -- --- Since 1.2.0 +-- @since 1.2.0 provideRepType :: (Monad m, ToContent a) => ContentType -> m a @@ -1247,7 +1260,7 @@ -- | Stream in the raw request body without any parsing. -- --- Since 1.2.0 +-- @since 1.2.0 rawRequestBody :: MonadHandler m => Source m S.ByteString rawRequestBody = do req <- lift waiRequest @@ -1267,7 +1280,7 @@ -- -- > respond ct = return . TypedContent ct . toContent -- --- Since 1.2.0 +-- @since 1.2.0 respond :: (Monad m, ToContent a) => ContentType -> a -> m TypedContent respond ct = return . TypedContent ct . toContent @@ -1279,7 +1292,7 @@ -- actions make no sense here. For example: short-circuit responses, setting -- headers, changing status codes, etc. -- --- Since 1.2.0 +-- @since 1.2.0 respondSource :: ContentType -> Source (HandlerT site IO) (Flush Builder) -> HandlerT site IO TypedContent @@ -1293,44 +1306,44 @@ -- | In a streaming response, send a single chunk of data. This function works -- on most datatypes, such as @ByteString@ and @Html@. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunk :: Monad m => ToFlushBuilder a => a -> Producer m (Flush Builder) sendChunk = yield . toFlushBuilder -- | In a streaming response, send a flush command, causing all buffered data -- to be immediately sent to the client. -- --- Since 1.2.0 +-- @since 1.2.0 sendFlush :: Monad m => Producer m (Flush Builder) sendFlush = yield Flush -- | Type-specialized version of 'sendChunk' for strict @ByteString@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkBS :: Monad m => S.ByteString -> Producer m (Flush Builder) sendChunkBS = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @ByteString@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkLBS :: Monad m => L.ByteString -> Producer m (Flush Builder) sendChunkLBS = sendChunk -- | Type-specialized version of 'sendChunk' for strict @Text@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkText :: Monad m => T.Text -> Producer m (Flush Builder) sendChunkText = sendChunk -- | Type-specialized version of 'sendChunk' for lazy @Text@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkLazyText :: Monad m => TL.Text -> Producer m (Flush Builder) sendChunkLazyText = sendChunk -- | Type-specialized version of 'sendChunk' for @Html@s. -- --- Since 1.2.0 +-- @since 1.2.0 sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml = sendChunk @@ -1374,7 +1387,7 @@ -- | The default cookie name for the CSRF token ("XSRF-TOKEN"). -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfCookieName :: S8.ByteString defaultCsrfCookieName = "XSRF-TOKEN" @@ -1382,7 +1395,7 @@ -- -- The cookie's path is set to @/@, making it valid for your whole website. -- --- Since 1.4.14 +-- @since 1.4.14 setCsrfCookie :: MonadHandler m => m () setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" } @@ -1390,7 +1403,7 @@ -- -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- --- Since 1.4.14 +-- @since 1.4.14 setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m () setCsrfCookieWithCookie cookie = do mCsrfToken <- reqToken <$> getRequest @@ -1398,14 +1411,14 @@ -- | The default header name for the CSRF token ("X-XSRF-TOKEN"). -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfHeaderName :: CI S8.ByteString defaultCsrfHeaderName = "X-XSRF-TOKEN" -- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () checkCsrfHeaderNamed headerName = do valid <- hasValidCsrfHeaderNamed headerName @@ -1413,7 +1426,7 @@ -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- --- Since 1.4.14 +-- @since 1.4.14 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool hasValidCsrfHeaderNamed headerName = do mCsrfToken <- reqToken <$> getRequest @@ -1425,14 +1438,14 @@ -- | The default parameter name for the CSRF token ("_token") -- --- Since 1.4.14 +-- @since 1.4.14 defaultCsrfParamName :: Text defaultCsrfParamName = "_token" -- | Takes a POST parameter name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfParamNamed :: MonadHandler m => Text -> m () checkCsrfParamNamed paramName = do valid <- hasValidCsrfParamNamed paramName @@ -1440,7 +1453,7 @@ -- | Takes a POST parameter name to lookup a CSRF token, and returns whether the value matches the token stored in the session. -- --- Since 1.4.14 +-- @since 1.4.14 hasValidCsrfParamNamed :: MonadHandler m => Text -> m Bool hasValidCsrfParamNamed paramName = do mCsrfToken <- reqToken <$> getRequest @@ -1451,7 +1464,7 @@ -- | Checks that a valid CSRF token is present in either the request headers or POST parameters. -- If the value doesn't match the token stored in the session, this function throws a 'PermissionDenied' error. -- --- Since 1.4.14 +-- @since 1.4.14 checkCsrfHeaderOrParam :: (MonadHandler m, MonadLogger m) => CI S8.ByteString -- ^ The header name to lookup the CSRF token -> Text -- ^ The POST parameter name to lookup the CSRF token diff --git a/Yesod/Core/Json.hs b/Yesod/Core/Json.hs --- a/Yesod/Core/Json.hs +++ b/Yesod/Core/Json.hs @@ -189,7 +189,7 @@ jsonEncodingOrRedirect = jsonOrRedirect' J.toEncoding #endif -jsonOrRedirect' :: (MonadHandler m, J.ToJSON a) +jsonOrRedirect' :: MonadHandler m => (a -> b) -> Route (HandlerSite m) -- ^ Redirect target -> a -- ^ Data to send via JSON diff --git a/Yesod/Core/Types.hs b/Yesod/Core/Types.hs --- a/Yesod/Core/Types.hs +++ b/Yesod/Core/Types.hs @@ -462,7 +462,12 @@ WidgetT $ \e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) e where q u (WidgetT b) = WidgetT (u . b) +-- CPP to avoid a redundant constraints warning +#if MIN_VERSION_base(4,9,0) +instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where +#else instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where +#endif liftResourceT f = WidgetT $ \hd -> liftIO $ (, mempty) <$> runInternalState f (handlerResource hd) instance MonadIO m => MonadLogger (WidgetT site m) where diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs --- a/Yesod/Routes/Parse.hs +++ b/Yesod/Routes/Parse.hs @@ -63,7 +63,7 @@ -- invalid input. resourcesFromString :: String -> [ResourceTree String] resourcesFromString = - fst . parse 0 . filter (not . all (== ' ')) . lines + fst . parse 0 . filter (not . all (== ' ')) . lines . filter (/= '\r') where parse _ [] = ([], []) parse indent (thisLine:otherLines) diff --git a/bench/widget.hs b/bench/widget.hs --- a/bench/widget.hs +++ b/bench/widget.hs @@ -7,20 +7,16 @@ import Criterion.Main import Text.Hamlet -import Numeric (showInt) import qualified Data.ByteString.Lazy as L import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import Data.Monoid (mconcat) import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html (toHtml) import Yesod.Core.Widget -import Control.Monad.Trans.Writer -import Control.Monad.Trans.RWS -import Data.Functor.Identity import Yesod.Core.Types -import Data.Monoid -import Data.IORef +import Data.Int +main :: IO () main = defaultMain [ bench "bigTable html" $ nf bigTableHtml bigTableData , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData @@ -35,6 +31,7 @@ bigTableData = replicate rows [1..10] {-# NOINLINE bigTableData #-} +bigTableHtml :: Show a => [[a]] -> Int64 bigTableHtml rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows @@ -43,6 +40,7 @@
#{show cell} |] +bigTableHamlet :: Show a => [[a]] -> Int64 bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| $forall row <- rows @@ -51,6 +49,7 @@
#{show cell} |] +bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| $forall row <- rows @@ -64,6 +63,7 @@ (_, GWData { gwdBody = Body x }) <- w undefined return x -bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ mconcat $ map row t +bigTableBlaze :: Show a => [[a]] -> Int64 +bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t where row r = tr $ mconcat $ map (td . toHtml . show) r diff --git a/test.hs b/test.hs deleted file mode 100644 --- a/test.hs +++ /dev/null @@ -1,5 +0,0 @@ -import Test.Hspec -import qualified YesodCoreTest - -main :: IO () -main = hspec YesodCoreTest.specs diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs --- a/test/Hierarchy.hs +++ b/test/Hierarchy.hs @@ -17,6 +17,9 @@ , toText , Env (..) , subDispatch + -- to avoid warnings + , deleteDelete2 + , deleteDelete3 ) where import Test.Hspec diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs --- a/test/RouteSpec.hs +++ b/test/RouteSpec.hs @@ -118,7 +118,7 @@ route = MySubRoute (pieces, []) instance Dispatcher MySubParam master where - dispatcher env (pieces, method) = + dispatcher env (pieces, _method) = case map unpack pieces of [[c]] -> let route = ParamRoute c @@ -234,56 +234,65 @@ describe "overlap checking" $ do it "catches overlapping statics" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping dynamics" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /#Int Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping statics and dynamics" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /#String Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping multi" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /##*Strings Foo2 |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "catches overlapping subsite" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /foo Foo2 Subsite getSubsite |] findOverlapNames routes @?= [("Foo1", "Foo2")] it "no false positives" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /bar/#String Foo2 |] findOverlapNames routes @?= [] it "obeys ignore rules" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /#!String Foo2 /!foo Foo3 |] findOverlapNames routes @?= [] it "obeys multipiece ignore rules #779" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 /+![String] Foo2 |] findOverlapNames routes @?= [] it "ignore rules for entire route #779" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /foo Foo1 !/+[String] Foo2 !/#String Foo3 @@ -291,7 +300,8 @@ |] findOverlapNames routes @?= [] it "ignore rules for hierarchy" $ do - let routes = [parseRoutesNoCheck| + let routes :: [ResourceTree String] + routes = [parseRoutesNoCheck| /+[String] Foo1 !/foo Foo2: /foo Foo3 diff --git a/test/YesodCoreTest/Auth.hs b/test/YesodCoreTest/Auth.hs --- a/test/YesodCoreTest/Auth.hs +++ b/test/YesodCoreTest/Auth.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses #-} -module YesodCoreTest.Auth (specs, Widget) where +module YesodCoreTest.Auth + ( specs + , Widget + , resourcesApp + ) where import Yesod.Core import Test.Hspec diff --git a/test/YesodCoreTest/Cache.hs b/test/YesodCoreTest/Cache.hs --- a/test/YesodCoreTest/Cache.hs +++ b/test/YesodCoreTest/Cache.hs @@ -3,7 +3,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Rank2Types #-} -module YesodCoreTest.Cache (cacheTest, Widget) where +module YesodCoreTest.Cache + ( cacheTest + , Widget + , resourcesC + ) where import Test.Hspec diff --git a/test/YesodCoreTest/CleanPath.hs b/test/YesodCoreTest/CleanPath.hs --- a/test/YesodCoreTest/CleanPath.hs +++ b/test/YesodCoreTest/CleanPath.hs @@ -2,7 +2,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE CPP #-} -module YesodCoreTest.CleanPath (cleanPathTest, Widget) where +module YesodCoreTest.CleanPath + ( cleanPathTest + , Widget + , resourcesY + ) where import Test.Hspec @@ -60,7 +64,7 @@ corrected = filter (not . TS.null) s joinPath Y ar pieces' qs' = - fromText ar `mappend` encodePath pieces qs + fromText ar `Data.Monoid.mappend` encodePath pieces qs where pieces = if null pieces' then [""] else pieces' qs = map (TE.encodeUtf8 *** go) qs' diff --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -4,6 +4,7 @@ module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget + , resourcesApp ) where import Yesod.Core import Test.Hspec @@ -98,7 +99,7 @@ getFileBadNameR = return $ TypedContent "ignored" $ ContentFile (error "filebadname") Nothing goodBuilderContent :: Builder -goodBuilderContent = mconcat $ replicate 100 $ fromByteString "This is a test\n" +goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ fromByteString "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent @@ -114,6 +115,7 @@ getErrorR 8 = cacheSeconds undefined getErrorR 9 = setUltDest (undefined :: Text) getErrorR 10 = setMessage undefined +getErrorR x = error $ "getErrorR: " ++ show x errorHandlingTest :: Spec errorHandlingTest = describe "Test.ErrorHandling" $ do diff --git a/test/YesodCoreTest/Exceptions.hs b/test/YesodCoreTest/Exceptions.hs --- a/test/YesodCoreTest/Exceptions.hs +++ b/test/YesodCoreTest/Exceptions.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module YesodCoreTest.Exceptions (exceptionsTest, Widget) where +module YesodCoreTest.Exceptions + ( exceptionsTest + , Widget + , resourcesY + ) where import Test.Hspec diff --git a/test/YesodCoreTest/InternalRequest.hs b/test/YesodCoreTest/InternalRequest.hs --- a/test/YesodCoreTest/InternalRequest.hs +++ b/test/YesodCoreTest/InternalRequest.hs @@ -21,8 +21,8 @@ -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?). -looksRandom :: Bool -looksRandom = runST $ do +_looksRandom :: Bool +_looksRandom = runST $ do gen <- MWC.create s <- randomString 20 gen return $ s == "VH9SkhtptqPs6GqtofVg" @@ -57,7 +57,7 @@ noDisabledToken :: Bool noDisabledToken = reqToken r == Nothing where - r = parseWaiRequest' defaultRequest mempty False 1000 + r = parseWaiRequest' defaultRequest Data.Monoid.mempty False 1000 ignoreDisabledToken :: Bool ignoreDisabledToken = reqToken r == Nothing where diff --git a/test/YesodCoreTest/JsLoader.hs b/test/YesodCoreTest/JsLoader.hs --- a/test/YesodCoreTest/JsLoader.hs +++ b/test/YesodCoreTest/JsLoader.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module YesodCoreTest.JsLoader (specs, Widget) where +module YesodCoreTest.JsLoader + ( specs + , Widget + , resourcesH + ) where import YesodCoreTest.JsLoaderSites.Bottom (B(..)) diff --git a/test/YesodCoreTest/JsLoaderSites/Bottom.hs b/test/YesodCoreTest/JsLoaderSites/Bottom.hs --- a/test/YesodCoreTest/JsLoaderSites/Bottom.hs +++ b/test/YesodCoreTest/JsLoaderSites/Bottom.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module YesodCoreTest.JsLoaderSites.Bottom (B(..), Widget) where +module YesodCoreTest.JsLoaderSites.Bottom + ( B(..) + , Widget + , resourcesB -- avoid warning + ) where import Yesod.Core diff --git a/test/YesodCoreTest/Json.hs b/test/YesodCoreTest/Json.hs --- a/test/YesodCoreTest/Json.hs +++ b/test/YesodCoreTest/Json.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} -module YesodCoreTest.Json (specs, Widget) where +module YesodCoreTest.Json + ( specs + , Widget + , resourcesApp + ) where import Yesod.Core import Test.Hspec diff --git a/test/YesodCoreTest/Links.hs b/test/YesodCoreTest/Links.hs --- a/test/YesodCoreTest/Links.hs +++ b/test/YesodCoreTest/Links.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} -module YesodCoreTest.Links (linksTest, Widget) where +module YesodCoreTest.Links + ( linksTest + , Widget + , resourcesY + ) where import Test.Hspec @@ -26,12 +30,16 @@ data Vector a = Vector deriving (Show, Read, Eq) -instance PathMultiPiece (Vector a) +instance PathMultiPiece (Vector a) where + toPathMultiPiece = error "toPathMultiPiece" + fromPathMultiPiece = error "fromPathMultiPiece" data Foo x y = Foo deriving (Show, Read, Eq) -instance PathPiece (Foo x y) +instance PathPiece (Foo x y) where + toPathPiece = error "toPathPiece" + fromPathPiece = error "fromPathPiece" instance Yesod Y diff --git a/test/YesodCoreTest/NoOverloadedStrings.hs b/test/YesodCoreTest/NoOverloadedStrings.hs --- a/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/test/YesodCoreTest/NoOverloadedStrings.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! -module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where +module YesodCoreTest.NoOverloadedStrings + ( noOverloadedTest + , Widget + , resourcesY + ) where import Test.Hspec import YesodCoreTest.NoOverloadedStringsSub @@ -60,7 +64,7 @@ case_sanity :: IO () case_sanity = runner $ do res <- request defaultRequest - assertBody mempty res + assertBody Data.Monoid.mempty res case_subsite :: IO () case_subsite = runner $ do diff --git a/test/YesodCoreTest/RawResponse.hs b/test/YesodCoreTest/RawResponse.hs --- a/test/YesodCoreTest/RawResponse.hs +++ b/test/YesodCoreTest/RawResponse.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ScopedTypeVariables #-} -module YesodCoreTest.RawResponse (specs, Widget) where +module YesodCoreTest.RawResponse + ( specs + , Widget + , resourcesApp + ) where import Yesod.Core import Test.Hspec -import qualified Data.Map as Map -import Network.Wai.Test import Network.Wai (responseStream) -import Data.Text (Text) -import Data.ByteString.Lazy (ByteString) import qualified Data.Conduit.List as CL import qualified Data.ByteString.Char8 as S8 import Data.Conduit @@ -15,7 +15,7 @@ import Data.Char (toUpper) import Control.Exception (try, IOException) import Data.Conduit.Network -import Network.Socket (sClose) +import Network.Socket (close) import Control.Concurrent (threadDelay) import Control.Concurrent.Async (withAsync) import Control.Monad.Trans.Resource (register) @@ -36,7 +36,7 @@ getHomeR :: Handler () getHomeR = do - ref <- liftIO $ newIORef 0 + ref <- liftIO $ newIORef (0 :: Int) _ <- register $ writeIORef ref 1 sendRawResponse $ \src sink -> liftIO $ do val <- readIORef ref @@ -66,7 +66,7 @@ case esocket of Left (_ :: IOException) -> loop (succ port) Right socket -> do - sClose socket + close socket return port specs :: Spec diff --git a/test/YesodCoreTest/Redirect.hs b/test/YesodCoreTest/Redirect.hs --- a/test/YesodCoreTest/Redirect.hs +++ b/test/YesodCoreTest/Redirect.hs @@ -1,5 +1,9 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.Redirect (specs, Widget) where +module YesodCoreTest.Redirect + ( specs + , Widget + , resourcesY + ) where import YesodCoreTest.YesodTest import Yesod.Core.Handler (redirectWith, setEtag) diff --git a/test/YesodCoreTest/Reps.hs b/test/YesodCoreTest/Reps.hs --- a/test/YesodCoreTest/Reps.hs +++ b/test/YesodCoreTest/Reps.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies, MultiParamTypeClasses, ViewPatterns #-} -module YesodCoreTest.Reps (specs, Widget) where +module YesodCoreTest.Reps + ( specs + , Widget + , resourcesApp + ) where import Yesod.Core import Test.Hspec diff --git a/test/YesodCoreTest/RequestBodySize.hs b/test/YesodCoreTest/RequestBodySize.hs --- a/test/YesodCoreTest/RequestBodySize.hs +++ b/test/YesodCoreTest/RequestBodySize.hs @@ -1,7 +1,11 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} -module YesodCoreTest.RequestBodySize (specs, Widget) where +module YesodCoreTest.RequestBodySize + ( specs + , Widget + , resourcesY + ) where import Test.Hspec diff --git a/test/YesodCoreTest/StubLaxSameSite.hs b/test/YesodCoreTest/StubLaxSameSite.hs --- a/test/YesodCoreTest/StubLaxSameSite.hs +++ b/test/YesodCoreTest/StubLaxSameSite.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.StubLaxSameSite ( App ( App ) ) where +module YesodCoreTest.StubLaxSameSite + ( App ( App ) + , Widget + , resourcesApp + ) where import Yesod.Core import qualified Web.ClientSession as CS diff --git a/test/YesodCoreTest/StubSslOnly.hs b/test/YesodCoreTest/StubSslOnly.hs --- a/test/YesodCoreTest/StubSslOnly.hs +++ b/test/YesodCoreTest/StubSslOnly.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.StubSslOnly ( App ( App ) ) where +module YesodCoreTest.StubSslOnly + ( App ( App ) + , Widget + , resourcesApp + ) where import Yesod.Core import qualified Web.ClientSession as CS diff --git a/test/YesodCoreTest/StubStrictSameSite.hs b/test/YesodCoreTest/StubStrictSameSite.hs --- a/test/YesodCoreTest/StubStrictSameSite.hs +++ b/test/YesodCoreTest/StubStrictSameSite.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.StubStrictSameSite ( App ( App ) ) where +module YesodCoreTest.StubStrictSameSite + ( App ( App ) + , Widget + , resourcesApp + ) where import Yesod.Core import qualified Web.ClientSession as CS diff --git a/test/YesodCoreTest/StubUnsecured.hs b/test/YesodCoreTest/StubUnsecured.hs --- a/test/YesodCoreTest/StubUnsecured.hs +++ b/test/YesodCoreTest/StubUnsecured.hs @@ -1,5 +1,9 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} -module YesodCoreTest.StubUnsecured ( App ( App ) ) where +module YesodCoreTest.StubUnsecured + ( App ( App ) + , Widget + , resourcesApp + ) where import Yesod.Core diff --git a/test/YesodCoreTest/WaiSubsite.hs b/test/YesodCoreTest/WaiSubsite.hs --- a/test/YesodCoreTest/WaiSubsite.hs +++ b/test/YesodCoreTest/WaiSubsite.hs @@ -1,5 +1,9 @@ {-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-} -module YesodCoreTest.WaiSubsite (specs, Widget) where +module YesodCoreTest.WaiSubsite + ( specs + , Widget + , resourcesY + ) where import YesodCoreTest.YesodTest import Yesod.Core diff --git a/test/YesodCoreTest/Widget.hs b/test/YesodCoreTest/Widget.hs --- a/test/YesodCoreTest/Widget.hs +++ b/test/YesodCoreTest/Widget.hs @@ -1,7 +1,10 @@ {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-} -module YesodCoreTest.Widget (widgetTest) where +module YesodCoreTest.Widget + ( widgetTest + , resourcesY + ) where import Test.Hspec diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.31 +version: 1.4.32 license: MIT license-file: LICENSE author: Michael Snoyman @@ -12,7 +12,6 @@ build-type: Simple homepage: http://www.yesodweb.com/ extra-source-files: - test.hs test/YesodCoreTest.hs test/YesodCoreTest/*.hs test/YesodCoreTest/JsLoaderSites/Bottom.hs @@ -119,6 +118,15 @@ hs-source-dirs: test, . other-modules: Hierarchy + Yesod.Routes.Class + Yesod.Routes.Overlap + Yesod.Routes.Parse + Yesod.Routes.TH + Yesod.Routes.TH.Dispatch + Yesod.Routes.TH.ParseRoute + Yesod.Routes.TH.RenderRoute + Yesod.Routes.TH.RouteAttrs + Yesod.Routes.TH.Types -- Workaround for: http://ghc.haskell.org/trac/ghc/ticket/8443 extensions: TemplateHaskell @@ -137,6 +145,37 @@ type: exitcode-stdio-1.0 main-is: test.hs hs-source-dirs: test + + other-modules: YesodCoreTest + YesodCoreTest.Auth + YesodCoreTest.Cache + YesodCoreTest.CleanPath + YesodCoreTest.Csrf + YesodCoreTest.ErrorHandling + YesodCoreTest.Exceptions + YesodCoreTest.InternalRequest + YesodCoreTest.JsLoader + YesodCoreTest.JsLoaderSites.Bottom + YesodCoreTest.Json + YesodCoreTest.Links + YesodCoreTest.LiteApp + YesodCoreTest.Media + YesodCoreTest.MediaData + YesodCoreTest.NoOverloadedStrings + YesodCoreTest.NoOverloadedStringsSub + YesodCoreTest.RawResponse + YesodCoreTest.Redirect + YesodCoreTest.Reps + YesodCoreTest.RequestBodySize + YesodCoreTest.Ssl + YesodCoreTest.Streaming + YesodCoreTest.StubLaxSameSite + YesodCoreTest.StubSslOnly + YesodCoreTest.StubStrictSameSite + YesodCoreTest.StubUnsecured + YesodCoreTest.WaiSubsite + YesodCoreTest.Widget + YesodCoreTest.YesodTest cpp-options: -DTEST build-depends: base