diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index c328b031..1bad46df 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -15,24 +15,25 @@ jobs: matrix: os: [ubuntu-latest, macos-latest, windows-latest] args: - - "--resolver nightly" + #- "--resolver nightly" + - "--resolver nightly-2022-02-11" + - "--resolver lts-18" - "--resolver lts-16" - "--resolver lts-14" - "--resolver lts-12" - "--resolver lts-11" - - "--stack-yaml stack-persistent-211.yaml" - - "--stack-yaml stack-persistent-212.yaml" - - "--stack-yaml stack-persistent-213.yaml" # Bugs in GHC make it crash too often to be worth running exclude: - os: windows-latest args: "--resolver nightly" - - os: windows-latest + - os: macos-latest args: "--resolver lts-16" - - os: windows-latest - args: "--stack-yaml stack-persistent-211.yaml" - - os: windows-latest - args: "--stack-yaml stack-persistent-212.yaml" + - os: macos-latest + args: "--resolver lts-14" + - os: macos-latest + args: "--resolver lts-12" + - os: macos-latest + args: "--resolver lts-11" steps: - name: Clone project @@ -51,6 +52,5 @@ jobs: shell: bash run: | set -ex - stack upgrade stack --version stack test --fast --no-terminal ${{ matrix.args }} diff --git a/.gitignore b/.gitignore index 8f84fbea..1cb273fe 100644 --- a/.gitignore +++ b/.gitignore @@ -26,3 +26,4 @@ tarballs/ # OS X .DS_Store *.yaml.lock +dist-newstyle/ diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..a2e9ab69 --- /dev/null +++ b/cabal.project @@ -0,0 +1,15 @@ +packages: + yesod-core + yesod-static + yesod-persistent + yesod-newsfeed + yesod-form + yesod-form-multi + yesod-auth + yesod-auth-oauth + yesod-sitemap + yesod-test + yesod-bin + yesod + yesod-eventsource + yesod-websockets diff --git a/stack-persistent-211.yaml b/stack-persistent-211.yaml deleted file mode 100644 index 883223ba..00000000 --- a/stack-persistent-211.yaml +++ /dev/null @@ -1,20 +0,0 @@ -resolver: lts-16.20 -packages: -- ./yesod-core -- ./yesod-static -- ./yesod-persistent -- ./yesod-newsfeed -- ./yesod-form -- ./yesod-form-multi -- ./yesod-auth -- ./yesod-auth-oauth -- ./yesod-sitemap -- ./yesod-test -- ./yesod-bin -- ./yesod -- ./yesod-eventsource -- ./yesod-websockets -extra-deps: -- persistent-2.11.0.1@rev:0 -- persistent-template-2.9.1.0@rev:0 -- persistent-sqlite-2.11.0.0@rev:0 diff --git a/stack-persistent-212.yaml b/stack-persistent-212.yaml deleted file mode 100644 index b4087765..00000000 --- a/stack-persistent-212.yaml +++ /dev/null @@ -1,20 +0,0 @@ -resolver: nightly-2021-03-31 -packages: -- ./yesod-core -- ./yesod-static -- ./yesod-persistent -- ./yesod-newsfeed -- ./yesod-form -- ./yesod-form-multi -- ./yesod-auth -- ./yesod-auth-oauth -- ./yesod-sitemap -- ./yesod-test -- ./yesod-bin -- ./yesod -- ./yesod-eventsource -- ./yesod-websockets -extra-deps: -- persistent-2.12.0.1 -- persistent-template-2.12.0.0 -- persistent-sqlite-2.12.0.0 diff --git a/stack-persistent-213.yaml b/stack-persistent-213.yaml deleted file mode 100644 index c90d12e7..00000000 --- a/stack-persistent-213.yaml +++ /dev/null @@ -1,23 +0,0 @@ -resolver: nightly-2021-03-31 -packages: -- ./yesod-core -- ./yesod-static -- ./yesod-persistent -- ./yesod-newsfeed -- ./yesod-form -- ./yesod-form-multi -- ./yesod-auth -- ./yesod-auth-oauth -- ./yesod-sitemap -- ./yesod-test -- ./yesod-bin -- ./yesod -- ./yesod-eventsource -- ./yesod-websockets -extra-deps: -- lift-type-0.1.0.1 -- persistent-2.13.0.0 -- persistent-mysql-2.13.0.0 -- persistent-sqlite-2.13.0.0 -- persistent-postgresql-2.13.0.0 -- persistent-template-2.12.0.0 diff --git a/stack.yaml b/stack.yaml index 01942d7b..a9365a18 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,9 +2,9 @@ nix: packages: [] pure: false shell-file: ./stack.nix - add-gc-roots: true + add-gc-roots: false -resolver: lts-16.31 +resolver: lts-21.25 packages: - ./yesod-core - ./yesod-static @@ -20,3 +20,6 @@ packages: - ./yesod - ./yesod-eventsource - ./yesod-websockets + +extra-deps: +- attoparsec-aeson-2.1.0.0 diff --git a/stack.yaml.lock b/stack.yaml.lock index c2221907..9b17cd1a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,10 +3,17 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: attoparsec-aeson-2.1.0.0@sha256:fa83aba43bfa58490de8f274d19b9d58b6403a207b12cac5f93922102b084c52,1154 + pantry-tree: + sha256: 294c3a8a19a7ddad58097e18c624c6b34894b3c4a4cc490759cb31d842db242a + size: 114 + original: + hackage: attoparsec-aeson-2.1.0.0 snapshots: - completed: - size: 534126 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml - sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 - original: lts-16.31 + sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd + size: 640086 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml + original: lts-21.25 diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index 9d5d5dbb..280564e2 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,5 +1,9 @@ # ChangeLog for yesod-auth-oauth +## 1.6.1 + +* Allow newer GHC + ## 1.6.0.3 * Allow yesod-form 1.7 diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index f2ccae1b..96ea8029 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -18,7 +18,6 @@ import Control.Applicative as A ((<$>), (<*>)) import Control.Arrow ((***)) import UnliftIO.Exception import Control.Monad.IO.Class -import UnliftIO (MonadUnliftIO) import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) @@ -53,14 +52,9 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login oauthSessionName = "__oauth_token_secret" dispatch - :: ( MonadHandler m - , master ~ HandlerSite m - , Auth ~ SubHandlerSite m - , MonadUnliftIO m - ) - => Text + :: Text -> [Text] - -> m TypedContent + -> AuthHandler master TypedContent dispatch "GET" ["forward"] = do render <- getUrlRender tm <- getRouteToParent diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 4d0faa5e..3e91ff69 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.10 name: yesod-auth-oauth -version: 1.6.0.3 +version: 1.6.1 license: BSD3 license-file: LICENSE author: Hiromi Ishii @@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md library default-language: Haskell2010 - build-depends: authenticate-oauth >= 1.5 && < 1.7 + build-depends: authenticate-oauth >= 1.5 && < 1.8 , base >= 4.10 && < 5 , bytestring >= 0.9.1.4 , text >= 0.7 diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index df6b5ab2..2fd1caa7 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,5 +1,25 @@ # ChangeLog for yesod-auth +## 1.6.11.2 + +* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820) + +## 1.6.11.1 + +* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797) + +## 1.6.11 + +* Add support for aeson 2 + +## 1.6.10.5 + +* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741) + +## 1.6.10.4 + +* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737) + ## 1.6.10.3 * Relax bounds for yesod-form 1.7 diff --git a/yesod-auth/README.md b/yesod-auth/README.md index e12c2e83..0eb153ce 100644 --- a/yesod-auth/README.md +++ b/yesod-auth/README.md @@ -6,6 +6,7 @@ BrowserID (a.k.a., Mozilla Persona), and email. Other packages are available from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description. +* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0. * [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod * [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security. -* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module. +* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module. diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index dd69812f..005f66dd 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -52,7 +52,6 @@ import Control.Monad.Trans.Maybe import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes -import Data.Aeson hiding (json) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) @@ -74,6 +73,7 @@ import Control.Exception (Exception) import Network.HTTP.Types (Status, internalServerError500, unauthorized401) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad (void) +import Data.Kind (Type) type AuthRoute = Route Auth @@ -452,7 +452,7 @@ $nothing

