diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index fb5ca395..9e1ca6ea 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.2 * Fix warnings diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index c45b054b..11e691c8 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -15,16 +15,15 @@ module Yesod.Auth.OAuth ) where import Control.Applicative as A ((<$>), (<*>)) import Control.Arrow ((***)) -import Control.Exception (Exception, throwIO) +import UnliftIO.Exception import Control.Monad.IO.Class -import Control.Monad.IO.Unlift (MonadUnliftIO) +import UnliftIO (MonadUnliftIO) import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) -import Data.Typeable import Web.Authenticate.OAuth import Yesod.Auth import Yesod.Form diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 2775fa66..38f6d047 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,5 +1,5 @@ name: yesod-auth-oauth -version: 1.4.2 +version: 1.6.0 license: BSD3 license-file: LICENSE author: Hiromi Ishii @@ -23,12 +23,12 @@ library build-depends: base >= 4 && < 4.3 build-depends: authenticate-oauth >= 1.5 && < 1.7 , bytestring >= 0.9.1.4 - , yesod-core >= 1.4 && < 1.5 - , yesod-auth >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 + , yesod-auth >= 1.6 && < 1.7 , text >= 0.7 - , yesod-form >= 1.4 && < 1.5 + , yesod-form >= 1.6 && < 1.7 , transformers >= 0.2.2 && < 0.6 - , unliftio-core + , unliftio exposed-modules: Yesod.Auth.OAuth ghc-options: -Wall diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 095ccbd6..69ac6519 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.21 * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index fe22654d..ae89dd12 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -50,7 +50,7 @@ module Yesod.Auth import Control.Monad (when) import Control.Monad.Trans.Maybe -import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO) +import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes import Data.Aeson hiding (json) @@ -314,8 +314,8 @@ loginErrorMessageMasterI dest msg = do -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status -loginErrorMessage :: YesodAuth master - => Route master +loginErrorMessage + :: Route master -> Text -> AuthHandler master TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 6a974a0e..789006e2 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -84,7 +84,7 @@ import qualified Data.Aeson.Encode as A import Data.Aeson.Parser (json') import Data.Aeson.Types (FromJSON (parseJSON), parseEither, parseMaybe, withObject, withText) -import Data.Conduit (($$+-), ($$), (.|), runConduit) +import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) @@ -274,7 +274,7 @@ getPerson :: Manager -> Token -> AuthHandler site (Maybe Person) getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do req <- personValueRequest token res <- http req manager - responseBody res $$+- sinkParser json' + runConduit $ responseBody res .| sinkParser json' ) personValueRequest :: MonadIO m => Token -> m Request diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 6cd8b187..e6be61aa 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.4.21 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -23,7 +23,7 @@ library build-depends: base >= 4 && < 5 , authenticate >= 1.3.4 , bytestring >= 0.9.1.4 - , yesod-core >= 1.4.31 && < 1.5 + , yesod-core >= 1.6 && < 1.7 , wai >= 1.4 , template-haskell , base16-bytestring @@ -32,13 +32,13 @@ library , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3 - , yesod-persistent >= 1.4 + , yesod-persistent >= 1.6 , shakespeare , containers , unordered-containers - , yesod-form >= 1.4 && < 1.5 + , yesod-form >= 1.6 && < 1.7 , transformers >= 0.2.2 - , persistent >= 2.5 && < 2.8 + , persistent >= 2.8 && < 2.9 , persistent-template >= 2.1 && < 2.8 , http-client >= 0.5 , http-client-tls diff --git a/yesod-bin/AddHandler.hs b/yesod-bin/AddHandler.hs index e925661f..8995a0b1 100644 --- a/yesod-bin/AddHandler.hs +++ b/yesod-bin/AddHandler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module AddHandler (addHandler) where @@ -8,7 +9,11 @@ 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, 0, 0) +import Distribution.PackageDescription.Parse (readGenericPackageDescription) +#else import Distribution.PackageDescription.Parse (readPackageDescription) +#endif import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) import Distribution.Verbosity (normal) @@ -224,7 +229,11 @@ uncapitalize "" = "" getSrcDir :: FilePath -> IO FilePath getSrcDir cabal = do +#if MIN_VERSION_Cabal(2, 0, 0) + pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal +#else pd <- flattenPackageDescription <$> readPackageDescription normal cabal +#endif let buildInfo = allBuildInfo pd srcDirs = concatMap hsSourceDirs buildInfo return $ fromMaybe "." $ listToMaybe srcDirs diff --git a/yesod-bin/Build.hs b/yesod-bin/Build.hs deleted file mode 100644 index eecef808..00000000 --- a/yesod-bin/Build.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -module Build - ( getDeps - , touchDeps - , touch - , recompDeps - , isNewerThan - , safeReadFile - ) where - -import Control.Applicative as App ((<|>), many, (<$>)) -import qualified Data.Attoparsec.Text as A -import Data.Char (isSpace, isUpper) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.ByteString (ByteString) -import qualified Data.ByteString as S - -import UnliftIO.Exception (tryIO, IOException, handleAny, catchAny, tryAny) -import Control.Monad (when, filterM, forM, forM_, (>=>)) -import Control.Monad.Trans.State (StateT (StateT), get, put, execStateT) -import Control.Monad.Trans.Writer (WriterT, tell, execWriterT) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Class (lift) - -import Data.Monoid (Monoid (..)) -import qualified Data.Map as Map -import qualified Data.Set as Set - -import qualified System.Posix.Types -import System.Directory -import System.FilePath (takeExtension, replaceExtension, (), takeDirectory, - splitPath, joinPath) -import System.PosixCompat.Files (getFileStatus, setFileTimes, - accessTime, modificationTime) - -import Text.Shakespeare (Deref) -import Text.Julius (juliusUsedIdentifiers) -import Text.Cassius (cassiusUsedIdentifiers) -import Text.Lucius (luciusUsedIdentifiers) - -safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString) -safeReadFile = liftIO . tryIO . S.readFile - -touch :: IO () -touch = do - m <- handleAny (\_ -> return Map.empty) $ readFile touchCache >>= readIO - x <- fmap snd (getDeps []) - m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m - createDirectoryIfMissing True $ takeDirectory touchCache - writeFile touchCache $ show m' - where - touchCache = "dist/touchCache.txt" - --- | Returns True if any files were touched, otherwise False -recompDeps :: [FilePath] -> StateT (Map.Map FilePath (Set.Set Deref)) IO Bool -recompDeps = - fmap toBool . execWriterT . (liftIO . getDeps >=> touchDeps hiFile removeHi . snd) - where - toBool NoFilesTouched = False - toBool SomeFilesTouched = True - -type Deps = Map.Map FilePath ([FilePath], ComparisonType) - -getDeps :: [FilePath] -> IO ([FilePath], Deps) -getDeps hsSourceDirs = do - let defSrcDirs = case hsSourceDirs of - [] -> ["."] - ds -> ds - hss <- fmap concat $ mapM findHaskellFiles defSrcDirs - deps' <- mapM determineDeps hss - return $ (hss, fixDeps $ zip hss deps') - -data AnyFilesTouched = NoFilesTouched | SomeFilesTouched -instance Data.Monoid.Monoid AnyFilesTouched where - mempty = NoFilesTouched - mappend NoFilesTouched NoFilesTouched = mempty - mappend _ _ = SomeFilesTouched - -touchDeps :: (FilePath -> FilePath) -> - (FilePath -> FilePath -> IO ()) -> - Deps -> WriterT AnyFilesTouched (StateT (Map.Map FilePath (Set.Set Deref)) IO) () -touchDeps f action deps = (mapM_ go . Map.toList) deps - where - ignoreStateEx defRes (StateT g) = StateT $ \s0 -> - g s0 `catchAny` \_ -> return (defRes, s0) - go (x, (ys, ct)) = do - isChanged <- lift $ ignoreStateEx True $ - case ct of - AlwaysOutdated -> return True - CompareUsedIdentifiers getDerefs -> do - derefMap <- get - ebs <- safeReadFile x - let newDerefs = - case ebs of - Left _ -> Set.empty - Right bs -> Set.fromList $ getDerefs $ T.unpack $ decodeUtf8With lenientDecode bs - put $ Map.insert x newDerefs derefMap - case Map.lookup x derefMap of - Just oldDerefs | oldDerefs == newDerefs -> return False - _ -> return True - when isChanged $ forM_ ys $ \y -> do - n <- liftIO $ x `isNewerThan` f y - when n $ do - liftIO $ putStrLn ("Forcing recompile for " ++ y ++ " because of " ++ x) - liftIO $ action x y - tell SomeFilesTouched - --- | remove the .hi files for a .hs file, thereby forcing a recompile -removeHi :: FilePath -> FilePath -> IO () -removeHi _ hs = mapM_ removeFile' hiFiles - where - removeFile' file = tryAny (removeFile file) >> return () - hiFiles = map (\e -> "dist/build" removeSrc (replaceExtension hs e)) - ["hi", "p_hi"] - --- | change file mtime of .hs file to that of the dependency -updateFileTime :: FilePath -> FilePath -> IO () -updateFileTime x hs = do - (_ , modx) <- getFileStatus' x - (access, _ ) <- getFileStatus' hs - _ <- tryAny (setFileTimes hs access modx) - return () - -hiFile :: FilePath -> FilePath -hiFile hs = "dist/build" removeSrc (replaceExtension hs "hi") - -removeSrc :: FilePath -> FilePath -removeSrc f = case splitPath f of - ("src/" : xs) -> joinPath xs - _ -> f - -isNewerThan :: FilePath -> FilePath -> IO Bool -isNewerThan f1 f2 = do - (_, mod1) <- getFileStatus' f1 - (_, mod2) <- getFileStatus' f2 - return (mod1 > mod2) - -getFileStatus' :: FilePath -> - IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime) -getFileStatus' fp = do - efs <- tryAny $ getFileStatus fp - case efs of - Left _ -> return (0, 0) - Right fs -> return (accessTime fs, modificationTime fs) - -fixDeps :: [(FilePath, [(ComparisonType, FilePath)])] -> Deps -fixDeps = - Map.unionsWith combine . map go - where - go :: (FilePath, [(ComparisonType, FilePath)]) -> Deps - go (x, ys) = Map.fromList $ map (\(ct, y) -> (y, ([x], ct))) ys - - combine (ys1, ct) (ys2, _) = (ys1 `mappend` ys2, ct) - -findHaskellFiles :: FilePath -> IO [FilePath] -findHaskellFiles path = do - contents <- getDirectoryContents path - fmap concat $ mapM go contents - where - go ('.':_) = return [] - go filename = do - d <- doesDirectoryExist full - if not d - then if isHaskellFile - then return [full] - else return [] - else if isHaskellDir - then findHaskellFiles full - else return [] - where - -- this could fail on unicode - isHaskellDir = isUpper (head filename) - isHaskellFile = takeExtension filename `elem` watch_files - full = path filename - watch_files = [".hs", ".lhs"] - -data TempType = StaticFiles FilePath - | Verbatim | Messages FilePath | Hamlet | Widget | Julius | Cassius | Lucius - deriving Show - --- | How to tell if a file is outdated. -data ComparisonType = AlwaysOutdated - | CompareUsedIdentifiers (String -> [Deref]) - -determineDeps :: FilePath -> IO [(ComparisonType, FilePath)] -determineDeps x = do - y <- safeReadFile x - case y of - Left _ -> return [] - Right bs -> do - let z = A.parseOnly (many $ (parser <|> (A.anyChar >> return Nothing))) - $ decodeUtf8With lenientDecode bs - case z of - Left _ -> return [] - Right r -> mapM go r >>= filterM (doesFileExist . snd) . concat - where - go (Just (StaticFiles fp, _)) = map ((,) AlwaysOutdated) App.<$> getFolderContents fp - go (Just (Hamlet, f)) = return [(AlwaysOutdated, f)] - go (Just (Widget, f)) = return - [ (AlwaysOutdated, "templates/" ++ f ++ ".hamlet") - , (CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, "templates/" ++ f ++ ".julius") - , (CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, "templates/" ++ f ++ ".lucius") - , (CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, "templates/" ++ f ++ ".cassius") - ] - go (Just (Julius, f)) = return [(CompareUsedIdentifiers $ map fst . juliusUsedIdentifiers, f)] - go (Just (Cassius, f)) = return [(CompareUsedIdentifiers $ map fst . cassiusUsedIdentifiers, f)] - go (Just (Lucius, f)) = return [(CompareUsedIdentifiers $ map fst . luciusUsedIdentifiers, f)] - go (Just (Verbatim, f)) = return [(AlwaysOutdated, f)] - go (Just (Messages f, _)) = map ((,) AlwaysOutdated) <$> getFolderContents f - go Nothing = return [] - - parser = do - ty <- (do _ <- A.string "\nstaticFiles \"" - x' <- A.many1 $ A.satisfy (/= '"') - return $ StaticFiles x') - <|> (A.string "$(parseRoutesFile " >> return Verbatim) - <|> (A.string "$(hamletFile " >> return Hamlet) - <|> (A.string "$(ihamletFile " >> return Hamlet) - <|> (A.string "$(whamletFile " >> return Hamlet) - <|> (A.string "$(html " >> return Hamlet) - <|> (A.string "$(widgetFile " >> return Widget) - <|> (A.string "$(Settings.hamletFile " >> return Hamlet) - <|> (A.string "$(Settings.widgetFile " >> return Widget) - <|> (A.string "$(juliusFile " >> return Julius) - <|> (A.string "$(cassiusFile " >> return Cassius) - <|> (A.string "$(luciusFile " >> return Lucius) - <|> (A.string "$(persistFile " >> return Verbatim) - <|> ( - A.string "$(persistFileWith " >> - A.many1 (A.satisfy (/= '"')) >> - return Verbatim) - <|> (do - _ <- A.string "\nmkMessage \"" - A.skipWhile (/= '"') - _ <- A.string "\" \"" - x' <- A.many1 $ A.satisfy (/= '"') - _ <- A.string "\" \"" - _y <- A.many1 $ A.satisfy (/= '"') - _ <- A.string "\"" - return $ Messages x') - case ty of - Messages{} -> return $ Just (ty, "") - StaticFiles{} -> return $ Just (ty, "") - _ -> do - A.skipWhile isSpace - _ <- A.char '"' - y <- A.many1 $ A.satisfy (/= '"') - _ <- A.char '"' - A.skipWhile isSpace - _ <- A.char ')' - return $ Just (ty, y) - - getFolderContents :: FilePath -> IO [FilePath] - getFolderContents fp = do - cs <- getDirectoryContents fp - let notHidden ('.':_) = False - notHidden ('t':"mp") = False - notHidden ('f':"ay") = False - notHidden _ = True - fmap concat $ forM (filter notHidden cs) $ \c -> do - let f = fp ++ '/' : c - isFile <- doesFileExist f - if isFile then return [f] else getFolderContents f diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index 0020b34a..04daaf82 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,3 +1,8 @@ +## 1.6.0 + +* Upgrade to conduit 1.3.0 +* Remove configure, build, touch, and test commands + ## 1.5.3 * Support typed-process-0.2.0.0 diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index c871a772..4daa9cca 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -9,8 +9,8 @@ module Devel ) where import Control.Applicative ((<|>)) +import UnliftIO (race_) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race_) import Control.Concurrent.STM import qualified UnliftIO.Exception as Ex import Control.Monad (forever, unless, void, diff --git a/yesod-bin/HsFile.hs b/yesod-bin/HsFile.hs index 18868c24..6c73fecf 100644 --- a/yesod-bin/HsFile.hs +++ b/yesod-bin/HsFile.hs @@ -3,7 +3,6 @@ module HsFile (mkHsFile) where import Text.ProjectTemplate (createTemplate) import Conduit -import Control.Monad.Trans.Resource (runResourceT) import qualified Data.ByteString as BS import Control.Monad.IO.Class (liftIO) import Data.String (fromString) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 566f8cf9..3f3a071b 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -2,37 +2,18 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) import Options.Applicative -import System.Environment (getEnvironment) -import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure) -import System.Process (rawSystem) +import System.Exit (exitFailure) import AddHandler (addHandler) import Devel (DevelOpts (..), devel, develSignal) import Keter (keter) import Options (injectDefaults) import qualified Paths_yesod_bin -import System.IO (hPutStrLn, stderr) import HsFile (mkHsFile) -#ifndef WINDOWS -import Build (touch) - -touch' :: IO () -touch' = touch - -windowsWarning :: String -windowsWarning = "" -#else -touch' :: IO () -touch' = return () - -windowsWarning :: String -windowsWarning = " (does not work on Windows)" -#endif data CabalPgm = Cabal | CabalDev deriving (Show, Eq) @@ -91,17 +72,16 @@ main = do c -> c }) ] optParser' - let cabal = rawSystem' (cabalCommand o) case optCommand o of Init _ -> initErrorMsg HsFiles -> mkHsFile - Configure -> cabal ["configure"] - Build es -> touch' >> cabal ("build":es) - Touch -> touch' + Configure -> cabalErrorMsg + Build _ -> cabalErrorMsg + Touch -> cabalErrorMsg Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods - Test -> cabalTest cabal + Test -> cabalErrorMsg Devel{..} -> devel DevelOpts { verbose = optVerbose o , successHook = develSuccessHook @@ -113,19 +93,6 @@ main = do } develExtraArgs DevelSignal -> develSignal where - cabalTest cabal = do - env <- getEnvironment - case lookup "STACK_EXE" env of - Nothing -> do - touch' - _ <- cabal ["configure", "--enable-tests", "-flibrary-only"] - _ <- cabal ["build"] - cabal ["test"] - Just _ -> do - hPutStrLn stderr "'yesod test' is no longer needed with Stack" - hPutStrLn stderr "Instead, please just run 'stack test'" - exitFailure - initErrorMsg = do mapM_ putStrLn [ "The init command has been removed." @@ -136,6 +103,13 @@ main = do ] exitFailure + cabalErrorMsg = do + mapM_ putStrLn + [ "The configure, build, touch, and test commands have been removed." + , "Please use 'stack' for building your project." + ] + exitFailure + optParser' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -148,17 +122,17 @@ optParser = Options <> command "hsfiles" (info (pure HsFiles) (progDesc "Create a hsfiles file for the current folder")) <> command "configure" (info (pure Configure) - (progDesc "Configure a project for building")) + (progDesc "DEPRECATED")) <> command "build" (info (helper <*> (Build <$> extraCabalArgs)) - (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "touch" (info (pure Touch) - (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "devel" (info (helper <*> develOptions) (progDesc "Run project with the devel server")) <> command "devel-signal" (info (helper <*> pure DevelSignal) (progDesc "Used internally by the devel command")) <> command "test" (info (pure Test) - (progDesc "Build and run the integration tests")) + (progDesc "DEPRECATED")) <> command "add-handler" (info (helper <*> addHandlerOptions) (progDesc ("Add a new handler and module to the project." ++ " Interactively asks for input if you do not specify arguments."))) @@ -217,10 +191,3 @@ addHandlerOptions = AddHandler -- | Optional @String@ argument optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr m = option (Just <$> str) $ value Nothing <> m - --- | Like @rawSystem@, but exits if it receives a non-success result. -rawSystem' :: String -> [String] -> IO () -rawSystem' x y = do - res <- rawSystem x y - unless (res == ExitSuccess) $ exitWith res - diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index 2eefd423..7bf30c43 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -1,5 +1,5 @@ name: yesod-bin -version: 1.5.3 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -68,13 +68,11 @@ executable yesod , data-default-class , streaming-commons , warp-tls >= 3.0.1 - , async - , deepseq + , unliftio ghc-options: -Wall -threaded -rtsopts main-is: main.hs other-modules: Devel - Build Keter AddHandler Paths_yesod_bin diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index 521e68fc..8b73dd55 100644 --- a/yesod-core/ChangeLog.md +++ b/yesod-core/ChangeLog.md @@ -1,13 +1,15 @@ -## 1.5.0 - -* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers. - -## 1.4.38 +## 1.6.0 +* Upgrade to conduit 1.3.0 +* Switch to `MonadUnliftIO` +* Drop `mwc-random` and `blaze-builder` dependencies +* Strictify some internal data structures +* Add `CI` wrapper to first field in `Header` data constructor + [#1418](https://github.com/yesodweb/yesod/issues/1418) * Internal only change, users of stable API are unaffected: `WidgetT` holds its data in an `IORef` so that it is isomorphic to `ReaderT`, avoiding state-loss issues.. -* Instances for `MonadUnliftIO` +* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers. ## 1.4.37.2 diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index ae2f40bc..2aa04b10 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -31,7 +31,6 @@ module Yesod.Core -- * Logging , defaultMakeLogger , defaultMessageLoggerSource - , defaultShouldLog , defaultShouldLogIO , formatLogMessage , LogLevel (..) @@ -146,7 +145,7 @@ import qualified Yesod.Core.Internal.Run import qualified Paths_yesod_core import Data.Version (showVersion) import Yesod.Routes.Class -import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..)) +import UnliftIO (MonadIO (..), MonadUnliftIO (..)) import Control.Monad.Trans.Resource (MonadResource (..)) import Yesod.Core.Internal.LiteApp diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index c4c1b641..be9db709 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -12,7 +12,7 @@ import Yesod.Core.Content (ToTypedContent (..)) import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute) import Yesod.Core.Class.Handler import Yesod.Core.Class.Yesod -import Control.Monad.Trans.Reader (ReaderT (..), ask) +import Control.Monad.Trans.Reader (ReaderT (..)) -- | This class is automatically instantiated when you use the template haskell -- mkYesod function. You should never need to deal with it directly. diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index c69a2524..97cf1aa7 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -14,7 +14,6 @@ module Yesod.Core.Class.Handler import Yesod.Core.Types import Control.Monad.Logger (MonadLogger) -import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO) import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Class (lift) #if __GLASGOW_HASKELL__ < 710 diff --git a/yesod-core/Yesod/Core/Class/Yesod.hs b/yesod-core/Yesod/Core/Class/Yesod.hs index 01be1459..c796ad64 100644 --- a/yesod-core/Yesod/Core/Class/Yesod.hs +++ b/yesod-core/Yesod/Core/Class/Yesod.hs @@ -10,7 +10,7 @@ import Yesod.Core.Handler import Yesod.Routes.Class -import Data.ByteString.Builder (Builder, toLazyByteString) +import Data.ByteString.Builder (Builder) import Data.Text.Encoding (encodeUtf8Builder) import Control.Arrow ((***), second) import Control.Exception (bracket) @@ -24,7 +24,6 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Aeson (object, (.=)) import Data.List (foldl', nub) import qualified Data.Map as Map @@ -37,9 +36,8 @@ import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Word (Word64) import Language.Haskell.TH.Syntax (Loc (..)) -import Network.HTTP.Types (encodePath, renderQueryText) +import Network.HTTP.Types (encodePath) import qualified Network.Wai as W -import Data.Default (def) import Network.Wai.Parse (lbsBackEnd, tempFileBackEnd) import Network.Wai.Logger (ZonedDate, clockDateCacher) @@ -52,7 +50,7 @@ import Text.Hamlet import Text.Julius import qualified Web.ClientSession as CS import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax, - sameSiteStrict, SameSiteOption) + sameSiteStrict, SameSiteOption, defaultSetCookie) import Yesod.Core.Types import Yesod.Core.Internal.Session import Yesod.Core.Widget @@ -66,18 +64,14 @@ class RenderRoute site => Yesod site where -- | An absolute URL to the root of the application. Do not include -- trailing slash. -- - -- Default value: 'ApprootRelative'. This is valid under the following - -- conditions: + -- Default value: 'guessApproot'. If you know your application root + -- statically, it will be more efficient and more reliable to instead use + -- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute + -- URLs, you can use 'ApprootRelative' instead. -- - -- * Your application is served from the root of the domain. - -- - -- * You do not use any features that require absolute URLs, such as Atom - -- feeds and XML sitemaps. - -- - -- If this is not true, you should override with a different - -- implementation. + -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'. approot :: Approot site - approot = ApprootRelative + approot = guessApproot -- | Output error response pages. -- @@ -103,12 +97,6 @@ class RenderRoute site => Yesod site where ^{pageBody p} |] - -- | Override the rendering function for a particular URL. One use case for - -- this is to offload static hosting to a different domain name to avoid - -- sending cookies. - urlRenderOverride :: site -> Route site -> Maybe Builder - urlRenderOverride _ _ = Nothing - -- | Override the rendering function for a particular URL and query string -- parameters. One use case for this is to offload static hosting to a -- different domain name to avoid sending cookies. @@ -121,15 +109,7 @@ class RenderRoute site => Yesod site where -> Route site -> [(T.Text, T.Text)] -- ^ query string -> Maybe Builder - urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route - where - addParams [] routeBldr = routeBldr - addParams nonEmptyParams routeBldr = - let routeBS = toLazyByteString routeBldr - qsSeparator = if BL8.elem '?' routeBS then "&" else "?" - valueToMaybe t = if t == "" then Nothing else Just t - queryText = map (id *** valueToMaybe) nonEmptyParams - in routeBldr `mappend` qsSeparator `mappend` renderQueryText False queryText + urlParamRenderOverride _ _ _ = Nothing -- | Determine if a request is authorized or not. -- @@ -280,22 +260,11 @@ class RenderRoute site => Yesod site where -- | Should we log the given log source/level combination. -- - -- Default: the 'defaultShouldLog' function. - shouldLog :: site -> LogSource -> LogLevel -> Bool - shouldLog _ = defaultShouldLog - - -- | Should we log the given log source/level combination. - -- - -- Note that this is almost identical to @shouldLog@, except the result - -- lives in @IO@. This allows you to dynamically alter the logging level of - -- your application by having this result depend on, e.g., an @IORef@. - -- - -- The default implementation simply uses @shouldLog@. Future versions of - -- Yesod will remove @shouldLog@ and use this method exclusively. + -- Default: the 'defaultShouldLogIO' function. -- -- Since 1.2.4 shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool - shouldLogIO a b c = return (shouldLog a b c) + shouldLogIO _ = defaultShouldLogIO -- | A Yesod middleware, which will wrap every handler function. This -- allows you to run code before and after a normal handler. @@ -332,7 +301,6 @@ class RenderRoute site => Yesod site where

#{title} ^{body} |] -{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-} -- | Default implementation of 'makeLogger'. Sends to stdout and -- automatically flushes on each write. @@ -369,15 +337,8 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do -- above 'LevelInfo'. -- -- Since 1.4.10 -defaultShouldLog :: LogSource -> LogLevel -> Bool -defaultShouldLog _ level = level >= LevelInfo - --- | A default implementation of 'shouldLogIO' that can be used with --- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'. --- --- Since 1.4.10 defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool -defaultShouldLogIO a b = return $ defaultShouldLog a b +defaultShouldLogIO _ level = return $ level >= LevelInfo -- | Default implementation of 'yesodMiddleware'. Adds the response header -- \"Vary: Accept, Accept-Language\" and performs authorization checks. @@ -871,7 +832,7 @@ loadClientSession key getCachedDate sessionName req = load save date sess' = do -- We should never cache the IV! Be careful! iv <- liftIO CS.randomIV - return [AddCookie def + return [AddCookie defaultSetCookie { setCookieName = sessionName , setCookieValue = encodeClientSession key iv date host sess' , setCookiePath = Just "/" diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index 8a01309a..51b27cd6 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -61,10 +61,9 @@ import Data.Monoid (mempty) #endif import Text.Hamlet (Html) import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -import Data.Conduit (Flush (Chunk), ResumableSource, mapOutput) +import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput) import Control.Monad (liftM) import Control.Monad.Trans.Resource (ResourceT) -import Data.Conduit.Internal (ResumableSource (ResumableSource)) import qualified Data.Conduit.Internal as CI import qualified Data.Aeson as J @@ -122,8 +121,8 @@ instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (Resource instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where toContent src = ContentSource $ mapOutput toFlushBuilder src -instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where - toContent (ResumableSource src) = toContent src +instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where + toContent (CI.SealedConduitT src) = toContent src -- | A class for all data which can be sent in a streaming response. Note that -- for textual data, instances must use UTF-8 encoding. diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 747d40d4..c2a9290d 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -63,6 +63,7 @@ import Yesod.Core.Class.Dispatch import Yesod.Core.Internal.Run import Safe (readMay) import System.Environment (getEnvironment) +import qualified System.Random as Random import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) @@ -78,7 +79,6 @@ import Control.Monad.Logger import Control.Monad (when) import qualified Paths_yesod_core import Data.Version (showVersion) -import qualified System.Random.MWC as MWC -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This function will provide no middlewares; if you want commonly @@ -87,16 +87,18 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application toWaiAppPlain site = do logger <- makeLogger site sb <- makeSessionBackend site - gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires return $ toWaiAppYre YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb - , yreGen = gen + , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } +defaultGen :: IO Int +defaultGen = Random.getStdRandom Random.next + -- | Pure low level function to construct WAI application. Usefull -- when you need not standard way to run your app, or want to embed it -- inside another app. @@ -151,13 +153,12 @@ toWaiApp site = do toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger logger site = do sb <- makeSessionBackend site - gen <- MWC.createSystemRandom getMaxExpires <- getGetMaxExpires let yre = YesodRunnerEnv { yreLogger = logger , yreSite = site , yreSessionBackend = sb - , yreGen = gen + , yreGen = defaultGen , yreGetMaxExpires = getMaxExpires } messageLoggerSource diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 2bd06b93..886c7a07 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -193,13 +193,14 @@ import Control.Applicative ((<$>)) import Data.Monoid (mempty, mappend) #endif import Control.Applicative ((<|>)) +import qualified Data.CaseInsensitive as CI import Control.Exception (evaluate, SomeException, throwIO) import Control.Exception (handle) import Control.Monad (void, liftM, unless) import qualified Control.Monad.Trans.Writer as Writer -import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) +import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import qualified Network.HTTP.Types as H import qualified Network.Wai as W @@ -228,7 +229,7 @@ import Data.Monoid (Endo (..)) import Data.Text (Text) import qualified Network.Wai.Parse as NWP import Text.Shakespeare.I18N (RenderMessage (..)) -import Web.Cookie (SetCookie (..)) +import Web.Cookie (SetCookie (..), defaultSetCookie) import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..)) import Yesod.Core.Internal.Util (formatRFC1123) import Text.Blaze.Html (preEscapedToHtml, toHtml) @@ -250,7 +251,6 @@ import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void) import qualified Yesod.Core.TypeCache as Cache import qualified Data.Word8 as W8 import qualified Data.Foldable as Fold -import Data.Default import Control.Monad.Logger (MonadLogger, logWarnS) type HandlerT site (m :: * -> *) = HandlerFor site @@ -782,7 +782,7 @@ setLanguage = setSession langKey -- -- @since 1.2.0 addHeader :: MonadHandler m => Text -> Text -> m () -addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8 +addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8 -- | Deprecated synonym for addHeader. setHeader :: MonadHandler m => Text -> Text -> m () @@ -800,10 +800,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m () replaceOrAddHeader a b = modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} where - repHeader = Header (encodeUtf8 a) (encodeUtf8 b) + repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b) sameHeaderName :: Header -> Header -> Bool - sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2) + sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2 sameHeaderName _ _ = False replaceIndividualHeader :: [Header] -> [Header] @@ -1457,7 +1457,10 @@ defaultCsrfCookieName = "XSRF-TOKEN" -- -- @since 1.4.14 setCsrfCookie :: MonadHandler m => m () -setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" } +setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie + { setCookieName = defaultCsrfCookieName + , setCookiePath = Just "/" + } -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. -- diff --git a/yesod-core/Yesod/Core/Internal/Request.hs b/yesod-core/Yesod/Core/Internal/Request.hs index 65201b19..b30cf30c 100644 --- a/yesod-core/Yesod/Core/Internal/Request.hs +++ b/yesod-core/Yesod/Core/Internal/Request.hs @@ -35,14 +35,11 @@ import Data.Text.Encoding (decodeUtf8With, decodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import Conduit import Data.Word (Word8, Word64) -import Control.Monad.Trans.Resource (runResourceT, ResourceT) import Control.Exception (throwIO) import Control.Monad ((<=<), liftM) import Yesod.Core.Types import qualified Data.Map as Map import Data.IORef -import qualified System.Random.MWC as MWC -import Control.Monad.Primitive (PrimMonad, PrimState) import qualified Data.Vector.Storable as V import Data.ByteString.Internal (ByteString (PS)) import qualified Data.Word8 as Word8 @@ -74,7 +71,7 @@ parseWaiRequest :: W.Request -> SessionMap -> Bool -> Maybe Word64 -- ^ max body size - -> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest) + -> Either (IO YesodRequest) (IO Int -> IO YesodRequest) parseWaiRequest env session useToken mmaxBodySize = -- In most cases, we won't need to generate any random values. Therefore, -- we split our results: if we need a random generator, return a Right @@ -154,16 +151,21 @@ addTwoLetters (toAdd, exist) (l:ls) = -- | Generate a random String of alphanumerical characters -- (a-z, A-Z, and 0-9) of the given length using the given -- random number generator. -randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text +randomString :: Monad m => Int -> m Int -> m Text randomString len gen = liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar where - asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen - - toAscii i - | i < 26 = i + Word8._A - | i < 52 = i + Word8._a - 26 - | otherwise = i + Word8._0 - 52 + asciiChar = + let loop = do + x <- gen + let y = fromIntegral $ x `mod` 64 + case () of + () + | y < 26 -> return $ y + Word8._A + | y < 52 -> return $ y + Word8._a - 26 + | y < 62 -> return $ y + Word8._0 - 52 + | otherwise -> loop + in loop fromByteVector :: V.Vector Word8 -> ByteString fromByteVector v = @@ -177,10 +179,10 @@ mkFileInfoLBS name ct lbs = FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs) mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo -mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst) +mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst) -mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo -mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) +mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo +mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst) tokenKey :: IsString a => a tokenKey = "_TOKEN" diff --git a/yesod-core/Yesod/Core/Internal/Response.hs b/yesod-core/Yesod/Core/Internal/Response.hs index a4be46bd..abf0cdfa 100644 --- a/yesod-core/Yesod/Core/Internal/Response.hs +++ b/yesod-core/Yesod/Core/Internal/Response.hs @@ -8,7 +8,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as BL import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI import Network.Wai import Control.Monad (mplus) import Control.Monad.Trans.Resource (runInternalState, InternalState) @@ -24,8 +23,7 @@ import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import Yesod.Core.Internal.Request (tokenKey) import Data.Text.Encoding (encodeUtf8) -import Data.Conduit (Flush (..), ($$), transPipe) -import qualified Data.Conduit.List as CL +import Conduit yarToResponse :: YesodResponse -> (SessionMap -> IO [Header]) -- ^ save session @@ -53,9 +51,9 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse sendResponse $ ResponseBuilder s hs' b go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p go (ContentSource body) = sendResponse $ responseStream s finalHeaders - $ \sendChunk flush -> + $ \sendChunk flush -> runConduit $ transPipe (`runInternalState` is) body - $$ CL.mapM_ (\mchunk -> + .| mapM_C (\mchunk -> case mchunk of Flush -> flush Chunk builder -> sendChunk builder) @@ -93,7 +91,7 @@ headerToPair (DeleteCookie key path) = , "; expires=Thu, 01-Jan-1970 00:00:00 GMT" ] ) -headerToPair (Header key value) = (CI.mk key, value) +headerToPair (Header key value) = (key, value) evaluateContent :: Content -> IO (Either ErrorResponse Content) evaluateContent (ContentBuilder b mlen) = handle f $ do diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index a755428f..0fdcaf5c 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -16,8 +16,6 @@ import Control.Applicative ((<$>)) import Yesod.Core.Internal.Response import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BL -import Control.Exception (fromException, evaluate) -import qualified Control.Exception as E import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (LogLevel (LevelError), LogSource, liftLoc) @@ -45,38 +43,21 @@ import Yesod.Core.Internal.Request (parseWaiRequest, import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Routes.Class (Route, renderRoute) import Control.DeepSeq (($!!), NFData) +import UnliftIO.Exception --- | Catch all synchronous exceptions, ignoring asynchronous --- exceptions. --- --- Ideally we'd use this from a different library -catchSync :: IO a -> (E.SomeException -> IO a) -> IO a -catchSync thing after = thing `E.catch` \e -> - if isAsyncException e - then E.throwIO e - else after e - --- | Determine if an exception is asynchronous --- --- Also worth being upstream -isAsyncException :: E.SomeException -> Bool -isAsyncException e = - case fromException e of - Just E.SomeAsyncException{} -> True - Nothing -> False - --- | Convert an exception into an ErrorResponse -toErrorHandler :: E.SomeException -> IO ErrorResponse -toErrorHandler e0 = flip catchSync errFromShow $ +-- | Convert a synchronous exception into an ErrorResponse +toErrorHandler :: SomeException -> IO ErrorResponse +toErrorHandler e0 = handleAny errFromShow $ case fromException e0 of Just (HCError x) -> evaluate $!! x - _ - | isAsyncException e0 -> E.throwIO e0 - | otherwise -> errFromShow e0 + _ -> errFromShow e0 -- | Generate an @ErrorResponse@ based on the shown version of the exception -errFromShow :: E.SomeException -> IO ErrorResponse -errFromShow x = evaluate $!! InternalError $! T.pack $! show x +errFromShow :: SomeException -> IO ErrorResponse +errFromShow x = do + text <- evaluate (T.pack $ show x) `catchAny` \_ -> + return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception") + return $ InternalError text -- | Do a basic run of a handler, getting some contents and the final -- @GHState@. The @GHState@ unfortunately may contain some impure @@ -95,7 +76,7 @@ basicRunHandler rhe handler yreq resState = do -- Run the handler itself, capturing any runtime exceptions and -- converting them into a @HandlerContents@ - contents' <- catchSync + contents' <- catchAny (do res <- unHandlerFor handler (hd istate) tc <- evaluate (toTypedContent res) @@ -135,7 +116,7 @@ handleError :: RunHandlerEnv site -> IO YesodResponse handleError rhe yreq resState finalSession headers e0 = do -- Find any evil hidden impure exceptions - e <- (evaluate $!! e0) `catchSync` errFromShow + e <- (evaluate $!! e0) `catchAny` errFromShow -- Generate a response, leveraging the updated session and -- response headers @@ -200,7 +181,7 @@ evalFallback :: (Monoid w, NFData w) => HandlerContents -> w -> IO (w, HandlerContents) -evalFallback contents val = catchSync +evalFallback contents val = catchAny (fmap (, contents) (evaluate $!! val)) (fmap ((mempty, ) . HCError) . toErrorHandler) @@ -218,13 +199,14 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState - -- propagating exceptions into the contents (finalSession, contents1) <- evalFallback contents0 (ghsSession state) (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) + contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler) -- Convert the HandlerContents into the final YesodResponse handleContents (handleError rhe yreq resState finalSession headers) finalSession headers - contents2 + contents3 safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> ErrorResponse diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index a3936603..51d9bbe8 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -25,6 +25,7 @@ import Control.Monad.Logger (LogLevel, LogSource, import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive (CI) import Data.Conduit (Flush, ConduitT) import Data.IORef (IORef, modifyIORef') import Data.Map (Map, unionWith) @@ -46,7 +47,6 @@ import Network.Wai (FilePart, import qualified Network.Wai as W import qualified Network.Wai.Parse as NWP import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr) -import qualified System.Random.MWC as MWC import Network.Wai.Logger (DateCacheGetter) import Text.Blaze.Html (Html, toHtml) import Text.Hamlet (HtmlUrl) @@ -61,7 +61,7 @@ import Control.DeepSeq.Generics (genericRnf) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Control.Monad.Logger (MonadLoggerIO (..)) import Data.Semigroup (Semigroup) -import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..)) +import UnliftIO (MonadUnliftIO (..), UnliftIO (..)) -- Sessions type SessionMap = Map Text ByteString @@ -74,7 +74,7 @@ newtype SessionBackend = SessionBackend -> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session } -data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap +data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap deriving (Show, Read) instance Serialize SessionCookie where put (SessionCookie a b c) = do @@ -152,13 +152,13 @@ data Approot master = ApprootRelative -- ^ No application root. type ResolvedApproot = Text -data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text +data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text deriving (Eq, Show, Read) data ScriptLoadPosition master = BottomOfBody | BottomOfHeadBlocking - | BottomOfHeadAsync (BottomOfHeadAsync master) + | BottomOfHeadAsync !(BottomOfHeadAsync master) type BottomOfHeadAsync master = [Text] -- ^ urls to load asynchronously @@ -171,7 +171,7 @@ type Texts = [Text] newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } -- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized. --- +-- -- @since 1.4.34 newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } @@ -199,8 +199,9 @@ data YesodRunnerEnv site = YesodRunnerEnv { yreLogger :: !Logger , yreSite :: !site , yreSessionBackend :: !(Maybe SessionBackend) - , yreGen :: !MWC.GenIO - , yreGetMaxExpires :: IO Text + , yreGen :: !(IO Int) + -- ^ Generate a random number + , yreGetMaxExpires :: !(IO Text) } data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv @@ -225,11 +226,11 @@ newtype HandlerFor site a = HandlerFor data GHState = GHState { ghsSession :: !SessionMap - , ghsRBC :: Maybe RequestBodyContents - , ghsIdent :: Int - , ghsCache :: TypeMap - , ghsCacheBy :: KeyedTypeMap - , ghsHeaders :: Endo [Header] + , ghsRBC :: !(Maybe RequestBodyContents) + , ghsIdent :: !Int + , ghsCache :: !TypeMap + , ghsCacheBy :: !KeyedTypeMap + , ghsHeaders :: !(Endo [Header]) } -- | An extension of the basic WAI 'W.Application' datatype to provide extra @@ -283,9 +284,9 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder } -- -- > PageContent url -> HtmlUrl url data PageContent url = PageContent - { pageTitle :: Html - , pageHead :: HtmlUrl url - , pageBody :: HtmlUrl url + { pageTitle :: !Html + , pageHead :: !(HtmlUrl url) + , pageBody :: !(HtmlUrl url) } data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. @@ -312,11 +313,11 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a } -- | Responses to indicate some form of an error occurred. data ErrorResponse = NotFound - | InternalError Text - | InvalidArgs [Text] + | InternalError !Text + | InvalidArgs ![Text] | NotAuthenticated - | PermissionDenied Text - | BadMethod H.Method + | PermissionDenied !Text + | BadMethod !H.Method deriving (Show, Eq, Typeable, Generic) instance NFData ErrorResponse where rnf = genericRnf @@ -324,9 +325,11 @@ instance NFData ErrorResponse where ----- header stuff -- | Headers to be added to a 'Result'. data Header = - AddCookie SetCookie - | DeleteCookie ByteString ByteString - | Header ByteString ByteString + AddCookie !SetCookie + | DeleteCookie !ByteString !ByteString + -- ^ name and path + | Header !(CI ByteString) !ByteString + -- ^ key and value deriving (Eq, Show) -- FIXME In the next major version bump, let's just add strictness annotations @@ -337,16 +340,16 @@ instance NFData Header where rnf (DeleteCookie x y) = x `seq` y `seq` () rnf (Header x y) = x `seq` y `seq` () -data Location url = Local url | Remote Text +data Location url = Local !url | Remote !Text deriving (Show, Eq) -- | A diff list that does not directly enforce uniqueness. -- When creating a widget Yesod will use nub to make it unique. newtype UniqueList x = UniqueList ([x] -> [x]) -data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] } +data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] } deriving (Show, Eq) -data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] } +data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] } deriving (Show, Eq) newtype Title = Title { unTitle :: Html } @@ -382,13 +385,13 @@ instance Monoid (GWData a) where instance Semigroup (GWData a) data HandlerContents = - HCContent H.Status !TypedContent - | HCError ErrorResponse - | HCSendFile ContentType FilePath (Maybe FilePart) - | HCRedirect H.Status Text - | HCCreated Text - | HCWai W.Response - | HCWaiApp W.Application + HCContent !H.Status !TypedContent + | HCError !ErrorResponse + | HCSendFile !ContentType !FilePath !(Maybe FilePart) + | HCRedirect !H.Status !Text + | HCCreated !Text + | HCWai !W.Response + | HCWaiApp !W.Application deriving Typeable instance Show HandlerContents where diff --git a/yesod-core/bench/widget.hs b/yesod-core/bench/widget.hs index fd210cbe..51d519e8 100644 --- a/yesod-core/bench/widget.hs +++ b/yesod-core/bench/widget.hs @@ -5,22 +5,20 @@ {-# LANGUAGE QuasiQuotes #-} module Main where -import Criterion.Main +import Gauge.Main import Text.Hamlet 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 Yesod.Core.Types import Data.Int main :: IO () main = defaultMain [ bench "bigTable html" $ nf bigTableHtml bigTableData , bench "bigTable hamlet" $ nf bigTableHamlet bigTableData - , bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) + --, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData) , bench "bigTable blaze" $ nf bigTableBlaze bigTableData ] where @@ -49,6 +47,7 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet| #{show cell} |] + {- bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| @@ -62,6 +61,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml run (WidgetT w) = do (_, GWData { gwdBody = Body x }) <- w undefined return x + -} bigTableBlaze :: Show a => [[a]] -> Int64 bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t diff --git a/yesod-core/test/YesodCoreTest/InternalRequest.hs b/yesod-core/test/YesodCoreTest/InternalRequest.hs index 314a08ff..f0613866 100644 --- a/yesod-core/test/YesodCoreTest/InternalRequest.hs +++ b/yesod-core/test/YesodCoreTest/InternalRequest.hs @@ -10,9 +10,11 @@ import Data.Map (singleton) import Yesod.Core import Data.Word (Word64) import System.IO.Unsafe (unsafePerformIO) -import qualified System.Random.MWC as MWC -import Control.Monad.ST import Control.Monad (replicateM) +import System.Random + +gen :: IO Int +gen = getStdRandom next randomStringSpecs :: Spec randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do @@ -21,21 +23,19 @@ randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do -- NOTE: this testcase may break on other systems/architectures if -- mkStdGen is not identical everywhere (is it?). -_looksRandom :: Bool -_looksRandom = runST $ do - gen <- MWC.create +_looksRandom :: IO () +_looksRandom = do s <- randomString 20 gen - return $ s == "VH9SkhtptqPs6GqtofVg" + s `shouldBe` "VH9SkhtptqPs6GqtofVg" -noRepeat :: Int -> Int -> Bool -noRepeat len n = runST $ do - gen <- MWC.create +noRepeat :: Int -> Int -> IO () +noRepeat len n = do ss <- replicateM n $ randomString len gen - return $ length (nub ss) == n + length (nub ss) `shouldBe` n -- For convenience instead of "(undefined :: StdGen)". -g :: MWC.GenIO +g :: IO Int g = error "test/YesodCoreTest/InternalRequest.g" parseWaiRequest' :: Request diff --git a/yesod-core/test/YesodCoreTest/RawResponse.hs b/yesod-core/test/YesodCoreTest/RawResponse.hs index 79f69900..60b28807 100644 --- a/yesod-core/test/YesodCoreTest/RawResponse.hs +++ b/yesod-core/test/YesodCoreTest/RawResponse.hs @@ -39,8 +39,8 @@ getHomeR = do _ <- register $ writeIORef ref 1 sendRawResponse $ \src sink -> liftIO $ do val <- readIORef ref - yield (S8.pack $ show val) $$ sink - src $$ CL.map (S8.map toUpper) =$ sink + runConduit $ yield (S8.pack $ show val) .| sink + runConduit $ src .| CL.map (S8.map toUpper) .| sink getWaiStreamR :: Handler () getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do @@ -76,18 +76,18 @@ specs = do withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do - yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad - (appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") - yield "WORLd" $$ appSink ad - (appSource ad $$ await) >>= (`shouldBe` Just "WORLD") + runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad + runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO") + runConduit $ yield "WORLd" .| appSink ad + runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD") let body req = do port <- getFreePort withAsync (warp port App) $ \_ -> do threadDelay 100000 runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do - yield req $$ appSink ad - appSource ad $$ CB.lines =$ do + runConduit $ yield req .| appSink ad + runConduit $ appSource ad .| CB.lines .| do let loop = do x <- await case x of diff --git a/yesod-core/test/YesodCoreTest/RequestBodySize.hs b/yesod-core/test/YesodCoreTest/RequestBodySize.hs index 9926b42e..ac7c696f 100644 --- a/yesod-core/test/YesodCoreTest/RequestBodySize.hs +++ b/yesod-core/test/YesodCoreTest/RequestBodySize.hs @@ -42,11 +42,11 @@ postPostR = do return $ RepPlain $ toContent $ T.concat val postConsumeR = do - body <- rawRequestBody $$ consume + body <- runConduit $ rawRequestBody .| consume return $ RepPlain $ toContent $ S.concat body postPartialConsumeR = do - body <- rawRequestBody $$ isolate 5 =$ consume + body <- runConduit $ rawRequestBody .| isolate 5 .| consume return $ RepPlain $ toContent $ S.concat body postUnusedR = return $ RepPlain "" diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index bf61c3d6..e4bec214 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.38 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -52,22 +52,18 @@ library , resourcet >= 1.2 , blaze-html >= 0.5 , blaze-markup >= 0.7.1 - -- FIXME remove! - , data-default , safe , warp >= 3.0.2 , unix-compat , conduit-extra , deepseq >= 1.3 , deepseq-generics - -- FIXME remove - , mwc-random , primitive , word8 , auto-update , semigroups , byteable - , unliftio-core + , unliftio exposed-modules: Yesod.Core Yesod.Core.Content @@ -199,7 +195,6 @@ test-suite tests , shakespeare , streaming-commons , wai-extra - , mwc-random , cookie >= 0.4.1 && < 0.5 , unliftio ghc-options: -Wall @@ -209,7 +204,7 @@ benchmark widgets type: exitcode-stdio-1.0 hs-source-dirs: bench build-depends: base - , criterion + , gauge , bytestring , text , transformers diff --git a/yesod-eventsource/ChangeLog.md b/yesod-eventsource/ChangeLog.md index f7658231..a5b12741 100644 --- a/yesod-eventsource/ChangeLog.md +++ b/yesod-eventsource/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.1 * Fix warnings diff --git a/yesod-eventsource/Yesod/EventSource.hs b/yesod-eventsource/Yesod/EventSource.hs index f0918034..21310b19 100644 --- a/yesod-eventsource/Yesod/EventSource.hs +++ b/yesod-eventsource/Yesod/EventSource.hs @@ -13,7 +13,7 @@ import Control.Monad (when) import Data.Functor ((<$>)) import Data.Monoid (Monoid (..)) import Yesod.Core -import qualified Data.Conduit as C +import Data.Conduit import qualified Network.Wai as W import qualified Network.Wai.EventSource as ES import qualified Network.Wai.EventSource.EventStream as ES @@ -32,32 +32,35 @@ prepareForEventSource = do -- | (Internal) Source with a event stream content-type. -respondEventStream :: C.Source (HandlerT site IO) (C.Flush Builder) - -> HandlerT site IO TypedContent +respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) () + -> HandlerFor site TypedContent respondEventStream = respondSource "text/event-stream" --- | Returns a Server-Sent Event stream from a 'C.Source' of +-- | Returns a Server-Sent Event stream from a 'Source' of -- 'ES.ServerEvent'@s@. The HTTP socket is flushed after every --- event. The connection is closed either when the 'C.Source' +-- event. The connection is closed either when the 'Source' -- finishes outputting data or a 'ES.CloseEvent' is outputted, -- whichever comes first. -repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerEvent) - -> HandlerT site IO TypedContent +repEventSource :: (EventSourcePolyfill -> ConduitT () ES.ServerEvent (HandlerFor site) ()) + -> HandlerFor site TypedContent repEventSource src = prepareForEventSource >>= respondEventStream . sourceToSource . src -- | Convert a ServerEvent source into a Builder source of serialized -- events. -sourceToSource :: Monad m => C.Source m ES.ServerEvent -> C.Source m (C.Flush Builder) +sourceToSource + :: Monad m + => ConduitT () ES.ServerEvent m () + -> ConduitT () (Flush Builder) m () sourceToSource src = - src C.$= C.awaitForever eventToFlushBuilder + src .| awaitForever eventToFlushBuilder where eventToFlushBuilder event = case ES.eventToBuilder event of Nothing -> return () - Just x -> C.yield (C.Chunk x) >> C.yield C.Flush + Just x -> yield (Chunk x) >> yield Flush -- | Return a Server-Sent Event stream given a 'HandlerT' action @@ -68,8 +71,8 @@ sourceToSource src = -- The connection is closed as soon as an 'ES.CloseEvent' is -- outputted, after which no other events are sent to the client. pollingEventSource :: s - -> (EventSourcePolyfill -> s -> HandlerT site IO ([ES.ServerEvent], s)) - -> HandlerT site IO TypedContent + -> (EventSourcePolyfill -> s -> HandlerFor site ([ES.ServerEvent], s)) + -> HandlerFor site TypedContent pollingEventSource initial act = do polyfill <- prepareForEventSource let -- Get new events to be sent. @@ -79,8 +82,8 @@ pollingEventSource initial act = do [] -> getEvents s' _ -> do let (builder, continue) = joinEvents evs mempty - C.yield (C.Chunk builder) - C.yield C.Flush + yield (Chunk builder) + yield Flush when continue (getEvents s') -- Join all events in a single Builder. Returns @False@ @@ -103,7 +106,7 @@ pollingEventSource initial act = do -- outputted, after which no other events are sent to the client. ioToRepEventSource :: s -> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s)) - -> HandlerT site IO TypedContent + -> HandlerFor site TypedContent ioToRepEventSource initial act = pollingEventSource initial act' where act' p s = liftIO (act p s) diff --git a/yesod-eventsource/yesod-eventsource.cabal b/yesod-eventsource/yesod-eventsource.cabal index db77ea47..7105ca77 100644 --- a/yesod-eventsource/yesod-eventsource.cabal +++ b/yesod-eventsource/yesod-eventsource.cabal @@ -1,5 +1,5 @@ name: yesod-eventsource -version: 1.4.1 +version: 1.6.0 license: MIT license-file: LICENSE author: Felipe Lessa @@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md library build-depends: base >= 4 && < 5 - , yesod-core == 1.4.* + , yesod-core == 1.6.* , conduit >= 1.3 , wai >= 1.3 , wai-eventsource >= 1.3 diff --git a/yesod-form/ChangeLog.md b/yesod-form/ChangeLog.md index a941f21a..9af79a52 100644 --- a/yesod-form/ChangeLog.md +++ b/yesod-form/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.16 * Korean translation diff --git a/yesod-form/Yesod/Form/Bootstrap3.hs b/yesod-form/Yesod/Form/Bootstrap3.hs index a1963c1b..5d2a4ffb 100644 --- a/yesod-form/Yesod/Form/Bootstrap3.hs +++ b/yesod-form/Yesod/Form/Bootstrap3.hs @@ -186,7 +186,7 @@ renderBootstrap3 formLayout aform fragment = do -- | (Internal) Render a help widget for tooltips and errors. -helpWidget :: FieldView site -> WidgetT site IO () +helpWidget :: FieldView site -> WidgetFor site () helpWidget view = [whamlet| $maybe tt <- fvTooltip view #{tt} diff --git a/yesod-form/Yesod/Form/Fields.hs b/yesod-form/Yesod/Form/Fields.hs index 05b4574d..a79d75cb 100644 --- a/yesod-form/Yesod/Form/Fields.hs +++ b/yesod-form/Yesod/Form/Fields.hs @@ -161,10 +161,9 @@ $newline never } where showVal = either id (pack . show) --- | An alias for 'timeFieldTypeText'. +-- | An alias for 'timeFieldTypeTime'. timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay -timeField = timeFieldTypeText -{-# DEPRECATED timeField "'timeField' currently defaults to an input of type=\"text\". In the next major release, it will default to type=\"time\". To opt in to the new functionality, use 'timeFieldTypeTime'. To keep the existing behavior, use 'timeFieldTypeText'. See 'https://github.com/yesodweb/yesod/pull/874' for details." #-} +timeField = timeFieldTypeTime -- | Creates an input with @type="time"@. will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'. -- @@ -175,6 +174,8 @@ timeFieldTypeTime :: Monad m => RenderMessage (HandlerSite m) FormMessage => Fie timeFieldTypeTime = timeFieldOfType "time" -- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system). +-- +-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser. -- -- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function. -- @@ -420,15 +421,15 @@ urlField = Field -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) => [(msg, a)] - -> Field (HandlerT site IO) a + -> Field (HandlerFor site) a selectFieldList = selectField . optionsPairs -- | Creates a @\@ tag for selecting multiple options. multiSelectFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)] - -> Field (HandlerT site IO) [a] + -> Field (HandlerFor site) [a] multiSelectFieldList = multiSelectField . optionsPairs -- | Creates a @\. let fragment' = @@ -418,7 +418,7 @@ identifyFormKey = "_formid" type FormRender m a = AForm m a -> Html - -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) + -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()) renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a -- | Render a form into a series of tr tags. Note that, in order to allow diff --git a/yesod-form/Yesod/Form/Jquery.hs b/yesod-form/Yesod/Form/Jquery.hs index a5a2bfce..05ca51bb 100644 --- a/yesod-form/Yesod/Form/Jquery.hs +++ b/yesod-form/Yesod/Form/Jquery.hs @@ -53,16 +53,16 @@ class YesodJquery a where urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" -jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day +jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day jqueryDayField = flip jqueryDayField' "date" -- | Use jQuery's datepicker as the underlying implementation. -- -- Since 1.4.3 -jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day +jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day jqueryDatePickerDayField = flip jqueryDayField' "text" -jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerT site IO) Day +jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day jqueryDayField' jds inputType = Field { fieldParse = parseHelper $ maybe (Left MsgInvalidDay) @@ -107,13 +107,13 @@ $(function(){ ] jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) - => Route site -> Field (HandlerT site IO) Text + => Route site -> Field (HandlerFor site) Text jqueryAutocompleteField = jqueryAutocompleteField' 2 jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site) => Int -- ^ autocomplete minimum length -> Route site - -> Field (HandlerT site IO) Text + -> Field (HandlerFor site) Text jqueryAutocompleteField' minLen src = Field { fieldParse = parseHelper $ Right , fieldView = \theId name attrs val isReq -> do diff --git a/yesod-form/Yesod/Form/MassInput.hs b/yesod-form/Yesod/Form/MassInput.hs index e794ff27..edc977ad 100644 --- a/yesod-form/Yesod/Form/MassInput.hs +++ b/yesod-form/Yesod/Form/MassInput.hs @@ -44,17 +44,17 @@ up i = do -- | Generate a form that accepts 0 or more values from the user, allowing the -- user to specify that a new row is necessary. -inputList :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage) +inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage) => Html -- ^ label for the form -> ([[FieldView site]] -> xml) -- ^ how to display the rows, usually either 'massDivs' or 'massTable' - -> (Maybe a -> AForm (HandlerT site IO) a) + -> (Maybe a -> AForm (HandlerFor site) a) -- ^ display a single row of the form, where @Maybe a@ gives the -- previously submitted value -> Maybe [a] -- ^ default initial values for the form - -> AForm (HandlerT site IO) [a] + -> AForm (HandlerFor site) [a] inputList label fixXml single mdef = formToAForm $ do theId <- lift newIdent down 1 @@ -94,9 +94,9 @@ $newline never , fvRequired = False }]) -withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage) - => AForm (HandlerT site IO) a - -> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site])) +withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage) + => AForm (HandlerFor site) a + -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site])) withDelete af = do down 1 deleteName <- newFormIdent @@ -129,7 +129,7 @@ fixme eithers = massDivs, massTable :: [[FieldView site]] - -> WidgetT site IO () + -> WidgetFor site () massDivs viewss = [whamlet| $newline never $forall views <- viewss diff --git a/yesod-form/Yesod/Form/Nic.hs b/yesod-form/Yesod/Form/Nic.hs index 10057c0c..71b242ec 100644 --- a/yesod-form/Yesod/Form/Nic.hs +++ b/yesod-form/Yesod/Form/Nic.hs @@ -29,7 +29,7 @@ class Yesod a => YesodNic a where urlNicEdit :: a -> Either (Route a) Text urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" -nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html +nicHtmlField :: YesodNic site => Field (HandlerFor site) Html nicHtmlField = Field { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e , fieldView = \theId name attrs val _isReq -> do diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index 1aabcc68..bd4e91df 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -189,7 +189,7 @@ data FieldView site = FieldView { fvLabel :: Html , fvTooltip :: Maybe Html , fvId :: Text - , fvInput :: WidgetT site IO () + , fvInput :: WidgetFor site () , fvErrors :: Maybe Html , fvRequired :: Bool } @@ -200,7 +200,7 @@ type FieldViewFunc m a -> [(Text, Text)] -- ^ Attributes -> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Bool -- ^ Required? - -> WidgetT (HandlerSite m) IO () + -> WidgetFor (HandlerSite m) () data Field m a = Field { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)) diff --git a/yesod-form/yesod-form.cabal b/yesod-form/yesod-form.cabal index 4f252938..aa54488a 100644 --- a/yesod-form/yesod-form.cabal +++ b/yesod-form/yesod-form.cabal @@ -1,5 +1,5 @@ name: yesod-form -version: 1.4.16 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -20,8 +20,8 @@ flag network-uri library build-depends: base >= 4 && < 5 - , yesod-core >= 1.4.14 && < 1.5 - , yesod-persistent >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 + , yesod-persistent >= 1.6 && < 1.7 , time >= 1.1.4 , shakespeare >= 2.0 , persistent diff --git a/yesod-newsfeed/ChangeLog.md b/yesod-newsfeed/ChangeLog.md index eaaf8753..fb70d46b 100644 --- a/yesod-newsfeed/ChangeLog.md +++ b/yesod-newsfeed/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog +## 1.6.1 + +* Upgrade to yesod-core 1.6.0 + ## 1.6 * Create new datatype `EntryEnclosure` for self-documentation of `feedEntryEnclosure`. diff --git a/yesod-newsfeed/yesod-newsfeed.cabal b/yesod-newsfeed/yesod-newsfeed.cabal index b8d57c7d..cc4b9e6b 100644 --- a/yesod-newsfeed/yesod-newsfeed.cabal +++ b/yesod-newsfeed/yesod-newsfeed.cabal @@ -1,5 +1,5 @@ name: yesod-newsfeed -version: 1.6 +version: 1.6.1.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md library build-depends: base >= 4 && < 5 - , yesod-core >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 , time >= 1.1.4 , shakespeare >= 2.0 , bytestring >= 0.9.1.4 diff --git a/yesod-persistent/ChangeLog.md b/yesod-persistent/ChangeLog.md index a7343ed8..1cda90f9 100644 --- a/yesod-persistent/ChangeLog.md +++ b/yesod-persistent/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.3 * Fix overly powerful constraints on get404 and getBy404. diff --git a/yesod-persistent/Yesod/Persist/Core.hs b/yesod-persistent/Yesod/Persist/Core.hs index 3f99833f..6e81d848 100644 --- a/yesod-persistent/Yesod/Persist/Core.hs +++ b/yesod-persistent/Yesod/Persist/Core.hs @@ -37,11 +37,11 @@ import qualified Database.Persist.Sql as SQL unSqlPersistT :: a -> a unSqlPersistT = id -type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO) +type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site) class Monad (YesodDB site) => YesodPersist site where type YesodPersistBackend site - runDB :: YesodDB site a -> HandlerT site IO a + runDB :: YesodDB site a -> HandlerFor site a -- | Helper for creating 'runDB'. -- @@ -49,8 +49,8 @@ class Monad (YesodDB site) => YesodPersist site where defaultRunDB :: PersistConfig c => (site -> c) -> (site -> PersistConfigPool c) - -> PersistConfigBackend c (HandlerT site IO) a - -> HandlerT site IO a + -> PersistConfigBackend c (HandlerFor site) a + -> HandlerFor site a defaultRunDB getConfig getPool f = do master <- getYesod Database.Persist.runPool @@ -74,10 +74,10 @@ class YesodPersist site => YesodPersistRunner site where -- least, a rollback will be used instead. -- -- Since 1.2.0 - getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ()) + getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ()) newtype DBRunner site = DBRunner - { runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a + { runDBRunner :: forall a. YesodDB site a -> HandlerFor site a } -- | Helper for implementing 'getDBRunner'. @@ -86,11 +86,11 @@ newtype DBRunner site = DBRunner #if MIN_VERSION_persistent(2,5,0) defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend) => (site -> Pool backend) - -> HandlerT site IO (DBRunner site, HandlerT site IO ()) + -> HandlerFor site (DBRunner site, HandlerFor site ()) #else defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend => (site -> Pool SQL.SqlBackend) - -> HandlerT site IO (DBRunner site, HandlerT site IO ()) + -> HandlerFor site (DBRunner site, HandlerFor site ()) #endif defaultGetDBRunner getPool = do pool <- fmap getPool getYesod @@ -118,8 +118,8 @@ defaultGetDBRunner getPool = do -- -- Since 1.2.0 runDBSource :: YesodPersistRunner site - => Source (YesodDB site) a - -> Source (HandlerT site IO) a + => ConduitT () a (YesodDB site) () + -> ConduitT () a (HandlerFor site) () runDBSource src = do (dbrunner, cleanup) <- lift getDBRunner transPipe (runDBRunner dbrunner) src @@ -128,8 +128,8 @@ runDBSource src = do -- | Extends 'respondSource' to create a streaming database response body. respondSourceDB :: YesodPersistRunner site => ContentType - -> Source (YesodDB site) (Flush Builder) - -> HandlerT site IO TypedContent + -> ConduitT () (Flush Builder) (YesodDB site) () + -> HandlerFor site TypedContent respondSourceDB ctype = respondSource ctype . runDBSource -- | Get the given entity by ID, or return a 404 not found if it doesn't exist. diff --git a/yesod-persistent/test/Yesod/PersistSpec.hs b/yesod-persistent/test/Yesod/PersistSpec.hs index fa6a4986..13356553 100644 --- a/yesod-persistent/test/Yesod/PersistSpec.hs +++ b/yesod-persistent/test/Yesod/PersistSpec.hs @@ -45,7 +45,7 @@ getHomeR = do insert_ $ Person "Charlie" insert_ $ Person "Alice" insert_ $ Person "Bob" - respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder + respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder where toBuilder (Entity _ (Person name)) = do yield $ Chunk $ fromText name diff --git a/yesod-persistent/yesod-persistent.cabal b/yesod-persistent/yesod-persistent.cabal index a2c255dd..353fac6e 100644 --- a/yesod-persistent/yesod-persistent.cabal +++ b/yesod-persistent/yesod-persistent.cabal @@ -1,5 +1,5 @@ name: yesod-persistent -version: 1.4.3 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md library build-depends: base >= 4 && < 5 - , yesod-core >= 1.4.0 && < 1.5 - , persistent >= 2.1 && < 2.8 + , yesod-core >= 1.6 && < 1.7 + , persistent >= 2.8 && < 2.9 , persistent-template >= 2.1 && < 2.8 , transformers >= 0.2.2 , blaze-builder diff --git a/yesod-sitemap/ChangeLog.md b/yesod-sitemap/ChangeLog.md index e69de29b..646e7378 100644 --- a/yesod-sitemap/ChangeLog.md +++ b/yesod-sitemap/ChangeLog.md @@ -0,0 +1,3 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 diff --git a/yesod-sitemap/Yesod/Sitemap.hs b/yesod-sitemap/Yesod/Sitemap.hs index 308164f8..6b6a407f 100644 --- a/yesod-sitemap/Yesod/Sitemap.hs +++ b/yesod-sitemap/Yesod/Sitemap.hs @@ -74,19 +74,19 @@ robots smurl = do -- | Serve a stream of @SitemapUrl@s as a sitemap. -- -- Since 1.2.0 -sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site)) - -> HandlerT site IO TypedContent +sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) () + -> HandlerFor site TypedContent sitemap urls = do render <- getUrlRender respondSource typeXml $ do yield Flush - urls $= sitemapConduit render $= renderBuilder def $= CL.map Chunk + urls .| sitemapConduit render .| renderBuilder def .| CL.map Chunk -- | Convenience wrapper for @sitemap@ for the case when the input is an -- in-memory list. -- -- Since 1.2.0 -sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent +sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent sitemapList = sitemap . mapM_ yield -- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL @@ -97,7 +97,7 @@ sitemapList = sitemap . mapM_ yield -- Since 1.2.0 sitemapConduit :: Monad m => (a -> Text) - -> Conduit (SitemapUrl a) m Event + -> ConduitT (SitemapUrl a) Event m () sitemapConduit render = do yield EventBeginDocument element "urlset" [] $ awaitForever goUrl diff --git a/yesod-sitemap/yesod-sitemap.cabal b/yesod-sitemap/yesod-sitemap.cabal index 511a21b7..b88a7546 100644 --- a/yesod-sitemap/yesod-sitemap.cabal +++ b/yesod-sitemap/yesod-sitemap.cabal @@ -1,5 +1,5 @@ name: yesod-sitemap -version: 1.4.0.1 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md library build-depends: base >= 4 && < 5 - , yesod-core >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 , time >= 1.1.4 , xml-conduit >= 1.0 , text diff --git a/yesod-static/ChangeLog.md b/yesod-static/ChangeLog.md index fdb162a8..0e30e941 100644 --- a/yesod-static/ChangeLog.md +++ b/yesod-static/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.5.3.1 * Switch to cryptonite diff --git a/yesod-static/Yesod/EmbeddedStatic.hs b/yesod-static/Yesod/EmbeddedStatic.hs index 7b005c80..1fe446df 100644 --- a/yesod-static/Yesod/EmbeddedStatic.hs +++ b/yesod-static/Yesod/EmbeddedStatic.hs @@ -57,10 +57,7 @@ import Network.HTTP.Types.Status (status404) import Network.Wai (responseLBS, pathInfo) import Network.Wai.Application.Static (staticApp) import System.IO.Unsafe (unsafePerformIO) -import Yesod.Core - ( HandlerT - , YesodSubDispatch(..) - ) +import Yesod.Core (YesodSubDispatch(..)) import Yesod.Core.Types ( YesodSubRunnerEnv(..) , YesodRunnerEnv(..) diff --git a/yesod-static/Yesod/EmbeddedStatic/Internal.hs b/yesod-static/Yesod/EmbeddedStatic/Internal.hs index 9e778bea..cd643d2a 100644 --- a/yesod-static/Yesod/EmbeddedStatic/Internal.hs +++ b/yesod-static/Yesod/EmbeddedStatic/Internal.hs @@ -25,7 +25,7 @@ import Network.Wai import Network.Wai.Application.Static (defaultWebAppSettings, staticApp) import WaiAppStatic.Types import Yesod.Core - ( HandlerT + ( HandlerFor , ParseRoute(..) , RenderRoute(..) , getYesod @@ -136,7 +136,7 @@ develApp settings extra req sendResponse = do -- | The type of 'addStaticContent' type AddStaticContent site = T.Text -> T.Text -> BL.ByteString - -> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)]))) + -> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)]))) -- | Helper for embedStaticContent and embedLicensedStaticContent. staticContentHelper :: (site -> EmbeddedStatic) diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 7c250b88..e426f62d 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -68,7 +68,6 @@ import qualified System.FilePath as FP import Control.Monad import Data.FileEmbed (embedDir) -import Control.Monad.Trans.Resource (runResourceT) import Yesod.Core import Yesod.Core.Types @@ -94,7 +93,6 @@ import qualified Data.ByteString as S import System.PosixCompat.Files (getFileStatus, modificationTime) import System.Posix.Types (EpochTime) import Conduit -import Data.Functor.Identity (runIdentity) import System.FilePath ((), (<.>), takeDirectory) import qualified System.FilePath as F import qualified Data.Text.Lazy as TL diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal index 8ddf0dbc..e5135d05 100644 --- a/yesod-static/yesod-static.cabal +++ b/yesod-static/yesod-static.cabal @@ -1,5 +1,5 @@ name: yesod-static -version: 1.5.3.1 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -29,7 +29,7 @@ library build-depends: base >= 4 && < 5 , containers >= 0.2 , old-time >= 1.0 - , yesod-core >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 , base64-bytestring >= 0.1.0.1 , byteable >= 0.1 , bytestring >= 0.9.1.4 @@ -91,7 +91,7 @@ test-suite tests YesodStaticTest build-depends: base , hspec >= 1.3 - , yesod-test >= 1.4 + , yesod-test >= 1.6 , wai-extra , HUnit diff --git a/yesod-test/ChangeLog.md b/yesod-test/ChangeLog.md index 1ce26713..07c308ef 100644 --- a/yesod-test/ChangeLog.md +++ b/yesod-test/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.5.9.1 * Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473) diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index f6c13a40..977e838a 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -6,6 +6,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-| Yesod.Test is a pragmatic framework for testing web applications built @@ -63,6 +64,7 @@ module Yesod.Test , addFile , setRequestBody , RequestBuilder + , SIO , setUrl , clickOn @@ -136,6 +138,7 @@ import Data.CaseInsensitive (CI) import Network.Wai import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import Control.Monad.Trans.Reader (ReaderT (..)) +import Conduit (MonadThrow) import Control.Monad.IO.Class import System.IO import Yesod.Core.Unsafe (runFakeHandler) @@ -181,7 +184,7 @@ data YesodExampleData site = YesodExampleData -- | A single test case, to be run with 'yit'. -- -- Since 1.2.0 -type YesodExample site = ReaderT (IORef (YesodExampleData site)) IO +type YesodExample site = SIO (YesodExampleData site) -- | Mapping from cookie name to value. -- @@ -204,13 +207,13 @@ data YesodSpecTree site -- -- Since 1.2.0 getTestYesod :: YesodExample site site -getTestYesod = fmap yedSite getState +getTestYesod = fmap yedSite getSIO -- | Get the most recently provided response value, if available. -- -- Since 1.2.0 getResponse :: YesodExample site (Maybe SResponse) -getResponse = fmap yedResponse getState +getResponse = fmap yedResponse getSIO data RequestBuilderData site = RequestBuilderData { rbdPostData :: RBDPostData @@ -233,7 +236,7 @@ data RequestPart -- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments -- to send with your requests. Some of the functions that run on it use the current -- response to analyze the forms that the server is expecting to receive. -type RequestBuilder site = ReaderT (IORef (RequestBuilderData site)) IO +type RequestBuilder site = SIO (RequestBuilderData site) -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application' -- and 'ConnectionPool' @@ -250,7 +253,7 @@ yesodSpec site yspecs = unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Hspec.specItem x $ do app <- toWaiAppPlain site - evalStateT y YesodExampleData + evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty @@ -270,7 +273,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs = unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do site <- getSiteAction' app <- toWaiAppPlain site - evalStateT y YesodExampleData + evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty @@ -291,7 +294,7 @@ yesodSpecApp site getApp yspecs = unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecItem x y) = Hspec.specItem x $ do app <- getApp - evalStateT y YesodExampleData + evalSIO y YesodExampleData { yedApp = app , yedSite = site , yedCookies = M.empty @@ -304,12 +307,11 @@ yit label example = tell [YesodSpecItem label example] -- Performs a given action using the last response. Use this to create -- response-level assertions -withResponse' :: MonadIO m - => (state -> Maybe SResponse) +withResponse' :: (state -> Maybe SResponse) -> [T.Text] - -> (SResponse -> ReaderT (IORef state) m a) - -> ReaderT (IORef state) m a -withResponse' getter errTrace f = maybe err f . getter =<< getState + -> (SResponse -> SIO state a) + -> SIO state a +withResponse' getter errTrace f = maybe err f . getter =<< getSIO where err = failure msg msg = if null errTrace then "There was no response, you should make a request." @@ -328,11 +330,10 @@ parseHTML :: HtmlLBS -> Cursor parseHTML html = fromDocument $ HD.parseLBS html -- | Query the last response using CSS selectors, returns a list of matched fragments -htmlQuery' :: MonadIO m - => (state -> Maybe SResponse) +htmlQuery' :: (state -> Maybe SResponse) -> [T.Text] -> Query - -> ReaderT (IORef state) m [HtmlLBS] + -> SIO state [HtmlLBS] htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res -> case findBySelector (simpleBody res) query of Left err -> failure $ query <> " did not parse: " <> T.pack (show err) @@ -497,14 +498,14 @@ printMatches query = do -- | Add a parameter with the given name and value to the request body. addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam name value = - modifyState $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } + modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) } where addPostData (BinaryPostData _) = error "Trying to add post param to binary content." addPostData (MultipleItemsPostData posts) = MultipleItemsPostData $ ReqKvPart name value : posts -- | Add a parameter with the given name and value to the query string. addGetParam :: T.Text -> T.Text -> RequestBuilder site () -addGetParam name value = modifyState $ \rbd -> rbd +addGetParam name value = modifySIO $ \rbd -> rbd { rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value) : rbdGets rbd } @@ -523,7 +524,7 @@ addFile :: T.Text -- ^ The parameter name for the file. -> RequestBuilder site () addFile name path mimetype = do contents <- liftIO $ BSL8.readFile path - modifyState $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } + modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) } where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content." addPostData (MultipleItemsPostData posts) contents = MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts @@ -532,7 +533,7 @@ addFile name path mimetype = do -- This looks up the name of a field based on the contents of the label pointing to it. genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text genericNameFromLabel match label = do - mres <- fmap rbdResponse getState + mres <- fmap rbdResponse getSIO res <- case mres of Nothing -> failure "genericNameFromLabel: No response available" @@ -799,7 +800,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do -- Since 1.4.3.2 getRequestCookies :: RequestBuilder site Cookies getRequestCookies = do - requestBuilderData <- getState + requestBuilderData <- getSIO headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of Just h -> return h Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up." @@ -907,7 +908,7 @@ getLocation = do -- > request $ do -- > setMethod methodPut setMethod :: H.Method -> RequestBuilder site () -setMethod m = modifyState $ \rbd -> rbd { rbdMethod = m } +setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m } -- | Sets the URL used by the request. -- @@ -922,7 +923,7 @@ setUrl :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder site () setUrl url' = do - site <- fmap rbdSite getState + site <- fmap rbdSite getSIO eurl <- Yesod.Core.Unsafe.runFakeHandler M.empty (const $ error "Yesod.Test: No logger available") @@ -930,7 +931,7 @@ setUrl url' = do (toTextUrl url') url <- either (error . show) return eurl let (urlPath, urlQuery) = T.break (== '?') url - modifyState $ \rbd -> rbd + modifySIO $ \rbd -> rbd { rbdPath = case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of ("http:":_:rest) -> rest @@ -969,7 +970,7 @@ clickOn query = do -- > request $ do -- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)] setRequestBody :: BSL8.ByteString -> RequestBuilder site () -setRequestBody body = modifyState $ \rbd -> rbd { rbdPostData = BinaryPostData body } +setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body } -- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's. -- @@ -979,7 +980,7 @@ setRequestBody body = modifyState $ \rbd -> rbd { rbdPostData = BinaryPostData b -- > request $ do -- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") addRequestHeader :: H.Header -> RequestBuilder site () -addRequestHeader header = modifyState $ \rbd -> rbd +addRequestHeader header = modifySIO $ \rbd -> rbd { rbdHeaders = header : rbdHeaders rbd } @@ -999,9 +1000,9 @@ addRequestHeader header = modifyState $ \rbd -> rbd request :: RequestBuilder site () -> YesodExample site () request reqBuilder = do - YesodExampleData app site oldCookies mRes <- getState + YesodExampleData app site oldCookies mRes <- getSIO - RequestBuilderData {..} <- liftIO $ execStateT reqBuilder RequestBuilderData + RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData { rbdPostData = MultipleItemsPostData [] , rbdResponse = mRes , rbdMethod = "GET" @@ -1041,7 +1042,7 @@ request reqBuilder = do }) app let newCookies = parseSetCookies $ simpleHeaders response cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies - putState $ YesodExampleData app site cookies' (Just response) + putSIO $ YesodExampleData app site cookies' (Just response) where isFile (ReqFilePart _ _ _ _) = True isFile _ = False @@ -1145,14 +1146,14 @@ testApp :: site -> Middleware -> TestApp site testApp site middleware = (site, middleware) type YSpec site = Hspec.SpecWith (TestApp site) -instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData site)) IO a) where - type Arg (ReaderT (IORef (YesodExampleData site)) IO a) = TestApp site +instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where + type Arg (SIO (YesodExampleData site) a) = TestApp site evaluateExample example params action = Hspec.evaluateExample (action $ \(site, middleware) -> do app <- toWaiAppPlain site - _ <- evalStateT example YesodExampleData + _ <- evalSIO example YesodExampleData { yedApp = middleware app , yedSite = site , yedCookies = M.empty @@ -1162,24 +1163,26 @@ instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData s params ($ ()) -getState :: MonadIO m => ReaderT (IORef s) m s -getState = ReaderT $ liftIO . readIORef +-- | State + IO +-- +-- @since 1.6.0 +newtype SIO s a = SIO (ReaderT (IORef s) IO a) + deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO) -putState :: MonadIO m => s -> ReaderT (IORef s) m () -putState x = ReaderT $ \ref -> liftIO $ writeIORef ref $! x +getSIO :: SIO s s +getSIO = SIO $ ReaderT readIORef -modifyState :: MonadIO m => (s -> s) -> ReaderT (IORef s) m () -modifyState f = ReaderT $ \ref -> liftIO $ do - x <- readIORef ref - writeIORef ref $! f x +putSIO :: s -> SIO s () +putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s -evalStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m a -evalStateT (ReaderT f) s = do - ref <- liftIO $ newIORef s +modifySIO :: (s -> s) -> SIO s () +modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f + +evalSIO :: SIO s a -> s -> IO a +evalSIO (SIO (ReaderT f)) s = newIORef s >>= f + +execSIO :: SIO s () -> s -> IO s +execSIO (SIO (ReaderT f)) s = do + ref <- newIORef s f ref - -execStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m s -execStateT (ReaderT f) s = do - ref <- liftIO $ newIORef s - _ <- f ref - liftIO $ readIORef ref + readIORef ref diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index ead43c59..fdb833d8 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -37,7 +37,7 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) -import UnliftIO (tryAny, SomeException, try) +import UnliftIO.Exception (tryAny, SomeException, try) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index b699802d..4e4a61db 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -1,5 +1,5 @@ name: yesod-test -version: 1.5.9.1 +version: 1.6.0 license: MIT license-file: LICENSE author: Nubis @@ -27,7 +27,6 @@ library , hspec-core == 2.* , html-conduit >= 0.1 , http-types >= 0.7 - , monad-control , network >= 2.2 , persistent >= 1.0 , pretty-show >= 1.6 @@ -38,7 +37,8 @@ library , wai-extra , xml-conduit >= 1.0 , xml-types >= 0.3 - , yesod-core >= 1.4.14 + , yesod-core >= 1.6 + , conduit exposed-modules: Yesod.Test Yesod.Test.CssQuery @@ -58,7 +58,7 @@ test-suite test , containers , html-conduit , yesod-core - , yesod-form >= 1.4.14 + , yesod-form >= 1.6 , text , wai , http-types diff --git a/yesod-websockets/ChangeLog.md b/yesod-websockets/ChangeLog.md index 74ece92f..9b9a22f6 100644 --- a/yesod-websockets/ChangeLog.md +++ b/yesod-websockets/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.3.0 + +* Upgrade to yesod-core 1.6 + ## 0.2.6 * Fix warnings diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 2346b03c..5a54c553 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} module Yesod.WebSockets @@ -34,10 +33,9 @@ module Yesod.WebSockets , WS.ConnectionOptions (..) ) where -import Control.Monad (forever, void, when) -import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) -import qualified Data.Conduit as C -import qualified Data.Conduit.List as CL +import Control.Monad (forever, when) +import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask) +import Conduit import qualified Network.Wai.Handler.WebSockets as WaiWS import qualified Network.WebSockets as WS import qualified Yesod.Core as Y @@ -55,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection -- instead. -- -- Since 0.1.0 -webSockets :: (Y.MonadUnliftIO m, Y.MonadHandler m) => WebSocketsT m () -> m () +webSockets + :: (MonadUnliftIO m, Y.MonadHandler m) + => WebSocketsT m () + -> m () webSockets = webSocketsOptions WS.defaultConnectionOptions -- | Varient of 'webSockets' which allows you to specify -- the WS.ConnectionOptions setttings when upgrading to a websocket connection. -- -- Since 0.2.5 -webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m) - => WS.ConnectionOptions - -> WebSocketsT m () - -> m () -#if MIN_VERSION_websockets(0,10,0) +webSocketsOptions + :: (MonadUnliftIO m, Y.MonadHandler m) + => WS.ConnectionOptions + -> WebSocketsT m () + -> m () webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing [] -#else -webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing -#endif -- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest' -- setttings when upgrading to a websocket connection. -- -- Since 0.2.4 -webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m) +webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m) => (WS.RequestHead -> m (Maybe WS.AcceptRequest)) -- ^ A Nothing indicates that the websocket upgrade request should not happen -- and instead the rest of the handler will be called instead. This allows @@ -93,7 +91,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions -- setttings when upgrading to a websocket connection. -- -- Since 0.2.5 -webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m) +webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m) => WS.ConnectionOptions -- ^ Custom websockets options -> (WS.RequestHead -> m (Maybe WS.AcceptRequest)) @@ -125,100 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do sink -- | Wrapper for capturing exceptions -wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ()) -wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x +wrapWSE :: (MonadIO m, MonadReader WS.Connection m) + => (WS.Connection -> a -> IO ()) + -> a + -> m (Either SomeException ()) +wrapWSE ws x = do + conn <- ask + liftIO $ tryAny $ ws conn x -wrapWS :: MonadIO m => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m () -wrapWS ws x = ReaderT $ liftIO . flip ws x +wrapWS :: (MonadIO m, MonadReader WS.Connection m) + => (WS.Connection -> a -> IO ()) + -> a + -> m () +wrapWS ws x = do + conn <- ask + liftIO $ ws conn x -- | Receive a piece of data from the client. -- -- Since 0.1.0 -receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a -receiveData = ReaderT $ liftIO . WS.receiveData +receiveData + :: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a) + => m a +receiveData = do + conn <- ask + liftIO $ WS.receiveData conn -- | Receive a piece of data from the client. -- Capture SomeException as the result or operation -- Since 0.2.2 -receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a) -receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData +receiveDataE + :: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a) + => m (Either SomeException a) +receiveDataE = do + conn <- ask + liftIO $ tryAny $ WS.receiveData conn -- | Receive an application message. -- Capture SomeException as the result or operation -- Since 0.2.3 -receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage) -receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage +receiveDataMessageE + :: (MonadIO m, MonadReader WS.Connection m) + => m (Either SomeException WS.DataMessage) +receiveDataMessageE = do + conn <- ask + liftIO $ tryAny $ WS.receiveDataMessage conn -- | Send a textual message to the client. -- -- Since 0.1.0 -sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendTextData + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m () sendTextData = wrapWS WS.sendTextData -- | Send a textual message to the client. -- Capture SomeException as the result or operation --- and can be used like +-- and can be used like -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)` -- Since 0.2.2 -sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendTextDataE + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m (Either SomeException ()) sendTextDataE = wrapWSE WS.sendTextData -- | Send a binary message to the client. -- -- Since 0.1.0 -sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendBinaryData + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m () sendBinaryData = wrapWS WS.sendBinaryData -- | Send a binary message to the client. -- Capture SomeException as the result of operation -- Since 0.2.2 -sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendBinaryDataE + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m (Either SomeException ()) sendBinaryDataE = wrapWSE WS.sendBinaryData -- | Send a ping message to the client. -- -- Since 0.2.2 -sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendPing + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> WebSocketsT m () sendPing = wrapWS WS.sendPing --- | Send a ping message to the client. +-- | Send a ping message to the client. -- Capture SomeException as the result of operation -- Since 0.2.2 -sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendPingE + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m (Either SomeException ()) sendPingE = wrapWSE WS.sendPing --- | Send a DataMessage to the client. +-- | Send a DataMessage to the client. -- Capture SomeException as the result of operation -- Since 0.2.3 -sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ()) -sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x) +sendDataMessageE + :: (MonadIO m, MonadReader WS.Connection m) + => WS.DataMessage + -> m (Either SomeException ()) +sendDataMessageE x = do + conn <- ask + liftIO $ tryAny $ WS.sendDataMessage conn x --- | Send a close request to the client. --- +-- | Send a close request to the client. +-- -- Since 0.2.2 -sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m () +sendClose + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> WebSocketsT m () sendClose = wrapWS WS.sendClose --- | Send a close request to the client. +-- | Send a close request to the client. -- Capture SomeException as the result of operation -- Since 0.2.2 -sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ()) +sendCloseE + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => a + -> m (Either SomeException ()) sendCloseE = wrapWSE WS.sendClose -- | A @Source@ of WebSockets data from the user. -- -- Since 0.1.0 -sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a -sourceWS = forever $ Y.lift receiveData >>= C.yield +sourceWS + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => ConduitT i a m () +sourceWS = forever $ lift receiveData >>= yield -- | A @Sink@ for sending textual data to the user. -- -- Since 0.1.0 -sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () -sinkWSText = CL.mapM_ sendTextData +sinkWSText + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => ConduitT a o m () +sinkWSText = mapM_C sendTextData -- | A @Sink@ for sending binary data to the user. -- -- Since 0.1.0 -sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () -sinkWSBinary = CL.mapM_ sendBinaryData +sinkWSBinary + :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m) + => ConduitT a o m () +sinkWSBinary = mapM_C sendBinaryData diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 70bfc00b..3734b307 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -1,5 +1,5 @@ name: yesod-websockets -version: 0.2.6 +version: 0.3.0 synopsis: WebSockets support for Yesod description: WebSockets support for Yesod homepage: https://github.com/yesodweb/yesod @@ -21,11 +21,12 @@ library , wai , wai-websockets >= 2.1 - , websockets >= 0.9 + , websockets >= 0.10 , transformers >= 0.2 - , yesod-core >= 1.4 + , yesod-core >= 1.6 , unliftio - , conduit >= 1.0.15.1 + , conduit >= 1.3 + , mtl source-repository head type: git diff --git a/yesod/ChangeLog.md b/yesod/ChangeLog.md index 6799776d..db13e23b 100644 --- a/yesod/ChangeLog.md +++ b/yesod/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6 + ## 1.4.5 * Fix warnings diff --git a/yesod/Yesod/Default/Util.hs b/yesod/Yesod/Default/Util.hs index 4b12326c..1edfcdfe 100644 --- a/yesod/Yesod/Default/Util.hs +++ b/yesod/Yesod/Default/Util.hs @@ -40,7 +40,7 @@ addStaticContentExternal -> Text -- ^ filename extension -> Text -- ^ mime type -> L.ByteString -- ^ file contents - -> HandlerT master IO (Maybe (Either Text (Route master, [(Text, Text)]))) + -> HandlerFor master (Maybe (Either Text (Route master, [(Text, Text)]))) addStaticContentExternal minify hash staticDir toRoute ext' _ content = do liftIO $ createDirectoryIfMissing True statictmp exists <- liftIO $ doesFileExist fn' diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal index 5eb0f06e..67309efe 100644 --- a/yesod/yesod.cabal +++ b/yesod/yesod.cabal @@ -1,5 +1,5 @@ name: yesod -version: 1.4.5 +version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -18,10 +18,9 @@ library cpp-options: -DWINDOWS build-depends: base >= 4.6 && < 5 - , yesod-core >= 1.4 && < 1.5 - , yesod-persistent >= 1.4 && < 1.5 - , yesod-form >= 1.4 && < 1.5 - , monad-control >= 0.3 && < 1.1 + , yesod-core >= 1.6 && < 1.7 + , yesod-persistent >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.7 , transformers >= 0.2.2 , wai >= 1.3 , wai-extra >= 1.3