Not logged in. |] jsonCreds creds = - Object $ Map.fromList + toJSON $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] @@ -533,7 +533,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- > AuthEntity MySite ~ User -- -- @since 1.2.0 - type AuthEntity master :: * + type AuthEntity master :: Type type AuthEntity master = KeyEntity (AuthId master) getAuthEntity :: (MonadHandler m, HandlerSite m ~ master) diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index b768b3ae..6c470f22 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Provides a dummy authentication module that simply lets a user specify -- their identifier. This is not intended for real world use, just for -- testing. This plugin supports form submissions via JSON (since 1.6.8). @@ -35,12 +36,12 @@ module Yesod.Auth.Dummy ( authDummy ) where -import Yesod.Auth -import Yesod.Form (runInputPost, textField, ireq) -import Yesod.Core -import Data.Text (Text) -import Data.Aeson.Types (Result(..), Parser) +import Data.Aeson.Types (Parser, Result (..)) import qualified Data.Aeson.Types as A (parseEither, withObject) +import Data.Text (Text) +import Yesod.Auth +import Yesod.Core +import Yesod.Form (ireq, runInputPost, textField) identParser :: Value -> Parser Text identParser = A.withObject "Ident" (.: "ident") @@ -49,6 +50,7 @@ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where + dispatch :: Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" [] = do (jsonResult :: Result Value) <- parseCheckJsonBody eIdent <- case jsonResult of diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 7a09d8c6..5eceff35 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -31,16 +31,16 @@ -- = Using JSON Endpoints -- -- We are assuming that you have declared auth route as follows --- +-- -- @ -- /auth AuthR Auth getAuth -- @ --- +-- -- If you are using a different route, then you have to adjust the -- endpoints accordingly. -- -- * Registration --- +-- -- @ -- Endpoint: \/auth\/page\/email\/register -- Method: POST @@ -49,9 +49,9 @@ -- "password": "myStrongPassword" (optional) -- } -- @ --- +-- -- * Forgot password --- +-- -- @ -- Endpoint: \/auth\/page\/email\/forgot-password -- Method: POST @@ -59,16 +59,16 @@ -- @ -- -- * Login --- +-- -- @ -- Endpoint: \/auth\/page\/email\/login -- Method: POST --- JSON Data: { +-- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" -- } -- @ --- +-- -- * Set new password -- -- @ @@ -117,28 +117,30 @@ module Yesod.Auth.Email , defaultRegisterHelper ) where -import Yesod.Auth -import qualified Yesod.Auth.Message as Msg -import Yesod.Core -import Yesod.Form -import qualified Yesod.Auth.Util.PasswordStore as PS -import Control.Applicative ((<$>), (<*>)) -import qualified Crypto.Hash as H -import qualified Crypto.Nonce as Nonce -import Data.ByteString.Base16 as B16 -import Data.Text (Text) -import qualified Data.Text as TS -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import qualified Data.Text.Encoding as TE -import Data.Text.Encoding.Error (lenientDecode) -import Data.Time (addUTCTime, getCurrentTime) -import Safe (readMay) -import System.IO.Unsafe (unsafePerformIO) +import Control.Applicative ((<$>), (<*>)) +import qualified Crypto.Hash as H +import qualified Crypto.Nonce as Nonce +import Data.Aeson.Types (Parser, Result (..), parseMaybe, + withObject, (.:?)) +import Data.ByteArray (convert) +import Data.ByteString.Base16 as B16 +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as TS +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (addUTCTime, getCurrentTime) +import Safe (readMay) +import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate -import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) -import Data.Maybe (isJust) -import Data.ByteArray (convert) +import Yesod.Auth +import qualified Yesod.Auth.Message as Msg +import qualified Yesod.Auth.Util.PasswordStore as PS +import Yesod.Core +import Yesod.Core.Types (TypedContent (TypedContent)) +import Yesod.Form loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -240,7 +242,7 @@ class ( YesodAuth site -- -- @since 1.4.20 hashAndSaltPassword :: Text -> AuthHandler site SaltedPass - hashAndSaltPassword = liftIO . saltPass + hashAndSaltPassword password = liftIO $ saltPass password -- | Verify a password matches the stored password for the given account. -- @@ -432,13 +434,14 @@ authEmail :: (YesodAuthEmail m) => AuthPlugin m authEmail = AuthPlugin "email" dispatch emailLoginHandler where + dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of - Nothing -> notFound + Nothing -> notFound Just eid' -> getVerifyR eid' verkey False >>= sendResponse dispatch "GET" ["verify", eid, verkey, hasSetPass] = case fromPathPiece eid of @@ -576,7 +579,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do _ -> do (creds :: Result Value) <- parseCheckJsonBody return $ case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parseRegister val let eidentifier = case creds of @@ -589,7 +592,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do let mpass = case (forgotPassword, creds) of (False, Just (_, mp)) -> mp - _ -> Nothing + _ -> Nothing case eidentifier of Left failMsg -> loginErrorMessageI dest failMsg @@ -620,7 +623,7 @@ defaultRegisterHelper allowUsername forgotPassword dest = do then sendConfirmationEmail creds else case emailPreviouslyRegisteredResponse identifier of Just response -> response - Nothing -> sendConfirmationEmail creds + Nothing -> sendConfirmationEmail creds where sendConfirmationEmail (lid, _, verKey, email) = do render <- getUrlRender tp <- getRouteToParent @@ -739,7 +742,7 @@ postLoginR = do _ -> do (creds :: Result Value) <- parseCheckJsonBody case creds of - Error _ -> return Nothing + Error _ -> return Nothing Success val -> return $ parseMaybe parseCreds val case midentifier of @@ -779,8 +782,8 @@ getPasswordR = do maid <- maybeAuthId case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass - Just _ -> do - needOld <- maybe (return True) needOldPassword maid + Just aid -> do + needOld <- needOldPassword aid setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. @@ -870,7 +873,7 @@ postPasswordR = do maid <- maybeAuthId (creds :: Result Value) <- parseCheckJsonBody let jcreds = case creds of - Error _ -> Nothing + Error _ -> Nothing Success val -> parseMaybe parsePassword val let doJsonParsing = isJust jcreds case maid of @@ -882,7 +885,7 @@ postPasswordR = do res <- runInputPostResult $ ireq textField "current" let fcurrent = case res of FormSuccess currentPass -> Just currentPass - _ -> Nothing + _ -> Nothing let current = if doJsonParsing then getThird jcreds else fcurrent @@ -901,9 +904,9 @@ postPasswordR = do where msgOk = Msg.PassUpdated getThird (Just (_,_,t)) = t - getThird Nothing = Nothing + getThird Nothing = Nothing getNewConfirm (Just (a,b,_)) = Just (a,b) - getNewConfirm _ = Nothing + getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do res <- runInputPostResult $ (,) <$> ireq textField "new" @@ -912,7 +915,7 @@ postPasswordR = do then getNewConfirm jcreds else case res of FormSuccess res' -> Just res' - _ -> Nothing + _ -> Nothing case creds of Nothing -> loginErrorMessageI setpassR Msg.PassMismatch Just (new, confirm) -> @@ -932,7 +935,7 @@ postPasswordR = do mr <- getMessageRender selectRep $ do - provideRep $ + provideRep $ fmap asHtml $ redirect $ afterPasswordRoute y provideJsonMessage (mr msgOk) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index ce734a40..fbe17d2c 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -53,55 +53,61 @@ module Yesod.Auth.GoogleEmail2 , pid ) where -import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), - AuthRoute, Creds (Creds), - Route (PluginR), YesodAuth, - runHttpRequest, setCredsRedirect, - logoutDest, AuthHandler) -import qualified Yesod.Auth.Message as Msg -import Yesod.Core (HandlerSite, MonadHandler, - TypedContent, getRouteToParent, - getUrlRender, invalidArgs, - liftIO, lookupGetParam, - lookupSession, notFound, redirect, - setSession, whamlet, (.:), - addMessage, getYesod, - toHtml, liftSubHandler) +import Yesod.Auth (Auth, AuthHandler, + AuthPlugin (AuthPlugin), + AuthRoute, Creds (Creds), + Route (PluginR), YesodAuth, + logoutDest, runHttpRequest, + setCredsRedirect) +import qualified Yesod.Auth.Message as Msg +import Yesod.Core (HandlerSite, MonadHandler, + TypedContent, addMessage, + getRouteToParent, getUrlRender, + getYesod, invalidArgs, liftIO, + liftSubHandler, lookupGetParam, + lookupSession, notFound, redirect, + setSession, toHtml, whamlet, (.:)) -import Blaze.ByteString.Builder (fromByteString, toByteString) -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow (second) -import Control.Monad (unless, when) -import Control.Monad.IO.Class (MonadIO) -import qualified Crypto.Nonce as Nonce -import Data.Aeson ((.:?)) -import qualified Data.Aeson as A +import Blaze.ByteString.Builder (fromByteString, toByteString) +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Monad (unless, when) +import Control.Monad.IO.Class (MonadIO) +import qualified Crypto.Nonce as Nonce +import Data.Aeson ((.:?)) +import qualified Data.Aeson as A #if MIN_VERSION_aeson(1,0,0) -import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Text as A #else -import qualified Data.Aeson.Encode as A +import qualified Data.Aeson.Encode as A #endif -import Data.Aeson.Parser (json') -import Data.Aeson.Types (FromJSON (parseJSON), parseEither, - parseMaybe, withObject, withText) +import Data.Aeson.Parser (json') +import Data.Aeson.Types (FromJSON (parseJSON), parseEither, + parseMaybe, withObject, withText) import Data.Conduit -import Data.Conduit.Attoparsec (sinkParser) -import qualified Data.HashMap.Strict as M -import Data.Maybe (fromMaybe) -import Data.Monoid (mappend) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TL -import Network.HTTP.Client (Manager, requestHeaders, - responseBody, urlEncodedBody) -import qualified Network.HTTP.Client as HTTP +import Data.Conduit.Attoparsec (sinkParser) +import Data.Maybe (fromMaybe) +import Data.Monoid (mappend) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TL +import Network.HTTP.Client (Manager, requestHeaders, + responseBody, urlEncodedBody) +import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.Conduit (Request, bodyReaderSource) -import Network.HTTP.Conduit (http) -import Network.HTTP.Types (renderQueryText) -import System.IO.Unsafe (unsafePerformIO) +import Network.HTTP.Conduit (http) +import Network.HTTP.Types (renderQueryText) +import System.IO.Unsafe (unsafePerformIO) + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key +import qualified Data.Aeson.KeyMap +#else +import qualified Data.HashMap.Strict as M +#endif -- | Plugin identifier. This is used to identify the plugin used for @@ -239,7 +245,7 @@ authPlugin storeToken clientID clientSecret = value <- makeHttpRequest req token@(Token accessToken' tokenType') <- case parseEither parseJSON value of - Left e -> error e + Left e -> error e Right t -> return t unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType' @@ -247,16 +253,18 @@ authPlugin storeToken clientID clientSecret = -- User's access token is saved for further access to API when storeToken $ setSession accessTokenKey accessToken' - personValue <- makeHttpRequest =<< personValueRequest token + personValReq <- personValueRequest token + personValue <- makeHttpRequest personValReq + person <- case parseEither parseJSON personValue of - Left e -> error e + Left e -> error e Right x -> return x email <- case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of [e] -> return e - [] -> error "No account email" - x -> error $ "Too many account emails: " ++ show x + [] -> error "No account email" + x -> error $ "Too many account emails: " ++ show x setCredsRedirect $ Creds pid email $ allPersonInfo personValue dispatch _ _ = notFound @@ -450,16 +458,16 @@ data RelationshipStatus = Single -- ^ Person is single instance FromJSON RelationshipStatus where parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of - "single" -> Single - "in_a_relationship" -> InRelationship - "engaged" -> Engaged - "married" -> Married - "its_complicated" -> Complicated - "open_relationship" -> OpenRelationship - "widowed" -> Widowed - "in_domestic_partnership" -> DomesticPartnership - "in_civil_union" -> CivilUnion - _ -> RelationshipStatus t + "single" -> Single + "in_a_relationship" -> InRelationship + "engaged" -> Engaged + "married" -> Married + "its_complicated" -> Complicated + "open_relationship" -> OpenRelationship + "widowed" -> Widowed + "in_domestic_partnership" -> DomesticPartnership + "in_civil_union" -> CivilUnion + _ -> RelationshipStatus t -------------------------------------------------------------------------------- -- | The URI of the person's profile photo. @@ -585,9 +593,19 @@ instance FromJSON EmailType where _ -> EmailType t allPersonInfo :: A.Value -> [(Text, Text)] -allPersonInfo (A.Object o) = map enc $ M.toList o - where enc (key, A.String s) = (key, s) - enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v) +allPersonInfo (A.Object o) = map enc $ mapToList o + where + enc (key, A.String s) = (keyToText key, s) + enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v) + +#if MIN_VERSION_aeson(2, 0, 0) + keyToText = Data.Aeson.Key.toText + mapToList = Data.Aeson.KeyMap.toList +#else + keyToText = id + mapToList = M.toList +#endif + allPersonInfo _ = [] diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs index 4acfac06..b700dbd4 100644 --- a/yesod-auth/Yesod/Auth/Hardcoded.hs +++ b/yesod-auth/Yesod/Auth/Hardcoded.hs @@ -131,10 +131,9 @@ module Yesod.Auth.Hardcoded , loginR ) where -import Yesod.Auth (AuthPlugin (..), AuthRoute, +import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth, - loginErrorMessageI, setCredsRedirect, - AuthHandler) + loginErrorMessageI, setCredsRedirect) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField) @@ -159,8 +158,9 @@ authHardcoded :: YesodAuthHardcoded m => AuthPlugin m authHardcoded = AuthPlugin "hardcoded" dispatch loginWidget where + dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" ["login"] = postLoginR >>= sendResponse - dispatch _ _ = notFound + dispatch _ _ = notFound loginWidget toMaster = do request <- getRequest [whamlet| diff --git a/yesod-auth/Yesod/Auth/Message.hs b/yesod-auth/Yesod/Auth/Message.hs index 9f41261a..45a75eea 100644 --- a/yesod-auth/Yesod/Auth/Message.hs +++ b/yesod-auth/Yesod/Auth/Message.hs @@ -282,13 +282,13 @@ germanMessage NoOpenID = "Kein OpenID-Identifier gefunden" germanMessage LoginOpenID = "Login via OpenID" germanMessage LoginGoogle = "Login via Google" germanMessage LoginYahoo = "Login via Yahoo" -germanMessage Email = "Email" -germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name" +germanMessage Email = "E-Mail" +germanMessage UserName = "Benutzername" germanMessage Password = "Passwort" germanMessage CurrentPassword = "Aktuelles Passwort" germanMessage Register = "Registrieren" germanMessage RegisterLong = "Neuen Account registrieren" -germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." +germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt." germanMessage (ConfirmationEmailSent email) = "Eine Bestätigung wurde an " `mappend` @@ -308,24 +308,23 @@ germanMessage ConfirmPass = "Bestätigen" germanMessage PassMismatch = "Die Passwörter stimmen nicht überein" germanMessage PassUpdated = "Passwort überschrieben" germanMessage Facebook = "Login über Facebook" -germanMessage LoginViaEmail = "Login via e-Mail" +germanMessage LoginViaEmail = "Login via E-Mail" germanMessage InvalidLogin = "Ungültiger Login" germanMessage NowLoggedIn = "Login erfolgreich" -germanMessage LoginTitle = "Log In" +germanMessage LoginTitle = "Anmelden" germanMessage PleaseProvideUsername = "Bitte Nutzername angeben" germanMessage PleaseProvidePassword = "Bitte Passwort angeben" -germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben" -germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter" +germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben" +germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter" germanMessage PasswordResetTitle = "Passwort zurücksetzen" -germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername" -germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen" -germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann." +germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername" +germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen" +germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann." germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort" --- TODO -germanMessage i@(IdentifierNotFound _) = englishMessage i -germanMessage Logout = "Ausloggen" -- FIXME by Google Translate -germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate -germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate +germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO +germanMessage Logout = "Abmelden" +germanMessage LogoutTitle = "Abmelden" +germanMessage AuthError = "Fehler beim Anmelden" frenchMessage :: AuthMessage -> Text frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé" diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 18d30a8c..55b55e99 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: yesod-auth -version: 1.6.10.3 +version: 1.6.11.2 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -23,6 +23,7 @@ library default-language: Haskell2010 build-depends: base >= 4.10 && < 5 , aeson >= 0.7 + , attoparsec-aeson >= 2.1 , authenticate >= 1.3.4 , base16-bytestring , base64-bytestring diff --git a/yesod-bin/AddHandler.hs b/yesod-bin/AddHandler.hs index 52d57cdd..21519b6f 100644 --- a/yesod-bin/AddHandler.hs +++ b/yesod-bin/AddHandler.hs @@ -9,13 +9,18 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T import qualified Data.Text.IO as TIO -#if MIN_VERSION_Cabal(2, 2, 0) +#if MIN_VERSION_Cabal(3, 7, 0) +import Distribution.Simple.PackageDescription (readGenericPackageDescription) +#elif MIN_VERSION_Cabal(2, 2, 0) import Distribution.PackageDescription.Parsec (readGenericPackageDescription) #elif MIN_VERSION_Cabal(2, 0, 0) import Distribution.PackageDescription.Parse (readGenericPackageDescription) #else import Distribution.PackageDescription.Parse (readPackageDescription) #endif +#if MIN_VERSION_Cabal(3, 6, 0) +import Distribution.Utils.Path +#endif import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) import Distribution.Verbosity (normal) @@ -247,4 +252,8 @@ getSrcDir cabal = do #endif let buildInfo = allBuildInfo pd srcDirs = concatMap hsSourceDirs buildInfo +#if MIN_VERSION_Cabal(3, 6, 0) + return $ maybe "." getSymbolicPath $ listToMaybe srcDirs +#else return $ fromMaybe "." $ listToMaybe srcDirs +#endif diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index a7780c0a..106debb4 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,5 +1,17 @@ # ChangeLog for yesod-bin +## 1.6.2.2 + +* Support Cabal 3.8 [#1769](https://github.com/yesodweb/yesod/pull/1769) + +## 1.6.2.1 + +* Support Cabal 3.6 [#1754](https://github.com/yesodweb/yesod/pull/1754) + +## 1.6.2 + +* aeson 2.0 + ## 1.6.1 Added command line options `cert` and `key` to allow TLS certificate and key files to be passed to `yesod devel` [#1717](https://github.com/yesodweb/yesod/pull/1717) diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index 658119be..a871463a 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -28,6 +28,9 @@ import Data.String (fromString) import Data.Time (getCurrentTime) import qualified Distribution.Package as D import qualified Distribution.PackageDescription as D +#if MIN_VERSION_Cabal(3,8,0) +import qualified Distribution.Simple.PackageDescription as D +#endif #if MIN_VERSION_Cabal(2, 2, 0) import qualified Distribution.PackageDescription.Parsec as D #else @@ -136,7 +139,7 @@ reverseProxy :: DevelOpts -> TVar Int -> IO () reverseProxy opts appPortVar = do manager <- newManager $ managerSetProxy noProxy tlsManagerSettings let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")] - sayV = when (verbose opts) . sayString + sayV = when (verbose opts) . sayString let onExc _ req | maybe False (("application/json" `elem`) . parseHttpAccept) (lookup "accept" $ requestHeaders req) = diff --git a/yesod-bin/Keter.hs b/yesod-bin/Keter.hs index 07810ea8..94024e18 100644 --- a/yesod-bin/Keter.hs +++ b/yesod-bin/Keter.hs @@ -1,10 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Keter ( keter ) where import Data.Yaml + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.KeyMap as Map +#else import qualified Data.HashMap.Strict as Map +#endif import qualified Data.Text as T import System.Environment (getEnvironment) import System.Exit diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 20da5ef8..e54ed29c 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.6.1 +version: 1.6.2.2 license: MIT license-file: LICENSE author: Michael Snoyman @@ -35,7 +35,7 @@ executable yesod , directory >= 1.2.1 , file-embed , filepath >= 1.1 - , fsnotify >= 0.0 && < 0.4 + , fsnotify , http-client >= 0.4.7 , http-client-tls , http-reverse-proxy >= 0.4 @@ -61,6 +61,7 @@ executable yesod , warp-tls >= 3.0.1 , yaml >= 0.8 && < 0.12 , zlib >= 0.5 + , aeson ghc-options: -Wall -threaded -rtsopts main-is: main.hs diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 7fb76193..a6b2beb7 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,5 +1,64 @@ # ChangeLog for yesod-core +## 1.6.25.1 + +* Export the options that were created in 1.6.25.0 [#1825](https://github.com/yesodweb/yesod/pull/1825) + +## 1.6.25.0 + +* Add an options structure that allows the user to set which instances will be derived for a routes structure. [#1819](https://github.com/yesodweb/yesod/pull/1819) + +## 1.6.24.5 + +* Support Aeson 2.2 [#1818](https://github.com/yesodweb/yesod/pull/1818) + +## 1.6.24.4 + +* Fix test-suite compilation error for GHC >= 9.0.1 [#1812](https://github.com/yesodweb/yesod/pull/1812) + +## 1.6.24.3 + +* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805) + +## 1.6.24.2 + +* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797) + +## 1.6.24.1 + +* Adapt to removal of `ListT` from transformers-0.6. [#1796](https://github.com/yesodweb/yesod/pull/1796) + +## 1.6.24.0 + +* Make catching exceptions configurable and set the default back to rethrowing async exceptions. [#1772](https://github.com/yesodweb/yesod/pull/1772). + +## 1.6.23.1 + +* Fix typo in creation of the description `` tag in `defaultLayout`. [#1766](https://github.com/yesodweb/yesod/pull/1766) + +## 1.6.23 + +* Add idempotent versions of `setDescription`, `setDescriptionI`. These functions + have odd behaviour when called multiple times, so they are now warned against. + This can't be a silent change - if you want to switch to the new functions, make + sure your layouts are updated to use `pageDescription` as well as `pageTitle`. + [#1765](https://github.com/yesodweb/yesod/pull/1765) + +## 1.6.22.1 + ++ Remove sometimes failing superfluous test. [#1756](https://github.com/yesodweb/yesod/pull/1756) + +## 1.6.22.0 + +* Add missing list to documentation for ``Yesod.Core.Dispatch.warp``. [#1745](https://github.com/yesodweb/yesod/pull/1745) +* Add instances for `ToContent Void`, `ToTypedContent Void`. [#1752](https://github.com/yesodweb/yesod/pull/1752) +* Handle async exceptions within yesod rather then warp. [#1753](https://github.com/yesodweb/yesod/pull/1753) +* Support template-haskell 2.18 [#1754](https://github.com/yesodweb/yesod/pull/1754) + +## 1.6.21.0 + +* Export `Yesod.Core.Dispatch.defaultGen` so that users may reuse it for their own `YesodRunnerEnv`s [#1734](https://github.com/yesodweb/yesod/pull/1734) + ## 1.6.20.2 * Fix compatibility with template-haskell 2.17 [#1729](https://github.com/yesodweb/yesod/pull/1729) diff --git a/yesod-core/src/Yesod/Core/Class/Handler.hs b/yesod-core/src/Yesod/Core/Class/Handler.hs index 8d8ca448..d166a129 100644 --- a/yesod-core/src/Yesod/Core/Class/Handler.hs +++ b/yesod-core/src/Yesod/Core/Class/Handler.hs @@ -19,7 +19,9 @@ import Control.Monad.Trans.Class (lift) import Data.Conduit.Internal (Pipe, ConduitM) import Control.Monad.Trans.Identity ( IdentityT) +#if !MIN_VERSION_transformers(0,6,0) import Control.Monad.Trans.List ( ListT ) +#endif import Control.Monad.Trans.Maybe ( MaybeT ) import Control.Monad.Trans.Except ( ExceptT ) import Control.Monad.Trans.Reader ( ReaderT ) @@ -76,7 +78,9 @@ instance MonadHandler (WidgetFor site) where #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; type SubHandlerSite (T m) = SubHandlerSite m; liftHandler = lift . liftHandler; liftSubHandler = lift . liftSubHandler GO(IdentityT) +#if !MIN_VERSION_transformers(0,6,0) GO(ListT) +#endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r) @@ -104,7 +108,9 @@ liftWidgetT = liftWidget #define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget #define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget GO(IdentityT) +#if !MIN_VERSION_transformers(0,6,0) GO(ListT) +#endif GO(MaybeT) GO(ExceptT e) GO(ReaderT r) diff --git a/yesod-core/src/Yesod/Core/Class/Yesod.hs b/yesod-core/src/Yesod/Core/Class/Yesod.hs index 2a2c1b04..a5845126 100644 --- a/yesod-core/src/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/src/Yesod/Core/Class/Yesod.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Yesod.Core.Class.Yesod where import Yesod.Core.Content @@ -52,8 +54,10 @@ import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget import Data.CaseInsensitive (CI) +import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Request import Data.IORef +import UnliftIO (SomeException, catch, MonadUnliftIO) -- | Define settings for a Yesod applications. All methods have intelligent -- defaults, and therefore no implementation is required. @@ -70,6 +74,16 @@ class RenderRoute site => Yesod site where approot :: Approot site approot = guessApproot + -- | @since 1.6.24.0 + -- allows the user to specify how exceptions are cought. + -- by default all async exceptions are thrown and synchronous + -- exceptions render a 500 page. + -- To catch all exceptions (even async) to render a 500 page, + -- set this to 'UnliftIO.Exception.catchSyncOrAsync'. Beware + -- this may have negative effects with functions like 'timeout'. + catchHandlerExceptions :: MonadUnliftIO m => site -> m a -> (SomeException -> m a) -> m a + catchHandlerExceptions _ = catch + -- | Output error response pages. -- -- Default value: 'defaultErrorHandler'. @@ -87,6 +101,8 @@ class RenderRoute site => Yesod site where #{pageTitle p} + $maybe description <- pageDescription p + <meta name="description" content="#{description}"> ^{pageHead p} <body> $forall (status, msg) <- msgs @@ -539,8 +555,9 @@ widgetToPageContent w = do { wdRef = ref , wdHandler = hd } - GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref + GWData (Body body) (Last mTitle) (Last mDescription) scripts' stylesheets' style jscript (Head head') <- readIORef ref let title = maybe mempty unTitle mTitle + description = unDescription <$> mDescription scripts = runUniqueList scripts' stylesheets = runUniqueList stylesheets' @@ -610,7 +627,7 @@ widgetToPageContent w = do ^{regularScriptLoad} |] - return $ PageContent title headAll $ + return $ PageContent title description headAll $ case jsLoader master of BottomOfBody -> bodyScript _ -> body diff --git a/yesod-core/src/Yesod/Core/Content.hs b/yesod-core/src/Yesod/Core/Content.hs index d9741d92..bcb1ff1b 100644 --- a/yesod-core/src/Yesod/Core/Content.hs +++ b/yesod-core/src/Yesod/Core/Content.hs @@ -64,6 +64,7 @@ import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J import Data.Text.Lazy.Builder (toLazyText) +import Data.Void (Void, absurd) import Yesod.Core.Types import Text.Lucius (Css, renderCss) import Text.Julius (Javascript, unJavascript) @@ -103,6 +104,8 @@ instance ToContent Html where toContent bs = ContentBuilder (renderHtmlBuilder bs) Nothing instance ToContent () where toContent () = toContent B.empty +instance ToContent Void where + toContent = absurd instance ToContent (ContentType, Content) where toContent = snd instance ToContent TypedContent where @@ -276,6 +279,8 @@ instance ToTypedContent TypedContent where toTypedContent = id instance ToTypedContent () where toTypedContent () = TypedContent typePlain (toContent ()) +instance ToTypedContent Void where + toTypedContent = absurd instance ToTypedContent (ContentType, Content) where toTypedContent (ct, content) = TypedContent ct content instance ToTypedContent RepJson where diff --git a/yesod-core/src/Yesod/Core/Dispatch.hs b/yesod-core/src/Yesod/Core/Dispatch.hs index 8a2501e6..bde5bca9 100644 --- a/yesod-core/src/Yesod/Core/Dispatch.hs +++ b/yesod-core/src/Yesod/Core/Dispatch.hs @@ -10,13 +10,24 @@ module Yesod.Core.Dispatch , parseRoutesFile , parseRoutesFileNoCheck , mkYesod + , mkYesodOpts , mkYesodWith -- ** More fine-grained , mkYesodData + , mkYesodDataOpts , mkYesodSubData + , mkYesodSubDataOpts , mkYesodDispatch + , mkYesodDispatchOpts , mkYesodSubDispatch + -- *** Route generation options + , RouteOpts + , defaultOpts + , setEqDerived + , setShowDerived + , setReadDerived -- *** Helpers + , defaultGen , getGetMaxExpires -- ** Path pieces , PathPiece (..) @@ -100,6 +111,8 @@ toWaiAppPlain site = do -- unspecified range. The range size may not be a power of 2. Since -- 1.6.20, this uses a secure entropy source and generates in the full -- range of 'Int'. +-- +-- @since 1.6.21.0 defaultGen :: IO Int defaultGen = bsToInt <$> getEntropy bytes where @@ -184,6 +197,16 @@ toWaiAppLogger logger site = do -- middlewares. This set may change at any point without a breaking version -- number. Currently, it includes: -- +-- * Logging +-- +-- * GZIP compression +-- +-- * Automatic HEAD method handling +-- +-- * Request method override with the _method query string parameter +-- +-- * Accept header override with the _accept query string parameter +-- -- If you need more fine-grained control of middlewares, please use 'toWaiApp' -- directly. -- diff --git a/yesod-core/src/Yesod/Core/Handler.hs b/yesod-core/src/Yesod/Core/Handler.hs index 191cf5fd..5d329c13 100644 --- a/yesod-core/src/Yesod/Core/Handler.hs +++ b/yesod-core/src/Yesod/Core/Handler.hs @@ -245,6 +245,7 @@ import Text.Blaze.Html (preEscapedToHtml, toHtml) import qualified Data.IORef as I import Data.Maybe (listToMaybe, mapMaybe) import Data.Typeable (Typeable) +import Data.Kind (Type) import Web.PathPieces (PathPiece(..)) import Yesod.Core.Class.Handler import Yesod.Core.Types @@ -261,7 +262,7 @@ import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold import Control.Monad.Logger (MonadLogger, logWarnS) -type HandlerT site (m :: * -> *) = HandlerFor site +type HandlerT site (m :: Type -> Type) = HandlerFor site {-# DEPRECATED HandlerT "Use HandlerFor directly" #-} get :: MonadHandler m => m GHState diff --git a/yesod-core/src/Yesod/Core/Internal/Run.hs b/yesod-core/src/Yesod/Core/Internal/Run.hs index 9cb7044f..c97f28c1 100644 --- a/yesod-core/src/Yesod/Core/Internal/Run.hs +++ b/yesod-core/src/Yesod/Core/Internal/Run.hs @@ -1,13 +1,28 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -module Yesod.Core.Internal.Run where - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Yesod.Core.Internal.Run + ( toErrorHandler + , errFromShow + , basicRunHandler + , handleError + , handleContents + , evalFallback + , runHandler + , safeEh + , runFakeHandler + , yesodRunner + , yesodRender + , resolveApproot + ) + where +import qualified Control.Exception as EUnsafe import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BL @@ -39,6 +54,8 @@ import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) import UnliftIO.Exception +import UnliftIO(MonadUnliftIO, withRunInIO) +import Data.Proxy(Proxy(..)) -- | Convert a synchronous exception into an ErrorResponse toErrorHandler :: SomeException -> IO ErrorResponse @@ -71,7 +88,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- catchAny + contents' <- rheCatchHandlerExceptions rhe (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -172,11 +189,14 @@ handleContents handleError' finalSession headers contents = -- | Evaluate the given value. If an exception is thrown, use it to -- replace the provided contents and then return @mempty@ in place of the -- evaluated value. +-- +-- Note that this also catches async exceptions. evalFallback :: (Monoid w, NFData w) - => HandlerContents + => (forall a. IO a -> (SomeException -> IO a) -> IO a) + -> HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = catchAny +evalFallback catcher contents val = catcher (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) @@ -192,8 +212,8 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - -- Evaluate the unfortunately-lazy session and headers, -- propagating exceptions into the contents - (finalSession, contents1) <- evalFallback contents0 (ghsSession state) - (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) + (finalSession, contents1) <- evalFallback rheCatchHandlerExceptions contents0 (ghsSession state) + (headers, contents2) <- evalFallback rheCatchHandlerExceptions contents1 (appEndo (ghsHeaders state) []) contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse @@ -236,7 +256,7 @@ safeEh log' er req = do -- @HandlerFor@ is completely ignored, including changes to the -- session, cookies or headers. We only return you the -- @HandlerFor@'s return value. -runFakeHandler :: (Yesod site, MonadIO m) => +runFakeHandler :: forall site m a . (Yesod site, MonadIO m) => SessionMap -> (site -> Logger) -> site @@ -257,6 +277,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do , rheLog = messageLoggerSource site $ logger site , rheOnError = errHandler , rheMaxExpires = maxExpires + , rheCatchHandlerExceptions = catchHandlerExceptions site } handler' errHandler err req = do @@ -298,7 +319,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do _ <- runResourceT $ yapp fakeRequest I.readIORef ret -yesodRunner :: (ToTypedContent res, Yesod site) +yesodRunner :: forall res site . (ToTypedContent res, Yesod site) => HandlerFor site res -> YesodRunnerEnv site -> Maybe (Route site) @@ -333,6 +354,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req sendResponse = do , rheLog = log' , rheOnError = safeEh log' , rheMaxExpires = maxExpires + , rheCatchHandlerExceptions = catchHandlerExceptions yreSite } rhe = rheSafe { rheOnError = runHandler rheSafe . errorHandler diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs index 11bbf90b..29b40d5d 100644 --- a/yesod-core/src/Yesod/Core/Internal/TH.hs +++ b/yesod-core/src/Yesod/Core/Internal/TH.hs @@ -1,10 +1,48 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} -module Yesod.Core.Internal.TH where +{-# LANGUAGE RankNTypes #-} +module Yesod.Core.Internal.TH + ( mkYesod + , mkYesodOpts + + , mkYesodWith + + , mkYesodData + , mkYesodDataOpts + + , mkYesodSubData + , mkYesodSubDataOpts + + , mkYesodWithParser + , mkYesodWithParserOpts + + , mkYesodDispatch + , mkYesodDispatchOpts + + , masterTypeSyns + + , mkYesodGeneral + , mkYesodGeneralOpts + + , mkMDS + , mkDispatchInstance + + , mkYesodSubDispatch + + , subTopDispatch + , instanceD + + , RouteOpts + , defaultOpts + , setEqDerived + , setShowDerived + , setReadDerived + ) + where import Prelude hiding (exp) import Yesod.Core.Handler @@ -22,6 +60,7 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char) import Yesod.Routes.TH import Yesod.Routes.Parse +import Yesod.Core.Content (ToTypedContent (..)) import Yesod.Core.Types import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run @@ -35,7 +74,17 @@ import Yesod.Core.Internal.Run mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodWithParser name False return +mkYesod = mkYesodOpts defaultOpts + +-- | `mkYesod` but with custom options. +-- +-- @since 1.6.25.0 +mkYesodOpts :: RouteOpts + -> String + -> [ResourceTree String] + -> Q [Dec] +mkYesodOpts opts name = fmap (uncurry (++)) . mkYesodWithParserOpts opts name False return + {-# DEPRECATED mkYesodWith "Contexts and type variables are now parsed from the name in `mkYesod`. <https://github.com/yesodweb/yesod/pull/1366>" #-} -- | Similar to 'mkYesod', except contexts and type variables are not parsed. @@ -48,15 +97,30 @@ mkYesodWith :: [[String]] -- ^ list of contexts -> Q [Dec] mkYesodWith cxts name args = fmap (uncurry (++)) . mkYesodGeneral cxts name args False return + -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a -- monolithic file into smaller parts. Use this function, paired with -- 'mkYesodDispatch', to do just that. mkYesodData :: String -> [ResourceTree String] -> Q [Dec] -mkYesodData name resS = fst <$> mkYesodWithParser name False return resS +mkYesodData = mkYesodDataOpts defaultOpts + +-- | `mkYesodData` but with custom options. +-- +-- @since 1.6.25.0 +mkYesodDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec] +mkYesodDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name False return resS + mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] -mkYesodSubData name resS = fst <$> mkYesodWithParser name True return resS +mkYesodSubData = mkYesodSubDataOpts defaultOpts + +-- | +-- +-- @since 1.6.25.0 +mkYesodSubDataOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec] +mkYesodSubDataOpts opts name resS = fst <$> mkYesodWithParserOpts opts name True return resS + -- | Parses contexts and type arguments out of name before generating TH. mkYesodWithParser :: String -- ^ foundation type @@ -64,11 +128,22 @@ mkYesodWithParser :: String -- ^ foundation type -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) -mkYesodWithParser name isSub f resS = do +mkYesodWithParser = mkYesodWithParserOpts defaultOpts + +-- | Parses contexts and type arguments out of name before generating TH. +-- +-- @since 1.6.25.0 +mkYesodWithParserOpts :: RouteOpts -- ^ Additional route options + -> String -- ^ foundation type + -> Bool -- ^ is this a subsite + -> (Exp -> Q Exp) -- ^ unwrap handler + -> [ResourceTree String] + -> Q([Dec],[Dec]) +mkYesodWithParserOpts opts name isSub f resS = do let (name', rest, cxt) = case parse parseName "" name of Left err -> error $ show err Right a -> a - mkYesodGeneral cxt name' rest isSub f resS + mkYesodGeneralOpts opts cxt name' rest isSub f resS where parseName = do @@ -100,9 +175,17 @@ mkYesodWithParser name isSub f resS = do parseContexts = sepBy1 (many1 parseWord) (spaces >> char ',' >> return ()) + -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodWithParser name False return +mkYesodDispatch = mkYesodDispatchOpts defaultOpts + +-- | See 'mkYesodDataOpts' +-- +-- @since 1.6.25.0 +mkYesodDispatchOpts :: RouteOpts -> String -> [ResourceTree String] -> Q [Dec] +mkYesodDispatchOpts opts name = fmap snd . mkYesodWithParserOpts opts name False return + -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself? @@ -113,6 +196,7 @@ masterTypeSyns vs site = $ ConT ''WidgetFor `AppT` site `AppT` ConT ''() ] + mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. -> String -- ^ foundation type -> [String] -- ^ arguments for the type @@ -120,7 +204,20 @@ mkYesodGeneral :: [[String]] -- ^ Appliction context. Used in Ren -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) -mkYesodGeneral appCxt' namestr mtys isSub f resS = do +mkYesodGeneral = mkYesodGeneralOpts defaultOpts + +-- | +-- +-- @since 1.6.25.0 +mkYesodGeneralOpts :: RouteOpts -- ^ Options to adjust route creation + -> [[String]] -- ^ Appliction context. Used in RenderRoute, RouteAttrs, and ParseRoute instances. + -> String -- ^ foundation type + -> [String] -- ^ arguments for the type + -> Bool -- ^ is this a subsite + -> (Exp -> Q Exp) -- ^ unwrap handler + -> [ResourceTree String] + -> Q([Dec],[Dec]) +mkYesodGeneralOpts opts appCxt' namestr mtys isSub f resS = do let appCxt = fmap (\(c:rest) -> foldl' (\acc v -> acc `AppT` nameToType v) (ConT $ mkName c) rest ) appCxt' @@ -148,7 +245,7 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do -- Base type (site type with variables) let site = foldl' AppT (ConT name) argtypes res = map (fmap (parseType . dropBracket)) resS - renderRouteDec <- mkRenderRouteInstance appCxt site res + renderRouteDec <- mkRenderRouteInstanceOpts opts appCxt site res routeAttrsDec <- mkRouteAttrsInstance appCxt site res dispatchDec <- mkDispatchInstance site appCxt f res parseRoute <- mkParseRouteInstance appCxt site res @@ -167,18 +264,11 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do ] return (dataDec, dispatchDec) -mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b -mkMDS f rh = MkDispatchSettings + +mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b +mkMDS f rh sd = MkDispatchSettings { mdsRunHandler = rh - , mdsSubDispatcher = - [|\parentRunner getSub toParent env -> yesodSubDispatch - YesodSubRunnerEnv - { ysreParentRunner = parentRunner - , ysreGetSub = getSub - , ysreToParentRoute = toParent - , ysreParentEnv = env - } - |] + , mdsSubDispatcher = sd , mdsGetPathInfo = [|W.pathInfo|] , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|] , mdsMethod = [|W.requestMethod|] @@ -199,15 +289,35 @@ mkDispatchInstance :: Type -- ^ The master site type -> [ResourceTree c] -- ^ The resource -> DecsQ mkDispatchInstance master cxt f res = do - clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res + clause' <- + mkDispatchClause + (mkMDS + f + [|yesodRunner|] + [|\parentRunner getSub toParent env -> yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = parentRunner + , ysreGetSub = getSub + , ysreToParentRoute = toParent + , ysreParentEnv = env + } + |]) + res let thisDispatch = FunD 'yesodDispatch [clause'] return [instanceD cxt yDispatch [thisDispatch]] where yDispatch = ConT ''YesodDispatch `AppT` master + mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do - clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res + clause' <- + mkDispatchClause + (mkMDS + return + [|subHelper|] + [|subTopDispatch|]) + res inner <- newName "inner" let innerFun = FunD inner [clause'] helper <- newName "helper" @@ -219,5 +329,26 @@ mkYesodSubDispatch res = do ] return $ LetE [fun] (VarE helper) + +subTopDispatch :: + (YesodSubDispatch sub master) => + (forall content. ToTypedContent content => + SubHandlerFor child master content -> + YesodSubRunnerEnv child master -> + Maybe (Route child) -> + W.Application + ) -> + (mid -> sub) -> + (Route sub -> Route mid) -> + YesodSubRunnerEnv mid master -> + W.Application +subTopDispatch _ getSub toParent env = yesodSubDispatch + (YesodSubRunnerEnv + { ysreParentRunner = ysreParentRunner env + , ysreGetSub = getSub . ysreGetSub env + , ysreToParentRoute = ysreToParentRoute env . toParent + , ysreParentEnv = ysreParentEnv env + }) + instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing diff --git a/yesod-core/src/Yesod/Core/Types.hs b/yesod-core/src/Yesod/Core/Types.hs index 11a55f1a..88f01e35 100644 --- a/yesod-core/src/Yesod/Core/Types.hs +++ b/yesod-core/src/Yesod/Core/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} module Yesod.Core.Types where import Data.Aeson (ToJSON) @@ -55,7 +56,7 @@ import Control.Monad.Reader (MonadReader (..)) import Control.DeepSeq (NFData (rnf)) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) -import UnliftIO (MonadUnliftIO (..)) +import UnliftIO (MonadUnliftIO (..), SomeException) -- Sessions type SessionMap = Map Text ByteString @@ -182,6 +183,11 @@ data RunHandlerEnv child site = RunHandlerEnv -- -- Since 1.2.0 , rheMaxExpires :: !Text + + -- | @since 1.6.24.0 + -- catch function for rendering 500 pages on exceptions. + -- by default this is catch from unliftio (rethrows all async exceptions). + , rheCatchHandlerExceptions :: !(forall a m . MonadUnliftIO m => m a -> (SomeException -> m a) -> m a) } data HandlerData child site = HandlerData @@ -289,9 +295,10 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent - { pageTitle :: !Html - , pageHead :: !(HtmlUrl url) - , pageBody :: !(HtmlUrl url) + { pageTitle :: !Html + , pageDescription :: !(Maybe Text) + , pageHead :: !(HtmlUrl url) + , pageBody :: !(HtmlUrl url) } data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. @@ -387,6 +394,7 @@ data Script url = Script { scriptLocation :: !(Location url), scriptAttributes : data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } +newtype Description = Description { unDescription :: Text } newtype Head url = Head (HtmlUrl url) deriving Monoid @@ -402,6 +410,7 @@ type CssBuilderUrl a = (a -> [(Text, Text)] -> Text) -> TBuilder.Builder data GWData a = GWData { gwdBody :: !(Body a) , gwdTitle :: !(Last Title) + , gwdDescription :: !(Last Description) , gwdScripts :: !(UniqueList (Script a)) , gwdStylesheets :: !(UniqueList (Stylesheet a)) , gwdCss :: !(Map (Maybe Text) (CssBuilderUrl a)) -- media type @@ -409,20 +418,21 @@ data GWData a = GWData , gwdHead :: !(Head a) } instance Monoid (GWData a) where - mempty = GWData mempty mempty mempty mempty mempty mempty mempty + mempty = GWData mempty mempty mempty mempty mempty mempty mempty mempty #if !(MIN_VERSION_base(4,11,0)) mappend = (<>) #endif instance Semigroup (GWData a) where - GWData a1 a2 a3 a4 a5 a6 a7 <> - GWData b1 b2 b3 b4 b5 b6 b7 = GWData + GWData a1 a2 a3 a4 a5 a6 a7 a8 <> + GWData b1 b2 b3 b4 b5 b6 b7 b8 = GWData (mappend a1 b1) (mappend a2 b2) (mappend a3 b3) (mappend a4 b4) - (unionWith mappend a5 b5) - (mappend a6 b6) + (mappend a5 b5) + (unionWith mappend a6 b6) (mappend a7 b7) + (mappend a8 b8) data HandlerContents = HCContent !H.Status !TypedContent diff --git a/yesod-core/src/Yesod/Core/Widget.hs b/yesod-core/src/Yesod/Core/Widget.hs index 20569790..f20a9983 100644 --- a/yesod-core/src/Yesod/Core/Widget.hs +++ b/yesod-core/src/Yesod/Core/Widget.hs @@ -33,6 +33,8 @@ module Yesod.Core.Widget , setTitleI , setDescription , setDescriptionI + , setDescriptionIdemp + , setDescriptionIdempI , setOGType , setOGImage -- ** CSS @@ -64,6 +66,7 @@ import Yesod.Routes.Class import Yesod.Core.Handler (getMessageRender, getUrlRenderParams) import Text.Shakespeare.I18N (RenderMessage) import Data.Text (Text) +import Data.Kind (Type) import qualified Data.Map as Map import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax (Q, Exp (InfixE, VarE, LamE, AppE), Pat (VarP), newName) @@ -77,7 +80,7 @@ import qualified Data.Text.Lazy.Builder as TB import Yesod.Core.Types import Yesod.Core.Class.Handler -type WidgetT site (m :: * -> *) = WidgetFor site +type WidgetT site (m :: Type -> Type) = WidgetFor site {-# DEPRECATED WidgetT "Use WidgetFor directly" #-} preEscapedLazyText :: TL.Text -> Html @@ -87,19 +90,19 @@ class ToWidget site a where toWidget :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidget site (render -> Html) where - toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty + toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty mempty instance render ~ RY site => ToWidget site (render -> Css) where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x instance ToWidget site Css where toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidget site (render -> CssBuilder) where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty instance ToWidget site CssBuilder where - toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . const x) mempty mempty instance render ~ RY site => ToWidget site (render -> Javascript) where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just x) mempty instance ToWidget site Javascript where - toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty + toWidget x = tell $ GWData mempty mempty mempty mempty mempty mempty (Just $ const x) mempty instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where toWidget = liftWidget instance ToWidget site Html where @@ -130,9 +133,9 @@ instance render ~ RY site => ToWidgetMedia site (render -> Css) where instance ToWidgetMedia site Css where toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . const x instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty instance ToWidgetMedia site CssBuilder where - toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty + toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . const x) mempty mempty class ToWidgetBody site a where toWidgetBody :: (MonadWidget m, HandlerSite m ~ site) => a -> m () @@ -150,7 +153,7 @@ class ToWidgetHead site a where toWidgetHead :: (MonadWidget m, HandlerSite m ~ site) => a -> m () instance render ~ RY site => ToWidgetHead site (render -> Html) where - toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head + toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty mempty . Head instance render ~ RY site => ToWidgetHead site (render -> Css) where toWidgetHead = toWidget instance ToWidgetHead site Css where @@ -181,7 +184,7 @@ instance ToWidgetHead site Html where -- * Google typically shows 55-64 characters, so aim to keep your title -- length under 60 characters setTitle :: MonadWidget m => Html -> m () -setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty +setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty mempty -- | Set the localised page title. -- @@ -208,6 +211,14 @@ setDescription :: MonadWidget m => Text -> m () setDescription description = toWidgetHead $ [hamlet|<meta name=description content=#{description}>|] +{-# WARNING setDescription + [ "setDescription is not idempotent; we recommend setDescriptionIdemp instead" + , "Multiple calls to setDescription will insert multiple meta tags in the page head." + , "If you want an idempotent function, use setDescriptionIdemp - but if you do, you \ + \may need to change your layout to include pageDescription." + ] +#-} + -- | Add translated description meta tag to the head of the page -- -- n.b. See comments for @setDescription@. @@ -220,6 +231,48 @@ setDescriptionI msg = do mr <- getMessageRender toWidgetHead $ [hamlet|<meta name=description content=#{mr msg}>|] +{-# WARNING setDescriptionI + [ "setDescriptionI is not idempotent; we recommend setDescriptionIdempI instead" + , "Multiple calls to setDescriptionI will insert multiple meta tags in the page head." + , "If you want an idempotent function, use setDescriptionIdempI - but if you do, you \ + \may need to change your layout to include pageDescription." + ] +#-} + +-- | Add description meta tag to the head of the page +-- +-- Google does not use the description tag as a ranking signal, but the +-- contents of this tag will likely affect your click-through rate since it +-- shows up in search results. +-- +-- The average length of the description shown in Google's search results is +-- about 160 characters on desktop, and about 130 characters on mobile, at time +-- of writing. +-- +-- Unlike 'setDescription', this version is *idempotent* - calling it multiple +-- times will result in only a single description meta tag in the head. +-- +-- Source: https://www.advancedwebranking.com/blog/meta-tags-important-in-seo/ +-- +-- @since 1.6.23 +setDescriptionIdemp :: MonadWidget m => Text -> m () +setDescriptionIdemp description = tell $ GWData mempty mempty (Last $ Just $ Description description) mempty mempty mempty mempty mempty + +-- | Add translated description meta tag to the head of the page +-- +-- n.b. See comments for @setDescriptionIdemp@. +-- +-- Unlike 'setDescriptionI', this version is *idempotent* - calling it multiple +-- times will result in only a single description meta tag in the head. +-- +-- @since 1.6.23 +setDescriptionIdempI + :: (MonadWidget m, RenderMessage (HandlerSite m) msg) + => msg -> m () +setDescriptionIdempI msg = do + mr <- getMessageRender + setDescriptionIdemp $ mr msg + -- | Add OpenGraph type meta tag to the head of the page -- -- See all available OG types here: https://ogp.me/#types @@ -252,7 +305,7 @@ addStylesheetAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () -addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty +addStylesheetAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty -- | Link to the specified remote stylesheet. addStylesheetRemote :: MonadWidget m => Text -> m () @@ -260,7 +313,7 @@ addStylesheetRemote = flip addStylesheetRemoteAttrs [] -- | Link to the specified remote stylesheet. addStylesheetRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty +addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty addStylesheetEither :: MonadWidget m => Either (Route (HandlerSite m)) Text @@ -278,7 +331,7 @@ addScript = flip addScriptAttrs [] -- | Link to the specified local script. addScriptAttrs :: MonadWidget m => Route (HandlerSite m) -> [(Text, Text)] -> m () -addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty +addScriptAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty -- | Link to the specified remote script. addScriptRemote :: MonadWidget m => Text -> m () @@ -286,7 +339,7 @@ addScriptRemote = flip addScriptRemoteAttrs [] -- | Link to the specified remote script. addScriptRemoteAttrs :: MonadWidget m => Text -> [(Text, Text)] -> m () -addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty +addScriptRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty whamlet :: QuasiQuoter whamlet = NP.hamletWithSettings rules NP.defaultHamletSettings diff --git a/yesod-core/src/Yesod/Routes/TH/Dispatch.hs b/yesod-core/src/Yesod/Routes/TH/Dispatch.hs index c061a1c2..1d12c9d9 100644 --- a/yesod-core/src/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-core/src/Yesod/Routes/TH/Dispatch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, TemplateHaskell, ViewPatterns #-} module Yesod.Routes.TH.Dispatch ( MkDispatchSettings (..) @@ -73,7 +74,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do handlePiece (Static str) = return (LitP $ StringL str, Nothing) handlePiece (Dynamic _) = do x <- newName "dyn" - let pat = ViewP (VarE 'fromPathPiece) (ConP 'Just [VarP x]) + let pat = ViewP (VarE 'fromPathPiece) (conPCompat 'Just [VarP x]) return (pat, Just $ VarE x) handlePieces :: [Piece a] -> Q ([Pat], [Exp]) @@ -86,7 +87,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do mkPathPat final = foldr addPat final where - addPat x y = ConP '(:) [x, y] + addPat x y = conPCompat '(:) [x, y] go :: SDC -> ResourceTree a -> Q Clause go sdc (ResourceParent name _check pieces children) = do @@ -124,11 +125,11 @@ mkDispatchClause MkDispatchSettings {..} resources = do Methods multi methods -> do (finalPat, mfinalE) <- case multi of - Nothing -> return (ConP '[] [], Nothing) + Nothing -> return (conPCompat '[] [], Nothing) Just _ -> do multiName <- newName "multi" let pat = ViewP (VarE 'fromPathMultiPiece) - (ConP 'Just [VarP multiName]) + (conPCompat 'Just [VarP multiName]) return (pat, Just $ VarE multiName) let dynsMulti = @@ -200,3 +201,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do defaultGetHandler :: Maybe String -> String -> Q Exp defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs b/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs index 09654c83..9f7fb7de 100644 --- a/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs +++ b/yesod-core/src/Yesod/Routes/TH/RenderRoute.hs @@ -1,9 +1,20 @@ -{-# LANGUAGE TemplateHaskell, CPP #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + module Yesod.Routes.TH.RenderRoute ( -- ** RenderRoute mkRenderRouteInstance + , mkRenderRouteInstanceOpts , mkRouteCons + , mkRouteConsOpts , mkRenderRouteClauses + + , RouteOpts + , defaultOpts + , setEqDerived + , setShowDerived + , setReadDerived ) where import Yesod.Routes.TH.Types @@ -16,16 +27,67 @@ import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class +-- | General opts data type for generating yesod. +-- +-- Contains options for what instances are derived for the route. Use the setting +-- functions on `defaultOpts` to set specific fields. +-- +-- @since 1.6.25.0 +data RouteOpts = MkRouteOpts + { roDerivedEq :: Bool + , roDerivedShow :: Bool + , roDerivedRead :: Bool + } + +-- | Default options for generating routes. +-- +-- Defaults to all instances derived. +-- +-- @since 1.6.25.0 +defaultOpts :: RouteOpts +defaultOpts = MkRouteOpts True True True + +-- | +-- +-- @since 1.6.25.0 +setEqDerived :: Bool -> RouteOpts -> RouteOpts +setEqDerived b rdo = rdo { roDerivedEq = b } + +-- | +-- +-- @since 1.6.25.0 +setShowDerived :: Bool -> RouteOpts -> RouteOpts +setShowDerived b rdo = rdo { roDerivedShow = b } + +-- | +-- +-- @since 1.6.25.0 +setReadDerived :: Bool -> RouteOpts -> RouteOpts +setReadDerived b rdo = rdo { roDerivedRead = b } + +-- | +-- +-- @since 1.6.25.0 +instanceNamesFromOpts :: RouteOpts -> [Name] +instanceNamesFromOpts (MkRouteOpts eq shw rd) = prependIf eq ''Eq $ prependIf shw ''Show $ prependIf rd ''Read [] + where prependIf b = if b then (:) else const id + -- | Generate the constructors of a route data type. mkRouteCons :: [ResourceTree Type] -> Q ([Con], [Dec]) -mkRouteCons rttypes = +mkRouteCons = mkRouteConsOpts defaultOpts + +-- | Generate the constructors of a route data type, with custom opts. +-- +-- @since 1.6.25.0 +mkRouteConsOpts :: RouteOpts -> [ResourceTree Type] -> Q ([Con], [Dec]) +mkRouteConsOpts opts rttypes = mconcat <$> mapM mkRouteCon rttypes where mkRouteCon (ResourceLeaf res) = return ([con], []) where con = NormalC (mkName $ resourceName res) - $ map (\x -> (notStrict, x)) + $ map (notStrict,) $ concat [singles, multi, sub] singles = concatMap toSingle $ resourcePieces res toSingle Static{} = [] @@ -39,16 +101,17 @@ mkRouteCons rttypes = _ -> [] mkRouteCon (ResourceParent name _check pieces children) = do - (cons, decs) <- mkRouteCons children + (cons, decs) <- mkRouteConsOpts opts children + let conts = mapM conT $ instanceNamesFromOpts opts #if MIN_VERSION_template_haskell(2,12,0) - dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT [''Show, ''Read, ''Eq]) + dec <- DataD [] (mkName name) [] Nothing cons <$> fmap (pure . DerivClause Nothing) conts #else - dec <- DataD [] (mkName name) [] Nothing cons <$> mapM conT [''Show, ''Read, ''Eq] + dec <- DataD [] (mkName name) [] Nothing cons <$> conts #endif return ([con], dec : decs) where con = NormalC (mkName name) - $ map (\x -> (notStrict, x)) + $ map (notStrict,) $ singles ++ [ConT $ mkName name] singles = concatMap toSingle pieces @@ -67,7 +130,7 @@ mkRenderRouteClauses = let cnt = length $ filter isDynamic pieces dyns <- replicateM cnt $ newName "dyn" child <- newName "child" - let pat = ConP (mkName name) $ map VarP $ dyns ++ [child] + let pat = conPCompat (mkName name) $ map VarP $ dyns ++ [child] pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -100,7 +163,7 @@ mkRenderRouteClauses = case resourceDispatch res of Subsite{} -> return <$> newName "sub" _ -> return [] - let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub + let pat = conPCompat (mkName $ resourceName res) $ map VarP $ dyns ++ sub pack' <- [|pack|] tsp <- [|toPathPiece|] @@ -152,9 +215,19 @@ mkRenderRouteClauses = -- 'renderRoute' method. This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'. mkRenderRouteInstance :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] -mkRenderRouteInstance cxt typ ress = do +mkRenderRouteInstance = mkRenderRouteInstanceOpts defaultOpts + +-- | Generate the 'RenderRoute' instance. +-- +-- This includes both the 'Route' associated type and the +-- 'renderRoute' method. This function uses both 'mkRouteCons' and +-- 'mkRenderRouteClasses'. +-- +-- @since 1.6.25.0 +mkRenderRouteInstanceOpts :: RouteOpts -> Cxt -> Type -> [ResourceTree Type] -> Q [Dec] +mkRenderRouteInstanceOpts opts cxt typ ress = do cls <- mkRenderRouteClauses ress - (cons, decs) <- mkRouteCons ress + (cons, decs) <- mkRouteConsOpts opts ress #if MIN_VERSION_template_haskell(2,15,0) did <- DataInstD [] Nothing (AppT (ConT ''Route) typ) Nothing cons <$> fmap (pure . DerivClause Nothing) (mapM conT (clazzes False)) let sds = fmap (\t -> StandaloneDerivD Nothing cxt $ ConT t `AppT` ( ConT ''Route `AppT` typ)) (clazzes True) @@ -175,10 +248,17 @@ mkRenderRouteInstance cxt typ ress = do clazzes' else [] - clazzes' = [''Show, ''Eq, ''Read] + clazzes' = instanceNamesFromOpts opts notStrict :: Bang notStrict = Bang NoSourceUnpackedness NoSourceStrictness instanceD :: Cxt -> Type -> [Dec] -> Dec instanceD = InstanceD Nothing + +conPCompat :: Name -> [Pat] -> Pat +conPCompat n pats = ConP n +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + pats diff --git a/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs b/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs index 0f1aeece..72b24b49 100644 --- a/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs +++ b/yesod-core/src/Yesod/Routes/TH/RouteAttrs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} module Yesod.Routes.TH.RouteAttrs @@ -26,7 +27,11 @@ goTree front (ResourceParent name _check pieces trees) = toIgnore = length $ filter isDynamic pieces isDynamic Dynamic{} = True isDynamic Static{} = False - front' = front . ConP (mkName name) . ignored + front' = front . ConP (mkName name) +#if MIN_VERSION_template_haskell(2,18,0) + [] +#endif + . ignored goRes :: (Pat -> Pat) -> Resource a -> Q Clause goRes front Resource {..} = diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 591f86a7..dc83b760 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/yesod-core/test/YesodCoreTest.hs @@ -5,9 +5,11 @@ import YesodCoreTest.CleanPath import YesodCoreTest.Exceptions import YesodCoreTest.Widget import YesodCoreTest.Media +import YesodCoreTest.Meta import YesodCoreTest.Links import YesodCoreTest.Header import YesodCoreTest.NoOverloadedStrings +import YesodCoreTest.SubSub import YesodCoreTest.InternalRequest import YesodCoreTest.ErrorHandling import YesodCoreTest.Cache @@ -42,6 +44,7 @@ specs = do mediaTest linksTest noOverloadedTest + subSubTest internalRequestTest errorHandlingTest cacheTest @@ -63,3 +66,4 @@ specs = do Ssl.sameSiteSpec Csrf.csrfSpec breadcrumbTest + metaTest diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index 048342ce..0892faf1 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -1,26 +1,37 @@ {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} + module YesodCoreTest.ErrorHandling ( errorHandlingTest , Widget , resourcesApp ) where + +import Data.Typeable(cast) +import qualified System.Mem as Mem +import qualified Control.Concurrent.Async as Async +import Control.Concurrent as Conc import Yesod.Core import Test.Hspec import Network.Wai import Network.Wai.Test import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 -import Control.Exception (SomeException, try) +import Control.Exception (SomeException, try, AsyncException(..)) +import UnliftIO.Exception(finally) import Network.HTTP.Types (Status, mkStatus) import Data.ByteString.Builder (Builder, toLazyByteString) import Data.Monoid (mconcat) import Data.Text (Text, pack) import Control.Monad (forM_) +import qualified Network.Wai.Handler.Warp as Warp +import qualified YesodCoreTest.ErrorHandling.CustomApp as Custom import Control.Monad.Trans.State (StateT (..)) import Control.Monad.Trans.Reader (ReaderT (..)) import qualified UnliftIO.Exception as E +import System.Timeout(timeout) data App = App @@ -45,6 +56,10 @@ mkYesod "App" [parseRoutes| /auth-not-adequate AuthNotAdequateR GET /args-not-valid ArgsNotValidR POST /only-plain-text OnlyPlainTextR GET + +/thread-killed ThreadKilledR GET +/connection-closed-by-peer ConnectionClosedPeerR GET +/sleep-sec SleepASecR GET |] overrideStatus :: Status @@ -111,6 +126,23 @@ goodBuilderContent = Data.Monoid.mconcat $ replicate 100 $ "This is a test\n" getGoodBuilderR :: Handler TypedContent getGoodBuilderR = return $ TypedContent "text/plain" $ toContent goodBuilderContent +-- this handler kills it's own thread +getThreadKilledR :: Handler Html +getThreadKilledR = do + x <- liftIO Conc.myThreadId + liftIO $ Async.withAsync (Conc.killThread x) Async.wait + pure "unreachablle" +getSleepASecR :: Handler Html +getSleepASecR = do + liftIO $ Conc.threadDelay 1000000 + pure "slept a second" + +getConnectionClosedPeerR :: Handler Html +getConnectionClosedPeerR = do + x <- liftIO Conc.myThreadId + liftIO $ Async.withAsync (E.throwTo x Warp.ConnectionClosedByPeer) Async.wait + pure "unreachablle" + getErrorR :: Int -> Handler () getErrorR 1 = setSession undefined "foo" getErrorR 2 = setSession "foo" undefined @@ -154,6 +186,10 @@ errorHandlingTest = describe "Test.ErrorHandling" $ do it "accept CSS, permission denied -> 403" caseCssPermissionDenied it "accept image, non-existent path -> 404" caseImageNotFound it "accept video, bad method -> 405" caseVideoBadMethod + it "default config exception rethrows connection closed" caseDefaultConnectionCloseRethrows + it "custom config rethrows an exception" caseCustomExceptionRethrows + it "thread killed rethrow" caseThreadKilledRethrow + it "can timeout a runner" canTimeoutARunner runner :: Session a -> IO a runner f = toWaiApp App >>= runSession f @@ -291,3 +327,50 @@ caseVideoBadMethod = runner $ do ("accept", "video/webm") : requestHeaders defaultRequest } assertStatus 405 res + +fromExceptionUnwrap :: E.Exception e => SomeException -> Maybe e +fromExceptionUnwrap se + | Just (E.AsyncExceptionWrapper e) <- E.fromException se = cast e + | Just (E.SyncExceptionWrapper e) <- E.fromException se = cast e + | otherwise = E.fromException se + + +caseThreadKilledRethrow :: IO () +caseThreadKilledRethrow = + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of + (Just ThreadKilled) -> True + _ -> False + where + testcode = runner $ do + res <- request defaultRequest { pathInfo = ["thread-killed"] } + assertStatus 500 res + assertBodyContains "Internal Server Error" res + +caseDefaultConnectionCloseRethrows :: IO () +caseDefaultConnectionCloseRethrows = + shouldThrow testcode $ \e -> case fromExceptionUnwrap e of + Just Warp.ConnectionClosedByPeer -> True + _ -> False + + where + testcode = runner $ do + _res <- request defaultRequest { pathInfo = ["connection-closed-by-peer"] } + pure () + +caseCustomExceptionRethrows :: IO () +caseCustomExceptionRethrows = + shouldThrow testcode $ \case Custom.MkMyException -> True + where + testcode = customAppRunner $ do + _res <- request defaultRequest { pathInfo = ["throw-custom-exception"] } + pure () + customAppRunner f = toWaiApp Custom.CustomApp >>= runSession f + + +canTimeoutARunner :: IO () +canTimeoutARunner = do + res <- timeout 1000 $ runner $ do + res <- request defaultRequest { pathInfo = ["sleep-sec"] } + assertStatus 200 res -- if 500, it's catching the timeout exception + pure () -- it should've timeout by now, either being 500 or Nothing + res `shouldBe` Nothing -- make sure that pure statement didn't happen. diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs new file mode 100644 index 00000000..e7e5bde2 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/ErrorHandling/CustomApp.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} + +-- | a custom app that throws an exception +module YesodCoreTest.ErrorHandling.CustomApp + (CustomApp(..) + , MyException(..) + + -- * unused + , Widget + , resourcesCustomApp + ) where + + +import Yesod.Core.Types +import Yesod.Core +import qualified UnliftIO.Exception as E + +data CustomApp = CustomApp + +mkYesod "CustomApp" [parseRoutes| +/throw-custom-exception CustomHomeR GET +|] + +getCustomHomeR :: Handler Html +getCustomHomeR = + E.throwIO MkMyException + +data MyException = MkMyException + deriving (Show, E.Exception) + +instance Yesod CustomApp where + -- something we couldn't do before, rethrow custom exceptions + catchHandlerExceptions _ action handler = + action `E.catch` \exception -> do + case E.fromException exception of + Just MkMyException -> E.throwIO MkMyException + Nothing -> handler exception diff --git a/yesod-core/test/YesodCoreTest/Meta.hs b/yesod-core/test/YesodCoreTest/Meta.hs new file mode 100644 index 00000000..03e6e8ac --- /dev/null +++ b/yesod-core/test/YesodCoreTest/Meta.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module YesodCoreTest.Meta + ( metaTest + ) where + +import Test.Hspec + +import Yesod.Core +import Network.Wai +import Network.Wai.Test + +data App = App + +mkYesod "App" [parseRoutes| +/title TitleR GET +/desc DescriptionR GET +|] + +instance Yesod App where + +getTitleR :: Handler Html +getTitleR = defaultLayout $ do + setTitle "First title" + setTitle "Second title" + +getDescriptionR :: Handler Html +getDescriptionR = defaultLayout $ do + setDescriptionIdemp "First description" + setDescriptionIdemp "Second description" + +metaTest :: Spec +metaTest = describe "Setting page metadata" $ do + describe "Yesod.Core.Widget.setTitle" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["title"] + } + assertBody "<!DOCTYPE html>\n<html><head><title>Second title" res + describe "Yesod.Core.Widget.setDescriptionIdemp" $ do + it "is idempotent" $ runner $ do + res <- request defaultRequest + { pathInfo = ["desc"] + } + assertBody "\n" res + +runner :: Session () -> IO () +runner f = toWaiAppPlain App >>= runSession f diff --git a/yesod-core/test/YesodCoreTest/SubSub.hs b/yesod-core/test/YesodCoreTest/SubSub.hs new file mode 100644 index 00000000..4f02d48b --- /dev/null +++ b/yesod-core/test/YesodCoreTest/SubSub.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +module YesodCoreTest.SubSub where + +import Test.Hspec + +import Yesod.Core +import Network.Wai.Test +import qualified Data.Text as T +import qualified Data.ByteString.Lazy.Char8 as L8 + +import YesodCoreTest.SubSubData + +data App = App { getOuter :: OuterSubSite } + +mkYesod "App" [parseRoutes| +/ OuterSubSiteR OuterSubSite getOuter +|] + +instance Yesod App + +getSubR :: SubHandlerFor InnerSubSite master T.Text +getSubR = return $ T.pack "sub" + +instance YesodSubDispatch OuterSubSite master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite) + +instance YesodSubDispatch InnerSubSite master where + yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite) + +app :: App +app = App { getOuter = OuterSubSite { getInner = InnerSubSite }} + +runner :: Session () -> IO () +runner f = toWaiApp app >>= runSession f + +case_subSubsite :: IO () +case_subSubsite = runner $ do + res <- request defaultRequest + assertBody (L8.pack "sub") res + assertStatus 200 res + +subSubTest :: Spec +subSubTest = describe "YesodCoreTest.SubSub" $ do + it "sub_subsite" case_subSubsite \ No newline at end of file diff --git a/yesod-core/test/YesodCoreTest/SubSubData.hs b/yesod-core/test/YesodCoreTest/SubSubData.hs new file mode 100644 index 00000000..636da3a5 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/SubSubData.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} + +module YesodCoreTest.SubSubData where + +import Yesod.Core + + +data OuterSubSite = OuterSubSite { getInner :: InnerSubSite } + +data InnerSubSite = InnerSubSite + +mkYesodSubData "InnerSubSite" [parseRoutes| +/ SubR GET +|] + +mkYesodSubData "OuterSubSite" [parseRoutes| +/ InnerSubSiteR InnerSubSite getInner +|] \ No newline at end of file diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 0e3799d5..3c7b0902 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.6.20.2 +version: 1.6.25.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -27,6 +27,7 @@ library build-depends: base >= 4.10 && < 5 , aeson >= 1.0 + , attoparsec-aeson >= 2.1 , auto-update , blaze-html >= 0.5 , blaze-markup >= 0.7.1 @@ -58,7 +59,7 @@ library , unix-compat , unliftio , unordered-containers >= 0.2 - , vector >= 0.9 && < 0.13 + , vector >= 0.9 && < 0.14 , wai >= 3.2 , wai-extra >= 3.0.7 , wai-logger >= 0.2 @@ -146,6 +147,7 @@ test-suite tests YesodCoreTest.Header YesodCoreTest.Csrf YesodCoreTest.ErrorHandling + YesodCoreTest.ErrorHandling.CustomApp YesodCoreTest.Exceptions YesodCoreTest.InternalRequest YesodCoreTest.JsLoader @@ -155,6 +157,7 @@ test-suite tests YesodCoreTest.LiteApp YesodCoreTest.Media YesodCoreTest.MediaData + YesodCoreTest.Meta YesodCoreTest.NoOverloadedStrings YesodCoreTest.NoOverloadedStringsSub YesodCoreTest.ParameterizedSite @@ -171,6 +174,8 @@ test-suite tests YesodCoreTest.StubSslOnly YesodCoreTest.StubStrictSameSite YesodCoreTest.StubUnsecured + YesodCoreTest.SubSub + YesodCoreTest.SubSubData YesodCoreTest.WaiSubsite YesodCoreTest.Widget YesodCoreTest.YesodTest diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index 5d37f2f8..6fa84b00 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,5 +1,29 @@ # ChangeLog for yesod-form +## 1.7.6 + +* Added `datetimeLocalField` for creating a html `` [#1817](https://github.com/yesodweb/yesod/pull/1817) + +## 1.7.5 + +* Add Romanian translation [#1801](https://github.com/yesodweb/yesod/pull/1801) + +## 1.7.4 + +* Added a `Monad AForm` instance only when `transformers` >= 0.6 [#1795](https://github.com/yesodweb/yesod/pull/1795) + +## 1.7.3 + +* Fixed `radioField` according to Bootstrap 3 docs. [#1783](https://github.com/yesodweb/yesod/pull/1783) + +## 1.7.2 + +* Added `withRadioField` and re-express `radioField` into that. [#1775](https://github.com/yesodweb/yesod/pull/1775) + +## 1.7.1 + +* Added `colorField` for creating a html color field (``) [#1748](https://github.com/yesodweb/yesod/pull/1748) + ## 1.7.0 * Extended `OptionList` by `OptionListGrouped` and implemented grouped select fields (`