haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'better-monads' into no-transformers

Browse Source
This commit is contained in:
Michael Snoyman 2018-01-17 06:43:52 +02:00
commit 6830a9840c
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
67 changed files with 502 additions and 749 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-auth-oauth/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.2 ## 1.4.2
* Fix warnings * Fix warnings

5
yesod-auth-oauth/Yesod/Auth/OAuth.hs
View File

@ -15,16 +15,15 @@ module Yesod.Auth.OAuth
) where ) where
import Control.Applicative as A ((<$>), (<*>)) import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Exception (Exception, throwIO) import UnliftIO.Exception
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO) import UnliftIO (MonadUnliftIO)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable
import Web.Authenticate.OAuth import Web.Authenticate.OAuth
import Yesod.Auth import Yesod.Auth
import Yesod.Form import Yesod.Form

10
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth-oauth name: yesod-auth-oauth
version: 1.4.2 version: 1.6.0
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Hiromi Ishii author: Hiromi Ishii
@ -23,12 +23,12 @@ library
build-depends: base >= 4 && < 4.3 build-depends: base >= 4 && < 4.3
build-depends: authenticate-oauth >= 1.5 && < 1.7 build-depends: authenticate-oauth >= 1.5 && < 1.7
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, yesod-auth >= 1.4 && < 1.5 , yesod-auth >= 1.6 && < 1.7
, text >= 0.7 , text >= 0.7
, yesod-form >= 1.4 && < 1.5 , yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2 && < 0.6 , transformers >= 0.2.2 && < 0.6
, unliftio-core , unliftio
exposed-modules: Yesod.Auth.OAuth exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall ghc-options: -Wall

4
yesod-auth/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.21 ## 1.4.21
* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461) * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)

6
yesod-auth/Yesod/Auth.hs
View File

@ -50,7 +50,7 @@ module Yesod.Auth
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO) import UnliftIO (withRunInIO, MonadUnliftIO)
import Yesod.Auth.Routes import Yesod.Auth.Routes
import Data.Aeson hiding (json) import Data.Aeson hiding (json)
@ -314,8 +314,8 @@ loginErrorMessageMasterI dest msg = do
-- | For HTML, set the message and redirect to the route. -- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status -- For JSON, send the message and a 401 status
loginErrorMessage :: YesodAuth master loginErrorMessage
=> Route master :: Route master
-> Text -> Text
-> AuthHandler master TypedContent -> AuthHandler master TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)

4
yesod-auth/Yesod/Auth/GoogleEmail2.hs
View File

@ -84,7 +84,7 @@ import qualified Data.Aeson.Encode as A
import Data.Aeson.Parser (json') import Data.Aeson.Parser (json')
import Data.Aeson.Types (FromJSON (parseJSON), parseEither, import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
parseMaybe, withObject, withText) parseMaybe, withObject, withText)
import Data.Conduit (($$+-), ($$), (.|), runConduit) import Data.Conduit
import Data.Conduit.Attoparsec (sinkParser) import Data.Conduit.Attoparsec (sinkParser)
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -274,7 +274,7 @@ getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
req <- personValueRequest token req <- personValueRequest token
res <- http req manager res <- http req manager
responseBody res $$+- sinkParser json' runConduit $ responseBody res .| sinkParser json'
) )
personValueRequest :: MonadIO m => Token -> m Request personValueRequest :: MonadIO m => Token -> m Request

10
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 1.4.21 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -23,7 +23,7 @@ library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, authenticate >= 1.3.4 , authenticate >= 1.3.4
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
, yesod-core >= 1.4.31 && < 1.5 , yesod-core >= 1.6 && < 1.7
, wai >= 1.4 , wai >= 1.4
, template-haskell , template-haskell
, base16-bytestring , base16-bytestring
@ -32,13 +32,13 @@ library
, random >= 1.0.0.2 , random >= 1.0.0.2
, text >= 0.7 , text >= 0.7
, mime-mail >= 0.3 , mime-mail >= 0.3
, yesod-persistent >= 1.4 , yesod-persistent >= 1.6
, shakespeare , shakespeare
, containers , containers
, unordered-containers , unordered-containers
, yesod-form >= 1.4 && < 1.5 , yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2 , transformers >= 0.2.2
, persistent >= 2.5 && < 2.8 , persistent >= 2.8 && < 2.9
, persistent-template >= 2.1 && < 2.8 , persistent-template >= 2.1 && < 2.8
, http-client >= 0.5 , http-client >= 0.5
, http-client-tls , http-client-tls

9
yesod-bin/AddHandler.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternGuards #-}
module AddHandler (addHandler) where module AddHandler (addHandler) where
@ -8,7 +9,11 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
import Data.Maybe (fromMaybe, listToMaybe) import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as TIO 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) import Distribution.PackageDescription.Parse (readPackageDescription)
#endif
import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
import Distribution.Verbosity (normal) import Distribution.Verbosity (normal)
@ -224,7 +229,11 @@ uncapitalize "" = ""
getSrcDir :: FilePath -> IO FilePath getSrcDir :: FilePath -> IO FilePath
getSrcDir cabal = do getSrcDir cabal = do
#if MIN_VERSION_Cabal(2, 0, 0)
pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal
#else
pd <- flattenPackageDescription <$> readPackageDescription normal cabal pd <- flattenPackageDescription <$> readPackageDescription normal cabal
#endif
let buildInfo = allBuildInfo pd let buildInfo = allBuildInfo pd
srcDirs = concatMap hsSourceDirs buildInfo srcDirs = concatMap hsSourceDirs buildInfo
return $ fromMaybe "." $ listToMaybe srcDirs return $ fromMaybe "." $ listToMaybe srcDirs

268
yesod-bin/Build.hs
View File

@ -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

5
yesod-bin/ChangeLog.md
View File

@ -1,3 +1,8 @@
## 1.6.0
* Upgrade to conduit 1.3.0
* Remove configure, build, touch, and test commands
## 1.5.3 ## 1.5.3
* Support typed-process-0.2.0.0 * Support typed-process-0.2.0.0

2
yesod-bin/Devel.hs
View File

@ -9,8 +9,8 @@ module Devel
) where ) where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import UnliftIO (race_)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified UnliftIO.Exception as Ex import qualified UnliftIO.Exception as Ex
import Control.Monad (forever, unless, void, import Control.Monad (forever, unless, void,

1
yesod-bin/HsFile.hs
View File

@ -3,7 +3,6 @@
module HsFile (mkHsFile) where module HsFile (mkHsFile) where
import Text.ProjectTemplate (createTemplate) import Text.ProjectTemplate (createTemplate)
import Conduit import Conduit
import Control.Monad.Trans.Resource (runResourceT)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Data.String (fromString) import Data.String (fromString)

65
yesod-bin/main.hs
View File

@ -2,37 +2,18 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Main (main) where module Main (main) where
import Control.Monad (unless)
import Data.Monoid import Data.Monoid
import Data.Version (showVersion) import Data.Version (showVersion)
import Options.Applicative import Options.Applicative
import System.Environment (getEnvironment) import System.Exit (exitFailure)
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
import System.Process (rawSystem)
import AddHandler (addHandler) import AddHandler (addHandler)
import Devel (DevelOpts (..), devel, develSignal) import Devel (DevelOpts (..), devel, develSignal)
import Keter (keter) import Keter (keter)
import Options (injectDefaults) import Options (injectDefaults)
import qualified Paths_yesod_bin import qualified Paths_yesod_bin
import System.IO (hPutStrLn, stderr)
import HsFile (mkHsFile) 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) data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
@ -91,17 +72,16 @@ main = do
c -> c c -> c
}) })
] optParser' ] optParser'
let cabal = rawSystem' (cabalCommand o)
case optCommand o of case optCommand o of
Init _ -> initErrorMsg Init _ -> initErrorMsg
HsFiles -> mkHsFile HsFiles -> mkHsFile
Configure -> cabal ["configure"] Configure -> cabalErrorMsg
Build es -> touch' >> cabal ("build":es) Build _ -> cabalErrorMsg
Touch -> touch' Touch -> cabalErrorMsg
Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
Test -> cabalTest cabal Test -> cabalErrorMsg
Devel{..} -> devel DevelOpts Devel{..} -> devel DevelOpts
{ verbose = optVerbose o { verbose = optVerbose o
, successHook = develSuccessHook , successHook = develSuccessHook
@ -113,19 +93,6 @@ main = do
} develExtraArgs } develExtraArgs
DevelSignal -> develSignal DevelSignal -> develSignal
where 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 initErrorMsg = do
mapM_ putStrLn mapM_ putStrLn
[ "The init command has been removed." [ "The init command has been removed."
@ -136,6 +103,13 @@ main = do
] ]
exitFailure 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' :: ParserInfo Options
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
@ -148,17 +122,17 @@ optParser = Options
<> command "hsfiles" (info (pure HsFiles) <> command "hsfiles" (info (pure HsFiles)
(progDesc "Create a hsfiles file for the current folder")) (progDesc "Create a hsfiles file for the current folder"))
<> command "configure" (info (pure Configure) <> command "configure" (info (pure Configure)
(progDesc "Configure a project for building")) (progDesc "DEPRECATED"))
<> command "build" (info (helper <*> (Build <$> extraCabalArgs)) <> command "build" (info (helper <*> (Build <$> extraCabalArgs))
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) (progDesc "DEPRECATED"))
<> command "touch" (info (pure Touch) <> 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) <> command "devel" (info (helper <*> develOptions)
(progDesc "Run project with the devel server")) (progDesc "Run project with the devel server"))
<> command "devel-signal" (info (helper <*> pure DevelSignal) <> command "devel-signal" (info (helper <*> pure DevelSignal)
(progDesc "Used internally by the devel command")) (progDesc "Used internally by the devel command"))
<> command "test" (info (pure Test) <> command "test" (info (pure Test)
(progDesc "Build and run the integration tests")) (progDesc "DEPRECATED"))
<> command "add-handler" (info (helper <*> addHandlerOptions) <> command "add-handler" (info (helper <*> addHandlerOptions)
(progDesc ("Add a new handler and module to the project." (progDesc ("Add a new handler and module to the project."
++ " Interactively asks for input if you do not specify arguments."))) ++ " Interactively asks for input if you do not specify arguments.")))
@ -217,10 +191,3 @@ addHandlerOptions = AddHandler
-- | Optional @String@ argument -- | Optional @String@ argument
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
optStr m = option (Just <$> str) $ value Nothing <> m 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

6
yesod-bin/yesod-bin.cabal
View File

@ -1,5 +1,5 @@
name: yesod-bin name: yesod-bin
version: 1.5.3 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -68,13 +68,11 @@ executable yesod
, data-default-class , data-default-class
, streaming-commons , streaming-commons
, warp-tls >= 3.0.1 , warp-tls >= 3.0.1
, async , unliftio
, deepseq
ghc-options: -Wall -threaded -rtsopts ghc-options: -Wall -threaded -rtsopts
main-is: main.hs main-is: main.hs
other-modules: Devel other-modules: Devel
Build
Keter Keter
AddHandler AddHandler
Paths_yesod_bin Paths_yesod_bin

14
yesod-core/ChangeLog.md
View File

@ -1,13 +1,15 @@
## 1.5.0 ## 1.6.0
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
## 1.4.38
* 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` * Internal only change, users of stable API are unaffected: `WidgetT`
holds its data in an `IORef` so that it is isomorphic to `ReaderT`, holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
avoiding state-loss issues.. avoiding state-loss issues..
* Instances for `MonadUnliftIO` * Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
## 1.4.37.2 ## 1.4.37.2

3
yesod-core/Yesod/Core.hs
View File

@ -31,7 +31,6 @@ module Yesod.Core
-- * Logging -- * Logging
, defaultMakeLogger , defaultMakeLogger
, defaultMessageLoggerSource , defaultMessageLoggerSource
, defaultShouldLog
, defaultShouldLogIO , defaultShouldLogIO
, formatLogMessage , formatLogMessage
, LogLevel (..) , LogLevel (..)
@ -146,7 +145,7 @@ import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)
import Yesod.Routes.Class import Yesod.Routes.Class
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..)) import UnliftIO (MonadIO (..), MonadUnliftIO (..))
import Control.Monad.Trans.Resource (MonadResource (..)) import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp import Yesod.Core.Internal.LiteApp

2
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -12,7 +12,7 @@ import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute) import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute)
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Class.Yesod 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 -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.

1
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -14,7 +14,6 @@ module Yesod.Core.Class.Handler
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad.Logger (MonadLogger) import Control.Monad.Logger (MonadLogger)
import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO)
import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710

67
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -10,7 +10,7 @@ import Yesod.Core.Handler
import Yesod.Routes.Class import Yesod.Routes.Class
import Data.ByteString.Builder (Builder, toLazyByteString) import Data.ByteString.Builder (Builder)
import Data.Text.Encoding (encodeUtf8Builder) import Data.Text.Encoding (encodeUtf8Builder)
import Control.Arrow ((***), second) import Control.Arrow ((***), second)
import Control.Exception (bracket) import Control.Exception (bracket)
@ -24,7 +24,6 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState) import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Aeson (object, (.=)) import Data.Aeson (object, (.=))
import Data.List (foldl', nub) import Data.List (foldl', nub)
import qualified Data.Map as Map import qualified Data.Map as Map
@ -37,9 +36,8 @@ import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Word (Word64) import Data.Word (Word64)
import Language.Haskell.TH.Syntax (Loc (..)) import Language.Haskell.TH.Syntax (Loc (..))
import Network.HTTP.Types (encodePath, renderQueryText) import Network.HTTP.Types (encodePath)
import qualified Network.Wai as W import qualified Network.Wai as W
import Data.Default (def)
import Network.Wai.Parse (lbsBackEnd, import Network.Wai.Parse (lbsBackEnd,
tempFileBackEnd) tempFileBackEnd)
import Network.Wai.Logger (ZonedDate, clockDateCacher) import Network.Wai.Logger (ZonedDate, clockDateCacher)
@ -52,7 +50,7 @@ import Text.Hamlet
import Text.Julius import Text.Julius
import qualified Web.ClientSession as CS import qualified Web.ClientSession as CS
import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax, import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,
sameSiteStrict, SameSiteOption) sameSiteStrict, SameSiteOption, defaultSetCookie)
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Widget 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 -- | An absolute URL to the root of the application. Do not include
-- trailing slash. -- trailing slash.
-- --
-- Default value: 'ApprootRelative'. This is valid under the following -- Default value: 'guessApproot'. If you know your application root
-- conditions: -- 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. -- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
--
-- * 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.
approot :: Approot site approot :: Approot site
approot = ApprootRelative approot = guessApproot
-- | Output error response pages. -- | Output error response pages.
-- --
@ -103,12 +97,6 @@ class RenderRoute site => Yesod site where
^{pageBody p} ^{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 -- | Override the rendering function for a particular URL and query string
-- parameters. One use case for this is to offload static hosting to a -- parameters. One use case for this is to offload static hosting to a
-- different domain name to avoid sending cookies. -- different domain name to avoid sending cookies.
@ -121,15 +109,7 @@ class RenderRoute site => Yesod site where
-> Route site -> Route site
-> [(T.Text, T.Text)] -- ^ query string -> [(T.Text, T.Text)] -- ^ query string
-> Maybe Builder -> Maybe Builder
urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route urlParamRenderOverride _ _ _ = Nothing
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
-- | Determine if a request is authorized or not. -- | 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. -- | Should we log the given log source/level combination.
-- --
-- Default: the 'defaultShouldLog' function. -- Default: the 'defaultShouldLogIO' 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.
-- --
-- Since 1.2.4 -- Since 1.2.4
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool 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 -- | A Yesod middleware, which will wrap every handler function. This
-- allows you to run code before and after a normal handler. -- allows you to run code before and after a normal handler.
@ -332,7 +301,6 @@ class RenderRoute site => Yesod site where
<h1>#{title} <h1>#{title}
^{body} ^{body}
|] |]
{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
-- | Default implementation of 'makeLogger'. Sends to stdout and -- | Default implementation of 'makeLogger'. Sends to stdout and
-- automatically flushes on each write. -- automatically flushes on each write.
@ -369,15 +337,8 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
-- above 'LevelInfo'. -- above 'LevelInfo'.
-- --
-- Since 1.4.10 -- 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 :: LogSource -> LogLevel -> IO Bool
defaultShouldLogIO a b = return $ defaultShouldLog a b defaultShouldLogIO _ level = return $ level >= LevelInfo
-- | Default implementation of 'yesodMiddleware'. Adds the response header -- | Default implementation of 'yesodMiddleware'. Adds the response header
-- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- \"Vary: Accept, Accept-Language\" and performs authorization checks.
@ -871,7 +832,7 @@ loadClientSession key getCachedDate sessionName req = load
save date sess' = do save date sess' = do
-- We should never cache the IV! Be careful! -- We should never cache the IV! Be careful!
iv <- liftIO CS.randomIV iv <- liftIO CS.randomIV
return [AddCookie def return [AddCookie defaultSetCookie
{ setCookieName = sessionName { setCookieName = sessionName
, setCookieValue = encodeClientSession key iv date host sess' , setCookieValue = encodeClientSession key iv date host sess'
, setCookiePath = Just "/" , setCookiePath = Just "/"

7
yesod-core/Yesod/Core/Content.hs
View File

@ -61,10 +61,9 @@ import Data.Monoid (mempty)
#endif #endif
import Text.Hamlet (Html) import Text.Hamlet (Html)
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) 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 (liftM)
import Control.Monad.Trans.Resource (ResourceT) import Control.Monad.Trans.Resource (ResourceT)
import Data.Conduit.Internal (ResumableSource (ResumableSource))
import qualified Data.Conduit.Internal as CI import qualified Data.Conduit.Internal as CI
import qualified Data.Aeson as J 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 instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
toContent src = ContentSource $ mapOutput toFlushBuilder src toContent src = ContentSource $ mapOutput toFlushBuilder src
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
toContent (ResumableSource src) = toContent src toContent (CI.SealedConduitT src) = toContent src
-- | A class for all data which can be sent in a streaming response. Note that -- | A class for all data which can be sent in a streaming response. Note that
-- for textual data, instances must use UTF-8 encoding. -- for textual data, instances must use UTF-8 encoding.

11
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -63,6 +63,7 @@ import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run import Yesod.Core.Internal.Run
import Safe (readMay) import Safe (readMay)
import System.Environment (getEnvironment) import System.Environment (getEnvironment)
import qualified System.Random as Random
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq) import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
@ -78,7 +79,6 @@ import Control.Monad.Logger
import Control.Monad (when) import Control.Monad (when)
import qualified Paths_yesod_core import qualified Paths_yesod_core
import Data.Version (showVersion) import Data.Version (showVersion)
import qualified System.Random.MWC as MWC
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This function will provide no middlewares; if you want commonly -- 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 toWaiAppPlain site = do
logger <- makeLogger site logger <- makeLogger site
sb <- makeSessionBackend site sb <- makeSessionBackend site
gen <- MWC.createSystemRandom
getMaxExpires <- getGetMaxExpires getMaxExpires <- getGetMaxExpires
return $ toWaiAppYre YesodRunnerEnv return $ toWaiAppYre YesodRunnerEnv
{ yreLogger = logger { yreLogger = logger
, yreSite = site , yreSite = site
, yreSessionBackend = sb , yreSessionBackend = sb
, yreGen = gen , yreGen = defaultGen
, yreGetMaxExpires = getMaxExpires , yreGetMaxExpires = getMaxExpires
} }
defaultGen :: IO Int
defaultGen = Random.getStdRandom Random.next
-- | Pure low level function to construct WAI application. Usefull -- | Pure low level function to construct WAI application. Usefull
-- when you need not standard way to run your app, or want to embed it -- when you need not standard way to run your app, or want to embed it
-- inside another app. -- inside another app.
@ -151,13 +153,12 @@ toWaiApp site = do
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
toWaiAppLogger logger site = do toWaiAppLogger logger site = do
sb <- makeSessionBackend site sb <- makeSessionBackend site
gen <- MWC.createSystemRandom
getMaxExpires <- getGetMaxExpires getMaxExpires <- getGetMaxExpires
let yre = YesodRunnerEnv let yre = YesodRunnerEnv
{ yreLogger = logger { yreLogger = logger
, yreSite = site , yreSite = site
, yreSessionBackend = sb , yreSessionBackend = sb
, yreGen = gen , yreGen = defaultGen
, yreGetMaxExpires = getMaxExpires , yreGetMaxExpires = getMaxExpires
} }
messageLoggerSource messageLoggerSource

17
yesod-core/Yesod/Core/Handler.hs
View File

@ -193,13 +193,14 @@ import Control.Applicative ((<$>))
import Data.Monoid (mempty, mappend) import Data.Monoid (mempty, mappend)
#endif #endif
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import qualified Data.CaseInsensitive as CI
import Control.Exception (evaluate, SomeException, throwIO) import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception (handle) import Control.Exception (handle)
import Control.Monad (void, liftM, unless) import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer 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.HTTP.Types as H
import qualified Network.Wai as W import qualified Network.Wai as W
@ -228,7 +229,7 @@ import Data.Monoid (Endo (..))
import Data.Text (Text) import Data.Text (Text)
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import Text.Shakespeare.I18N (RenderMessage (..)) 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.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
import Yesod.Core.Internal.Util (formatRFC1123) import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml) 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 Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8 import qualified Data.Word8 as W8
import qualified Data.Foldable as Fold import qualified Data.Foldable as Fold
import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS) import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: * -> *) = HandlerFor site type HandlerT site (m :: * -> *) = HandlerFor site
@ -782,7 +782,7 @@ setLanguage = setSession langKey
-- --
-- @since 1.2.0 -- @since 1.2.0
addHeader :: MonadHandler m => Text -> Text -> m () 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. -- | Deprecated synonym for addHeader.
setHeader :: MonadHandler m => Text -> Text -> m () setHeader :: MonadHandler m => Text -> Text -> m ()
@ -800,10 +800,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
replaceOrAddHeader a b = replaceOrAddHeader a b =
modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)} modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
where where
repHeader = Header (encodeUtf8 a) (encodeUtf8 b) repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)
sameHeaderName :: Header -> Header -> Bool 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 sameHeaderName _ _ = False
replaceIndividualHeader :: [Header] -> [Header] replaceIndividualHeader :: [Header] -> [Header]
@ -1457,7 +1457,10 @@ defaultCsrfCookieName = "XSRF-TOKEN"
-- --
-- @since 1.4.14 -- @since 1.4.14
setCsrfCookie :: MonadHandler m => m () 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. -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.
-- --

30
yesod-core/Yesod/Core/Internal/Request.hs
View File

@ -35,14 +35,11 @@ import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Encoding.Error (lenientDecode)
import Conduit import Conduit
import Data.Word (Word8, Word64) import Data.Word (Word8, Word64)
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Control.Exception (throwIO) import Control.Exception (throwIO)
import Control.Monad ((<=<), liftM) import Control.Monad ((<=<), liftM)
import Yesod.Core.Types import Yesod.Core.Types
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.IORef import Data.IORef
import qualified System.Random.MWC as MWC
import Control.Monad.Primitive (PrimMonad, PrimState)
import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable as V
import Data.ByteString.Internal (ByteString (PS)) import Data.ByteString.Internal (ByteString (PS))
import qualified Data.Word8 as Word8 import qualified Data.Word8 as Word8
@ -74,7 +71,7 @@ parseWaiRequest :: W.Request
-> SessionMap -> SessionMap
-> Bool -> Bool
-> Maybe Word64 -- ^ max body size -> Maybe Word64 -- ^ max body size
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest) -> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
parseWaiRequest env session useToken mmaxBodySize = parseWaiRequest env session useToken mmaxBodySize =
-- In most cases, we won't need to generate any random values. Therefore, -- 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 -- 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 -- | Generate a random String of alphanumerical characters
-- (a-z, A-Z, and 0-9) of the given length using the given -- (a-z, A-Z, and 0-9) of the given length using the given
-- random number generator. -- random number generator.
randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text randomString :: Monad m => Int -> m Int -> m Text
randomString len gen = randomString len gen =
liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
where where
asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen asciiChar =
let loop = do
toAscii i x <- gen
| i < 26 = i + Word8._A let y = fromIntegral $ x `mod` 64
| i < 52 = i + Word8._a - 26 case () of
| otherwise = i + Word8._0 - 52 ()
| 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.Vector Word8 -> ByteString
fromByteVector v = fromByteVector v =
@ -177,10 +179,10 @@ mkFileInfoLBS name ct lbs =
FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs) FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo 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 :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst) mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
tokenKey :: IsString a => a tokenKey :: IsString a => a
tokenKey = "_TOKEN" tokenKey = "_TOKEN"

10
yesod-core/Yesod/Core/Internal/Response.hs
View File

@ -8,7 +8,6 @@ import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Network.Wai import Network.Wai
import Control.Monad (mplus) import Control.Monad (mplus)
import Control.Monad.Trans.Resource (runInternalState, InternalState) 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 qualified Data.Map as Map
import Yesod.Core.Internal.Request (tokenKey) import Yesod.Core.Internal.Request (tokenKey)
import Data.Text.Encoding (encodeUtf8) import Data.Text.Encoding (encodeUtf8)
import Data.Conduit (Flush (..), ($$), transPipe) import Conduit
import qualified Data.Conduit.List as CL
yarToResponse :: YesodResponse yarToResponse :: YesodResponse
-> (SessionMap -> IO [Header]) -- ^ save session -> (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 sendResponse $ ResponseBuilder s hs' b
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
go (ContentSource body) = sendResponse $ responseStream s finalHeaders go (ContentSource body) = sendResponse $ responseStream s finalHeaders
$ \sendChunk flush -> $ \sendChunk flush -> runConduit $
transPipe (`runInternalState` is) body transPipe (`runInternalState` is) body
$$ CL.mapM_ (\mchunk -> .| mapM_C (\mchunk ->
case mchunk of case mchunk of
Flush -> flush Flush -> flush
Chunk builder -> sendChunk builder) Chunk builder -> sendChunk builder)
@ -93,7 +91,7 @@ headerToPair (DeleteCookie key path) =
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT" , "; 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 :: Content -> IO (Either ErrorResponse Content)
evaluateContent (ContentBuilder b mlen) = handle f $ do evaluateContent (ContentBuilder b mlen) = handle f $ do

48
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -16,8 +16,6 @@ import Control.Applicative ((<$>))
import Yesod.Core.Internal.Response import Yesod.Core.Internal.Response
import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Builder (toLazyByteString)
import qualified Data.ByteString.Lazy as BL 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.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogLevel (LevelError), LogSource, import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc) liftLoc)
@ -45,38 +43,21 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123) import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
import Yesod.Routes.Class (Route, renderRoute) import Yesod.Routes.Class (Route, renderRoute)
import Control.DeepSeq (($!!), NFData) import Control.DeepSeq (($!!), NFData)
import UnliftIO.Exception
-- | Catch all synchronous exceptions, ignoring asynchronous -- | Convert a synchronous exception into an ErrorResponse
-- exceptions. toErrorHandler :: SomeException -> IO ErrorResponse
-- toErrorHandler e0 = handleAny errFromShow $
-- 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 $
case fromException e0 of case fromException e0 of
Just (HCError x) -> evaluate $!! x Just (HCError x) -> evaluate $!! x
_ _ -> errFromShow e0
| isAsyncException e0 -> E.throwIO e0
| otherwise -> errFromShow e0
-- | Generate an @ErrorResponse@ based on the shown version of the exception -- | Generate an @ErrorResponse@ based on the shown version of the exception
errFromShow :: E.SomeException -> IO ErrorResponse errFromShow :: SomeException -> IO ErrorResponse
errFromShow x = evaluate $!! InternalError $! T.pack $! show x 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 -- | Do a basic run of a handler, getting some contents and the final
-- @GHState@. The @GHState@ unfortunately may contain some impure -- @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 -- Run the handler itself, capturing any runtime exceptions and
-- converting them into a @HandlerContents@ -- converting them into a @HandlerContents@
contents' <- catchSync contents' <- catchAny
(do (do
res <- unHandlerFor handler (hd istate) res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res) tc <- evaluate (toTypedContent res)
@ -135,7 +116,7 @@ handleError :: RunHandlerEnv site
-> IO YesodResponse -> IO YesodResponse
handleError rhe yreq resState finalSession headers e0 = do handleError rhe yreq resState finalSession headers e0 = do
-- Find any evil hidden impure exceptions -- Find any evil hidden impure exceptions
e <- (evaluate $!! e0) `catchSync` errFromShow e <- (evaluate $!! e0) `catchAny` errFromShow
-- Generate a response, leveraging the updated session and -- Generate a response, leveraging the updated session and
-- response headers -- response headers
@ -200,7 +181,7 @@ evalFallback :: (Monoid w, NFData w)
=> HandlerContents => HandlerContents
-> w -> w
-> IO (w, HandlerContents) -> IO (w, HandlerContents)
evalFallback contents val = catchSync evalFallback contents val = catchAny
(fmap (, contents) (evaluate $!! val)) (fmap (, contents) (evaluate $!! val))
(fmap ((mempty, ) . HCError) . toErrorHandler) (fmap ((mempty, ) . HCError) . toErrorHandler)
@ -218,13 +199,14 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
-- propagating exceptions into the contents -- propagating exceptions into the contents
(finalSession, contents1) <- evalFallback contents0 (ghsSession state) (finalSession, contents1) <- evalFallback contents0 (ghsSession state)
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) []) (headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
-- Convert the HandlerContents into the final YesodResponse -- Convert the HandlerContents into the final YesodResponse
handleContents handleContents
(handleError rhe yreq resState finalSession headers) (handleError rhe yreq resState finalSession headers)
finalSession finalSession
headers headers
contents2 contents3
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> ErrorResponse -> ErrorResponse

69
yesod-core/Yesod/Core/Types.hs
View File

@ -25,6 +25,7 @@ import Control.Monad.Logger (LogLevel, LogSource,
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.CaseInsensitive (CI)
import Data.Conduit (Flush, ConduitT) import Data.Conduit (Flush, ConduitT)
import Data.IORef (IORef, modifyIORef') import Data.IORef (IORef, modifyIORef')
import Data.Map (Map, unionWith) import Data.Map (Map, unionWith)
@ -46,7 +47,6 @@ import Network.Wai (FilePart,
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Network.Wai.Parse as NWP import qualified Network.Wai.Parse as NWP
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr) import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
import qualified System.Random.MWC as MWC
import Network.Wai.Logger (DateCacheGetter) import Network.Wai.Logger (DateCacheGetter)
import Text.Blaze.Html (Html, toHtml) import Text.Blaze.Html (Html, toHtml)
import Text.Hamlet (HtmlUrl) import Text.Hamlet (HtmlUrl)
@ -61,7 +61,7 @@ import Control.DeepSeq.Generics (genericRnf)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..)) import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..)) import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
-- Sessions -- Sessions
type SessionMap = Map Text ByteString 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 -> 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) deriving (Show, Read)
instance Serialize SessionCookie where instance Serialize SessionCookie where
put (SessionCookie a b c) = do put (SessionCookie a b c) = do
@ -152,13 +152,13 @@ data Approot master = ApprootRelative -- ^ No application root.
type ResolvedApproot = Text type ResolvedApproot = Text
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text
deriving (Eq, Show, Read) deriving (Eq, Show, Read)
data ScriptLoadPosition master data ScriptLoadPosition master
= BottomOfBody = BottomOfBody
| BottomOfHeadBlocking | BottomOfHeadBlocking
| BottomOfHeadAsync (BottomOfHeadAsync master) | BottomOfHeadAsync !(BottomOfHeadAsync master)
type BottomOfHeadAsync master type BottomOfHeadAsync master
= [Text] -- ^ urls to load asynchronously = [Text] -- ^ urls to load asynchronously
@ -171,7 +171,7 @@ type Texts = [Text]
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application } newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized. -- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
-- --
-- @since 1.4.34 -- @since 1.4.34
newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application } newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
@ -199,8 +199,9 @@ data YesodRunnerEnv site = YesodRunnerEnv
{ yreLogger :: !Logger { yreLogger :: !Logger
, yreSite :: !site , yreSite :: !site
, yreSessionBackend :: !(Maybe SessionBackend) , yreSessionBackend :: !(Maybe SessionBackend)
, yreGen :: !MWC.GenIO , yreGen :: !(IO Int)
, yreGetMaxExpires :: IO Text -- ^ Generate a random number
, yreGetMaxExpires :: !(IO Text)
} }
data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
@ -225,11 +226,11 @@ newtype HandlerFor site a = HandlerFor
data GHState = GHState data GHState = GHState
{ ghsSession :: !SessionMap { ghsSession :: !SessionMap
, ghsRBC :: Maybe RequestBodyContents , ghsRBC :: !(Maybe RequestBodyContents)
, ghsIdent :: Int , ghsIdent :: !Int
, ghsCache :: TypeMap , ghsCache :: !TypeMap
, ghsCacheBy :: KeyedTypeMap , ghsCacheBy :: !KeyedTypeMap
, ghsHeaders :: Endo [Header] , ghsHeaders :: !(Endo [Header])
} }
-- | An extension of the basic WAI 'W.Application' datatype to provide extra -- | 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 -- > PageContent url -> HtmlUrl url
data PageContent url = PageContent data PageContent url = PageContent
{ pageTitle :: Html { pageTitle :: !Html
, pageHead :: HtmlUrl url , pageHead :: !(HtmlUrl url)
, pageBody :: HtmlUrl url , pageBody :: !(HtmlUrl url)
} }
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length. 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. -- | Responses to indicate some form of an error occurred.
data ErrorResponse = data ErrorResponse =
NotFound NotFound
| InternalError Text | InternalError !Text
| InvalidArgs [Text] | InvalidArgs ![Text]
| NotAuthenticated | NotAuthenticated
| PermissionDenied Text | PermissionDenied !Text
| BadMethod H.Method | BadMethod !H.Method
deriving (Show, Eq, Typeable, Generic) deriving (Show, Eq, Typeable, Generic)
instance NFData ErrorResponse where instance NFData ErrorResponse where
rnf = genericRnf rnf = genericRnf
@ -324,9 +325,11 @@ instance NFData ErrorResponse where
----- header stuff ----- header stuff
-- | Headers to be added to a 'Result'. -- | Headers to be added to a 'Result'.
data Header = data Header =
AddCookie SetCookie AddCookie !SetCookie
| DeleteCookie ByteString ByteString | DeleteCookie !ByteString !ByteString
| Header ByteString ByteString -- ^ name and path
| Header !(CI ByteString) !ByteString
-- ^ key and value
deriving (Eq, Show) deriving (Eq, Show)
-- FIXME In the next major version bump, let's just add strictness annotations -- 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 (DeleteCookie x y) = x `seq` y `seq` ()
rnf (Header 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) deriving (Show, Eq)
-- | A diff list that does not directly enforce uniqueness. -- | A diff list that does not directly enforce uniqueness.
-- When creating a widget Yesod will use nub to make it unique. -- When creating a widget Yesod will use nub to make it unique.
newtype UniqueList x = UniqueList ([x] -> [x]) 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) 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) deriving (Show, Eq)
newtype Title = Title { unTitle :: Html } newtype Title = Title { unTitle :: Html }
@ -382,13 +385,13 @@ instance Monoid (GWData a) where
instance Semigroup (GWData a) instance Semigroup (GWData a)
data HandlerContents = data HandlerContents =
HCContent H.Status !TypedContent HCContent !H.Status !TypedContent
| HCError ErrorResponse | HCError !ErrorResponse
| HCSendFile ContentType FilePath (Maybe FilePart) | HCSendFile !ContentType !FilePath !(Maybe FilePart)
| HCRedirect H.Status Text | HCRedirect !H.Status !Text
| HCCreated Text | HCCreated !Text
| HCWai W.Response | HCWai !W.Response
| HCWaiApp W.Application | HCWaiApp !W.Application
deriving Typeable deriving Typeable
instance Show HandlerContents where instance Show HandlerContents where

8
yesod-core/bench/widget.hs
View File

@ -5,22 +5,20 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Main where module Main where
import Criterion.Main import Gauge.Main
import Text.Hamlet import Text.Hamlet
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8 import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
import Data.Monoid (mconcat) import Data.Monoid (mconcat)
import Text.Blaze.Html5 (table, tr, td) import Text.Blaze.Html5 (table, tr, td)
import Text.Blaze.Html (toHtml) import Text.Blaze.Html (toHtml)
import Yesod.Core.Widget
import Yesod.Core.Types
import Data.Int import Data.Int
main :: IO () main :: IO ()
main = defaultMain main = defaultMain
[ bench "bigTable html" $ nf bigTableHtml bigTableData [ bench "bigTable html" $ nf bigTableHtml bigTableData
, bench "bigTable hamlet" $ nf bigTableHamlet 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 , bench "bigTable blaze" $ nf bigTableBlaze bigTableData
] ]
where where
@ -49,6 +47,7 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
<td>#{show cell} <td>#{show cell}
|] |]
{-
bigTableWidget :: Show a => [[a]] -> IO Int64 bigTableWidget :: Show a => [[a]] -> IO Int64
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet| bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
<table> <table>
@ -62,6 +61,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
run (WidgetT w) = do run (WidgetT w) = do
(_, GWData { gwdBody = Body x }) <- w undefined (_, GWData { gwdBody = Body x }) <- w undefined
return x return x
-}
bigTableBlaze :: Show a => [[a]] -> Int64 bigTableBlaze :: Show a => [[a]] -> Int64
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t

22
yesod-core/test/YesodCoreTest/InternalRequest.hs
View File

@ -10,9 +10,11 @@ import Data.Map (singleton)
import Yesod.Core import Yesod.Core
import Data.Word (Word64) import Data.Word (Word64)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import qualified System.Random.MWC as MWC
import Control.Monad.ST
import Control.Monad (replicateM) import Control.Monad (replicateM)
import System.Random
gen :: IO Int
gen = getStdRandom next
randomStringSpecs :: Spec randomStringSpecs :: Spec
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do 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 -- NOTE: this testcase may break on other systems/architectures if
-- mkStdGen is not identical everywhere (is it?). -- mkStdGen is not identical everywhere (is it?).
_looksRandom :: Bool _looksRandom :: IO ()
_looksRandom = runST $ do _looksRandom = do
gen <- MWC.create
s <- randomString 20 gen s <- randomString 20 gen
return $ s == "VH9SkhtptqPs6GqtofVg" s `shouldBe` "VH9SkhtptqPs6GqtofVg"
noRepeat :: Int -> Int -> Bool noRepeat :: Int -> Int -> IO ()
noRepeat len n = runST $ do noRepeat len n = do
gen <- MWC.create
ss <- replicateM n $ randomString len gen ss <- replicateM n $ randomString len gen
return $ length (nub ss) == n length (nub ss) `shouldBe` n
-- For convenience instead of "(undefined :: StdGen)". -- For convenience instead of "(undefined :: StdGen)".
g :: MWC.GenIO g :: IO Int
g = error "test/YesodCoreTest/InternalRequest.g" g = error "test/YesodCoreTest/InternalRequest.g"
parseWaiRequest' :: Request parseWaiRequest' :: Request

16
yesod-core/test/YesodCoreTest/RawResponse.hs
View File

@ -39,8 +39,8 @@ getHomeR = do
_ <- register $ writeIORef ref 1 _ <- register $ writeIORef ref 1
sendRawResponse $ \src sink -> liftIO $ do sendRawResponse $ \src sink -> liftIO $ do
val <- readIORef ref val <- readIORef ref
yield (S8.pack $ show val) $$ sink runConduit $ yield (S8.pack $ show val) .| sink
src $$ CL.map (S8.map toUpper) =$ sink runConduit $ src .| CL.map (S8.map toUpper) .| sink
getWaiStreamR :: Handler () getWaiStreamR :: Handler ()
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
@ -76,18 +76,18 @@ specs = do
withAsync (warp port App) $ \_ -> do withAsync (warp port App) $ \_ -> do
threadDelay 100000 threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
(appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO") runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
yield "WORLd" $$ appSink ad runConduit $ yield "WORLd" .| appSink ad
(appSource ad $$ await) >>= (`shouldBe` Just "WORLD") runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
let body req = do let body req = do
port <- getFreePort port <- getFreePort
withAsync (warp port App) $ \_ -> do withAsync (warp port App) $ \_ -> do
threadDelay 100000 threadDelay 100000
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
yield req $$ appSink ad runConduit $ yield req .| appSink ad
appSource ad $$ CB.lines =$ do runConduit $ appSource ad .| CB.lines .| do
let loop = do let loop = do
x <- await x <- await
case x of case x of

4
yesod-core/test/YesodCoreTest/RequestBodySize.hs
View File

@ -42,11 +42,11 @@ postPostR = do
return $ RepPlain $ toContent $ T.concat val return $ RepPlain $ toContent $ T.concat val
postConsumeR = do postConsumeR = do
body <- rawRequestBody $$ consume body <- runConduit $ rawRequestBody .| consume
return $ RepPlain $ toContent $ S.concat body return $ RepPlain $ toContent $ S.concat body
postPartialConsumeR = do postPartialConsumeR = do
body <- rawRequestBody $$ isolate 5 =$ consume body <- runConduit $ rawRequestBody .| isolate 5 .| consume
return $ RepPlain $ toContent $ S.concat body return $ RepPlain $ toContent $ S.concat body
postUnusedR = return $ RepPlain "" postUnusedR = return $ RepPlain ""

11
yesod-core/yesod-core.cabal
View File

@ -1,5 +1,5 @@
name: yesod-core name: yesod-core
version: 1.4.38 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -52,22 +52,18 @@ library
, resourcet >= 1.2 , resourcet >= 1.2
, blaze-html >= 0.5 , blaze-html >= 0.5
, blaze-markup >= 0.7.1 , blaze-markup >= 0.7.1
-- FIXME remove!
, data-default
, safe , safe
, warp >= 3.0.2 , warp >= 3.0.2
, unix-compat , unix-compat
, conduit-extra , conduit-extra
, deepseq >= 1.3 , deepseq >= 1.3
, deepseq-generics , deepseq-generics
-- FIXME remove
, mwc-random
, primitive , primitive
, word8 , word8
, auto-update , auto-update
, semigroups , semigroups
, byteable , byteable
, unliftio-core , unliftio
exposed-modules: Yesod.Core exposed-modules: Yesod.Core
Yesod.Core.Content Yesod.Core.Content
@ -199,7 +195,6 @@ test-suite tests
, shakespeare , shakespeare
, streaming-commons , streaming-commons
, wai-extra , wai-extra
, mwc-random
, cookie >= 0.4.1 && < 0.5 , cookie >= 0.4.1 && < 0.5
, unliftio , unliftio
ghc-options: -Wall ghc-options: -Wall
@ -209,7 +204,7 @@ benchmark widgets
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: bench hs-source-dirs: bench
build-depends: base build-depends: base
, criterion , gauge
, bytestring , bytestring
, text , text
, transformers , transformers

4
yesod-eventsource/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.1 ## 1.4.1
* Fix warnings * Fix warnings

33
yesod-eventsource/Yesod/EventSource.hs
View File

@ -13,7 +13,7 @@ import Control.Monad (when)
import Data.Functor ((<$>)) import Data.Functor ((<$>))
import Data.Monoid (Monoid (..)) import Data.Monoid (Monoid (..))
import Yesod.Core import Yesod.Core
import qualified Data.Conduit as C import Data.Conduit
import qualified Network.Wai as W import qualified Network.Wai as W
import qualified Network.Wai.EventSource as ES import qualified Network.Wai.EventSource as ES
import qualified Network.Wai.EventSource.EventStream as ES import qualified Network.Wai.EventSource.EventStream as ES
@ -32,32 +32,35 @@ prepareForEventSource = do
-- | (Internal) Source with a event stream content-type. -- | (Internal) Source with a event stream content-type.
respondEventStream :: C.Source (HandlerT site IO) (C.Flush Builder) respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
respondEventStream = respondSource "text/event-stream" 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 -- '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, -- finishes outputting data or a 'ES.CloseEvent' is outputted,
-- whichever comes first. -- whichever comes first.
repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerEvent) repEventSource :: (EventSourcePolyfill -> ConduitT () ES.ServerEvent (HandlerFor site) ())
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
repEventSource src = repEventSource src =
prepareForEventSource >>= prepareForEventSource >>=
respondEventStream . sourceToSource . src respondEventStream . sourceToSource . src
-- | Convert a ServerEvent source into a Builder source of serialized -- | Convert a ServerEvent source into a Builder source of serialized
-- events. -- 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 = sourceToSource src =
src C.$= C.awaitForever eventToFlushBuilder src .| awaitForever eventToFlushBuilder
where where
eventToFlushBuilder event = eventToFlushBuilder event =
case ES.eventToBuilder event of case ES.eventToBuilder event of
Nothing -> return () 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 -- | 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 -- The connection is closed as soon as an 'ES.CloseEvent' is
-- outputted, after which no other events are sent to the client. -- outputted, after which no other events are sent to the client.
pollingEventSource :: s pollingEventSource :: s
-> (EventSourcePolyfill -> s -> HandlerT site IO ([ES.ServerEvent], s)) -> (EventSourcePolyfill -> s -> HandlerFor site ([ES.ServerEvent], s))
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
pollingEventSource initial act = do pollingEventSource initial act = do
polyfill <- prepareForEventSource polyfill <- prepareForEventSource
let -- Get new events to be sent. let -- Get new events to be sent.
@ -79,8 +82,8 @@ pollingEventSource initial act = do
[] -> getEvents s' [] -> getEvents s'
_ -> do _ -> do
let (builder, continue) = joinEvents evs mempty let (builder, continue) = joinEvents evs mempty
C.yield (C.Chunk builder) yield (Chunk builder)
C.yield C.Flush yield Flush
when continue (getEvents s') when continue (getEvents s')
-- Join all events in a single Builder. Returns @False@ -- 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. -- outputted, after which no other events are sent to the client.
ioToRepEventSource :: s ioToRepEventSource :: s
-> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s)) -> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
ioToRepEventSource initial act = pollingEventSource initial act' ioToRepEventSource initial act = pollingEventSource initial act'
where act' p s = liftIO (act p s) where act' p s = liftIO (act p s)

4
yesod-eventsource/yesod-eventsource.cabal
View File

@ -1,5 +1,5 @@
name: yesod-eventsource name: yesod-eventsource
version: 1.4.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com> author: Felipe Lessa <felipe.lessa@gmail.com>
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core == 1.4.* , yesod-core == 1.6.*
, conduit >= 1.3 , conduit >= 1.3
, wai >= 1.3 , wai >= 1.3
, wai-eventsource >= 1.3 , wai-eventsource >= 1.3

4
yesod-form/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.16 ## 1.4.16
* Korean translation * Korean translation

2
yesod-form/Yesod/Form/Bootstrap3.hs
View File

@ -186,7 +186,7 @@ renderBootstrap3 formLayout aform fragment = do
-- | (Internal) Render a help widget for tooltips and errors. -- | (Internal) Render a help widget for tooltips and errors.
helpWidget :: FieldView site -> WidgetT site IO () helpWidget :: FieldView site -> WidgetFor site ()
helpWidget view = [whamlet| helpWidget view = [whamlet|
$maybe tt <- fvTooltip view $maybe tt <- fvTooltip view
<span .help-block>#{tt} <span .help-block>#{tt}

49
yesod-form/Yesod/Form/Fields.hs
View File

@ -161,10 +161,9 @@ $newline never
} }
where showVal = either id (pack . show) 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 :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
timeField = timeFieldTypeText timeField = timeFieldTypeTime
{-# 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." #-}
-- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> will fallback to a text field, and Yesod will parse the time as described in 'timeFieldTypeText'. -- | Creates an input with @type="time"@. <http://caniuse.com/#search=time%20input%20type Browsers not supporting this type> 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" 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). -- | 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. -- 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 -- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectFieldList = selectField . optionsPairs selectFieldList = selectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting one option. Example usage: -- | Creates a @\<select>@ tag for selecting one option. Example usage:
-- --
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing -- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
selectField :: (Eq a, RenderMessage site FormMessage) selectField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectField = selectFieldHelper selectField = selectFieldHelper
(\theId name attrs inside -> [whamlet| (\theId name attrs inside -> [whamlet|
$newline never $newline never
@ -446,13 +447,13 @@ $newline never
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectFieldList :: (Eq a, RenderMessage site msg) multiSelectFieldList :: (Eq a, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
multiSelectFieldList = multiSelectField . optionsPairs multiSelectFieldList = multiSelectField . optionsPairs
-- | Creates a @\<select>@ tag for selecting multiple options. -- | Creates a @\<select>@ tag for selecting multiple options.
multiSelectField :: Eq a multiSelectField :: Eq a
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
multiSelectField ioptlist = multiSelectField ioptlist =
Field parse view UrlEncoded Field parse view UrlEncoded
where where
@ -478,18 +479,18 @@ multiSelectField ioptlist =
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg) radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
=> [(msg, a)] => [(msg, a)]
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
radioFieldList = radioField . optionsPairs radioFieldList = radioField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)] checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
checkboxesFieldList = checkboxesField . optionsPairs checkboxesFieldList = checkboxesField . optionsPairs
-- | Creates an input with @type="checkbox"@ for selecting multiple options. -- | Creates an input with @type="checkbox"@ for selecting multiple options.
checkboxesField :: Eq a checkboxesField :: Eq a
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) [a] -> Field (HandlerFor site) [a]
checkboxesField ioptlist = (multiSelectField ioptlist) checkboxesField ioptlist = (multiSelectField ioptlist)
{ fieldView = { fieldView =
\theId name attrs val _isReq -> do \theId name attrs val _isReq -> do
@ -506,8 +507,8 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
} }
-- | Creates an input with @type="radio"@ for selecting one option. -- | Creates an input with @type="radio"@ for selecting one option.
radioField :: (Eq a, RenderMessage site FormMessage) radioField :: (Eq a, RenderMessage site FormMessage)
=> HandlerT site IO (OptionList a) => HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
radioField = selectFieldHelper radioField = selectFieldHelper
(\theId _name _attrs inside -> [whamlet| (\theId _name _attrs inside -> [whamlet|
$newline never $newline never
@ -663,7 +664,7 @@ optionsPersist :: ( YesodPersist site
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Entity a)) -> HandlerFor site (OptionList (Entity a))
#else #else
optionsPersist :: ( YesodPersist site, PersistEntity a optionsPersist :: ( YesodPersist site, PersistEntity a
, PersistQuery (PersistEntityBackend a) , PersistQuery (PersistEntityBackend a)
@ -674,7 +675,7 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Entity a)) -> HandlerFor site (OptionList (Entity a))
#endif #endif
optionsPersist filts ords toDisplay = fmap mkOptionList $ do optionsPersist filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
@ -701,7 +702,7 @@ optionsPersistKey
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Key a)) -> HandlerFor site (OptionList (Key a))
#else #else
optionsPersistKey optionsPersistKey
:: (YesodPersist site :: (YesodPersist site
@ -714,7 +715,7 @@ optionsPersistKey
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Key a)) -> HandlerFor site (OptionList (Key a))
#endif #endif
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
@ -728,11 +729,11 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
selectFieldHelper selectFieldHelper
:: (Eq a, RenderMessage site FormMessage) :: (Eq a, RenderMessage site FormMessage)
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ()) => (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())
-> (Text -> Text -> Bool -> WidgetT site IO ()) -> (Text -> Text -> Bool -> WidgetFor site ())
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ()) -> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())
-> HandlerT site IO (OptionList a) -> HandlerFor site (OptionList a)
-> Field (HandlerT site IO) a -> Field (HandlerFor site) a
selectFieldHelper outside onOpt inside opts' = Field selectFieldHelper outside onOpt inside opts' = Field
{ fieldParse = \x _ -> do { fieldParse = \x _ -> do
opts <- opts' opts <- opts'

6
yesod-form/Yesod/Form/Functions.hs
View File

@ -385,8 +385,8 @@ getHelper form env = do
identifyForm identifyForm
:: Monad m :: Monad m
=> Text -- ^ Form identification string. => Text -- ^ Form identification string.
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) -> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
identifyForm identVal form = \fragment -> do identifyForm identVal form = \fragment -> do
-- Create hidden <input>. -- Create hidden <input>.
let fragment' = let fragment' =
@ -418,7 +418,7 @@ identifyFormKey = "_formid"
type FormRender m a = type FormRender m a =
AForm m a AForm m a
-> Html -> Html
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()) -> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
-- | Render a form into a series of tr tags. Note that, in order to allow -- | Render a form into a series of tr tags. Note that, in order to allow

10
yesod-form/Yesod/Form/Jquery.hs
View File

@ -53,16 +53,16 @@ class YesodJquery a where
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js" 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" jqueryDayField = flip jqueryDayField' "date"
-- | Use jQuery's datepicker as the underlying implementation. -- | Use jQuery's datepicker as the underlying implementation.
-- --
-- Since 1.4.3 -- 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" 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 jqueryDayField' jds inputType = Field
{ fieldParse = parseHelper $ maybe { fieldParse = parseHelper $ maybe
(Left MsgInvalidDay) (Left MsgInvalidDay)
@ -107,13 +107,13 @@ $(function(){
] ]
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
=> Route site -> Field (HandlerT site IO) Text => Route site -> Field (HandlerFor site) Text
jqueryAutocompleteField = jqueryAutocompleteField' 2 jqueryAutocompleteField = jqueryAutocompleteField' 2
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site) jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
=> Int -- ^ autocomplete minimum length => Int -- ^ autocomplete minimum length
-> Route site -> Route site
-> Field (HandlerT site IO) Text -> Field (HandlerFor site) Text
jqueryAutocompleteField' minLen src = Field jqueryAutocompleteField' minLen src = Field
{ fieldParse = parseHelper $ Right { fieldParse = parseHelper $ Right
, fieldView = \theId name attrs val isReq -> do , fieldView = \theId name attrs val isReq -> do

14
yesod-form/Yesod/Form/MassInput.hs
View File

@ -44,17 +44,17 @@ up i = do
-- | Generate a form that accepts 0 or more values from the user, allowing the -- | Generate a form that accepts 0 or more values from the user, allowing the
-- user to specify that a new row is necessary. -- 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 => Html
-- ^ label for the form -- ^ label for the form
-> ([[FieldView site]] -> xml) -> ([[FieldView site]] -> xml)
-- ^ how to display the rows, usually either 'massDivs' or 'massTable' -- ^ 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 -- ^ display a single row of the form, where @Maybe a@ gives the
-- previously submitted value -- previously submitted value
-> Maybe [a] -> Maybe [a]
-- ^ default initial values for the form -- ^ default initial values for the form
-> AForm (HandlerT site IO) [a] -> AForm (HandlerFor site) [a]
inputList label fixXml single mdef = formToAForm $ do inputList label fixXml single mdef = formToAForm $ do
theId <- lift newIdent theId <- lift newIdent
down 1 down 1
@ -94,9 +94,9 @@ $newline never
, fvRequired = False , fvRequired = False
}]) }])
withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage) withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
=> AForm (HandlerT site IO) a => AForm (HandlerFor site) a
-> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site])) -> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
withDelete af = do withDelete af = do
down 1 down 1
deleteName <- newFormIdent deleteName <- newFormIdent
@ -129,7 +129,7 @@ fixme eithers =
massDivs, massTable massDivs, massTable
:: [[FieldView site]] :: [[FieldView site]]
-> WidgetT site IO () -> WidgetFor site ()
massDivs viewss = [whamlet| massDivs viewss = [whamlet|
$newline never $newline never
$forall views <- viewss $forall views <- viewss

2
yesod-form/Yesod/Form/Nic.hs
View File

@ -29,7 +29,7 @@ class Yesod a => YesodNic a where
urlNicEdit :: a -> Either (Route a) Text urlNicEdit :: a -> Either (Route a) Text
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js" 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 nicHtmlField = Field
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e { fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
, fieldView = \theId name attrs val _isReq -> do , fieldView = \theId name attrs val _isReq -> do

4
yesod-form/Yesod/Form/Types.hs
View File

@ -189,7 +189,7 @@ data FieldView site = FieldView
{ fvLabel :: Html { fvLabel :: Html
, fvTooltip :: Maybe Html , fvTooltip :: Maybe Html
, fvId :: Text , fvId :: Text
, fvInput :: WidgetT site IO () , fvInput :: WidgetFor site ()
, fvErrors :: Maybe Html , fvErrors :: Maybe Html
, fvRequired :: Bool , fvRequired :: Bool
} }
@ -200,7 +200,7 @@ type FieldViewFunc m a
-> [(Text, Text)] -- ^ Attributes -> [(Text, Text)] -- ^ Attributes
-> Either Text a -- ^ Either (invalid text) or (legitimate result) -> Either Text a -- ^ Either (invalid text) or (legitimate result)
-> Bool -- ^ Required? -> Bool -- ^ Required?
-> WidgetT (HandlerSite m) IO () -> WidgetFor (HandlerSite m) ()
data Field m a = Field data Field m a = Field
{ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)) { fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))

6
yesod-form/yesod-form.cabal
View File

@ -1,5 +1,5 @@
name: yesod-form name: yesod-form
version: 1.4.16 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -20,8 +20,8 @@ flag network-uri
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4.14 && < 1.5 , yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.4 && < 1.5 , yesod-persistent >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, shakespeare >= 2.0 , shakespeare >= 2.0
, persistent , persistent

4
yesod-newsfeed/ChangeLog.md
View File

@ -1,5 +1,9 @@
# Changelog # Changelog
## 1.6.1
* Upgrade to yesod-core 1.6.0
## 1.6 ## 1.6
* Create new datatype `EntryEnclosure` for self-documentation of `feedEntryEnclosure`. * Create new datatype `EntryEnclosure` for self-documentation of `feedEntryEnclosure`.

4
yesod-newsfeed/yesod-newsfeed.cabal
View File

@ -1,5 +1,5 @@
name: yesod-newsfeed name: yesod-newsfeed
version: 1.6 version: 1.6.1.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, shakespeare >= 2.0 , shakespeare >= 2.0
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4

4
yesod-persistent/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.4.3 ## 1.4.3
* Fix overly powerful constraints on get404 and getBy404. * Fix overly powerful constraints on get404 and getBy404.

24
yesod-persistent/Yesod/Persist/Core.hs
View File

@ -37,11 +37,11 @@ import qualified Database.Persist.Sql as SQL
unSqlPersistT :: a -> a unSqlPersistT :: a -> a
unSqlPersistT = id 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 class Monad (YesodDB site) => YesodPersist site where
type YesodPersistBackend site type YesodPersistBackend site
runDB :: YesodDB site a -> HandlerT site IO a runDB :: YesodDB site a -> HandlerFor site a
-- | Helper for creating 'runDB'. -- | Helper for creating 'runDB'.
-- --
@ -49,8 +49,8 @@ class Monad (YesodDB site) => YesodPersist site where
defaultRunDB :: PersistConfig c defaultRunDB :: PersistConfig c
=> (site -> c) => (site -> c)
-> (site -> PersistConfigPool c) -> (site -> PersistConfigPool c)
-> PersistConfigBackend c (HandlerT site IO) a -> PersistConfigBackend c (HandlerFor site) a
-> HandlerT site IO a -> HandlerFor site a
defaultRunDB getConfig getPool f = do defaultRunDB getConfig getPool f = do
master <- getYesod master <- getYesod
Database.Persist.runPool Database.Persist.runPool
@ -74,10 +74,10 @@ class YesodPersist site => YesodPersistRunner site where
-- least, a rollback will be used instead. -- least, a rollback will be used instead.
-- --
-- Since 1.2.0 -- Since 1.2.0
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ()) getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ())
newtype DBRunner site = DBRunner 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'. -- | Helper for implementing 'getDBRunner'.
@ -86,11 +86,11 @@ newtype DBRunner site = DBRunner
#if MIN_VERSION_persistent(2,5,0) #if MIN_VERSION_persistent(2,5,0)
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend) defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
=> (site -> Pool backend) => (site -> Pool backend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ()) -> HandlerFor site (DBRunner site, HandlerFor site ())
#else #else
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
=> (site -> Pool SQL.SqlBackend) => (site -> Pool SQL.SqlBackend)
-> HandlerT site IO (DBRunner site, HandlerT site IO ()) -> HandlerFor site (DBRunner site, HandlerFor site ())
#endif #endif
defaultGetDBRunner getPool = do defaultGetDBRunner getPool = do
pool <- fmap getPool getYesod pool <- fmap getPool getYesod
@ -118,8 +118,8 @@ defaultGetDBRunner getPool = do
-- --
-- Since 1.2.0 -- Since 1.2.0
runDBSource :: YesodPersistRunner site runDBSource :: YesodPersistRunner site
=> Source (YesodDB site) a => ConduitT () a (YesodDB site) ()
-> Source (HandlerT site IO) a -> ConduitT () a (HandlerFor site) ()
runDBSource src = do runDBSource src = do
(dbrunner, cleanup) <- lift getDBRunner (dbrunner, cleanup) <- lift getDBRunner
transPipe (runDBRunner dbrunner) src transPipe (runDBRunner dbrunner) src
@ -128,8 +128,8 @@ runDBSource src = do
-- | Extends 'respondSource' to create a streaming database response body. -- | Extends 'respondSource' to create a streaming database response body.
respondSourceDB :: YesodPersistRunner site respondSourceDB :: YesodPersistRunner site
=> ContentType => ContentType
-> Source (YesodDB site) (Flush Builder) -> ConduitT () (Flush Builder) (YesodDB site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
respondSourceDB ctype = respondSource ctype . runDBSource respondSourceDB ctype = respondSource ctype . runDBSource
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist. -- | Get the given entity by ID, or return a 404 not found if it doesn't exist.

2
yesod-persistent/test/Yesod/PersistSpec.hs
View File

@ -45,7 +45,7 @@ getHomeR = do
insert_ $ Person "Charlie" insert_ $ Person "Charlie"
insert_ $ Person "Alice" insert_ $ Person "Alice"
insert_ $ Person "Bob" insert_ $ Person "Bob"
respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder
where where
toBuilder (Entity _ (Person name)) = do toBuilder (Entity _ (Person name)) = do
yield $ Chunk $ fromText name yield $ Chunk $ fromText name

6
yesod-persistent/yesod-persistent.cabal
View File

@ -1,5 +1,5 @@
name: yesod-persistent name: yesod-persistent
version: 1.4.3 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4.0 && < 1.5 , yesod-core >= 1.6 && < 1.7
, persistent >= 2.1 && < 2.8 , persistent >= 2.8 && < 2.9
, persistent-template >= 2.1 && < 2.8 , persistent-template >= 2.1 && < 2.8
, transformers >= 0.2.2 , transformers >= 0.2.2
, blaze-builder , blaze-builder

3
yesod-sitemap/ChangeLog.md
View File

@ -0,0 +1,3 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0

10
yesod-sitemap/Yesod/Sitemap.hs
View File

@ -74,19 +74,19 @@ robots smurl = do
-- | Serve a stream of @SitemapUrl@s as a sitemap. -- | Serve a stream of @SitemapUrl@s as a sitemap.
-- --
-- Since 1.2.0 -- Since 1.2.0
sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site)) sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) ()
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
sitemap urls = do sitemap urls = do
render <- getUrlRender render <- getUrlRender
respondSource typeXml $ do respondSource typeXml $ do
yield Flush 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 -- | Convenience wrapper for @sitemap@ for the case when the input is an
-- in-memory list. -- in-memory list.
-- --
-- Since 1.2.0 -- Since 1.2.0
sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent
sitemapList = sitemap . mapM_ yield sitemapList = sitemap . mapM_ yield
-- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL -- | 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 -- Since 1.2.0
sitemapConduit :: Monad m sitemapConduit :: Monad m
=> (a -> Text) => (a -> Text)
-> Conduit (SitemapUrl a) m Event -> ConduitT (SitemapUrl a) Event m ()
sitemapConduit render = do sitemapConduit render = do
yield EventBeginDocument yield EventBeginDocument
element "urlset" [] $ awaitForever goUrl element "urlset" [] $ awaitForever goUrl

4
yesod-sitemap/yesod-sitemap.cabal
View File

@ -1,5 +1,5 @@
name: yesod-sitemap name: yesod-sitemap
version: 1.4.0.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
library library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, time >= 1.1.4 , time >= 1.1.4
, xml-conduit >= 1.0 , xml-conduit >= 1.0
, text , text

4
yesod-static/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.5.3.1 ## 1.5.3.1
* Switch to cryptonite * Switch to cryptonite

5
yesod-static/Yesod/EmbeddedStatic.hs
View File

@ -57,10 +57,7 @@ import Network.HTTP.Types.Status (status404)
import Network.Wai (responseLBS, pathInfo) import Network.Wai (responseLBS, pathInfo)
import Network.Wai.Application.Static (staticApp) import Network.Wai.Application.Static (staticApp)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Yesod.Core import Yesod.Core (YesodSubDispatch(..))
( HandlerT
, YesodSubDispatch(..)
)
import Yesod.Core.Types import Yesod.Core.Types
( YesodSubRunnerEnv(..) ( YesodSubRunnerEnv(..)
, YesodRunnerEnv(..) , YesodRunnerEnv(..)

4
yesod-static/Yesod/EmbeddedStatic/Internal.hs
View File

@ -25,7 +25,7 @@ import Network.Wai
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp) import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
import WaiAppStatic.Types import WaiAppStatic.Types
import Yesod.Core import Yesod.Core
( HandlerT ( HandlerFor
, ParseRoute(..) , ParseRoute(..)
, RenderRoute(..) , RenderRoute(..)
, getYesod , getYesod
@ -136,7 +136,7 @@ develApp settings extra req sendResponse = do
-- | The type of 'addStaticContent' -- | The type of 'addStaticContent'
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString 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. -- | Helper for embedStaticContent and embedLicensedStaticContent.
staticContentHelper :: (site -> EmbeddedStatic) staticContentHelper :: (site -> EmbeddedStatic)

2
yesod-static/Yesod/Static.hs
View File

@ -68,7 +68,6 @@ import qualified System.FilePath as FP
import Control.Monad import Control.Monad
import Data.FileEmbed (embedDir) import Data.FileEmbed (embedDir)
import Control.Monad.Trans.Resource (runResourceT)
import Yesod.Core import Yesod.Core
import Yesod.Core.Types import Yesod.Core.Types
@ -94,7 +93,6 @@ import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime) import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime) import System.Posix.Types (EpochTime)
import Conduit import Conduit
import Data.Functor.Identity (runIdentity)
import System.FilePath ((</>), (<.>), takeDirectory) import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F import qualified System.FilePath as F
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL

6
yesod-static/yesod-static.cabal
View File

@ -1,5 +1,5 @@
name: yesod-static name: yesod-static
version: 1.5.3.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -29,7 +29,7 @@ library
build-depends: base >= 4 && < 5 build-depends: base >= 4 && < 5
, containers >= 0.2 , containers >= 0.2
, old-time >= 1.0 , old-time >= 1.0
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, base64-bytestring >= 0.1.0.1 , base64-bytestring >= 0.1.0.1
, byteable >= 0.1 , byteable >= 0.1
, bytestring >= 0.9.1.4 , bytestring >= 0.9.1.4
@ -91,7 +91,7 @@ test-suite tests
YesodStaticTest YesodStaticTest
build-depends: base build-depends: base
, hspec >= 1.3 , hspec >= 1.3
, yesod-test >= 1.4 , yesod-test >= 1.6
, wai-extra , wai-extra
, HUnit , HUnit

4
yesod-test/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6.0
## 1.5.9.1 ## 1.5.9.1
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473) * Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473)

99
yesod-test/Yesod/Test.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-| {-|
Yesod.Test is a pragmatic framework for testing web applications built Yesod.Test is a pragmatic framework for testing web applications built
@ -63,6 +64,7 @@ module Yesod.Test
, addFile , addFile
, setRequestBody , setRequestBody
, RequestBuilder , RequestBuilder
, SIO
, setUrl , setUrl
, clickOn , clickOn
@ -136,6 +138,7 @@ import Data.CaseInsensitive (CI)
import Network.Wai import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request) import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
import Control.Monad.Trans.Reader (ReaderT (..)) import Control.Monad.Trans.Reader (ReaderT (..))
import Conduit (MonadThrow)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import System.IO import System.IO
import Yesod.Core.Unsafe (runFakeHandler) import Yesod.Core.Unsafe (runFakeHandler)
@ -181,7 +184,7 @@ data YesodExampleData site = YesodExampleData
-- | A single test case, to be run with 'yit'. -- | A single test case, to be run with 'yit'.
-- --
-- Since 1.2.0 -- Since 1.2.0
type YesodExample site = ReaderT (IORef (YesodExampleData site)) IO type YesodExample site = SIO (YesodExampleData site)
-- | Mapping from cookie name to value. -- | Mapping from cookie name to value.
-- --
@ -204,13 +207,13 @@ data YesodSpecTree site
-- --
-- Since 1.2.0 -- Since 1.2.0
getTestYesod :: YesodExample site site getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite getState getTestYesod = fmap yedSite getSIO
-- | Get the most recently provided response value, if available. -- | Get the most recently provided response value, if available.
-- --
-- Since 1.2.0 -- Since 1.2.0
getResponse :: YesodExample site (Maybe SResponse) getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse getState getResponse = fmap yedResponse getSIO
data RequestBuilderData site = RequestBuilderData data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData { rbdPostData :: RBDPostData
@ -233,7 +236,7 @@ data RequestPart
-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments -- | 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 -- 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. -- 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' -- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool' -- and 'ConnectionPool'
@ -250,7 +253,7 @@ yesodSpec site yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- toWaiAppPlain site app <- toWaiAppPlain site
evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -270,7 +273,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
site <- getSiteAction' site <- getSiteAction'
app <- toWaiAppPlain site app <- toWaiAppPlain site
evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -291,7 +294,7 @@ yesodSpecApp site getApp yspecs =
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
app <- getApp app <- getApp
evalStateT y YesodExampleData evalSIO y YesodExampleData
{ yedApp = app { yedApp = app
, yedSite = site , yedSite = site
, yedCookies = M.empty , 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 -- Performs a given action using the last response. Use this to create
-- response-level assertions -- response-level assertions
withResponse' :: MonadIO m withResponse' :: (state -> Maybe SResponse)
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> (SResponse -> ReaderT (IORef state) m a) -> (SResponse -> SIO state a)
-> ReaderT (IORef state) m a -> SIO state a
withResponse' getter errTrace f = maybe err f . getter =<< getState withResponse' getter errTrace f = maybe err f . getter =<< getSIO
where err = failure msg where err = failure msg
msg = if null errTrace msg = if null errTrace
then "There was no response, you should make a request." then "There was no response, you should make a request."
@ -328,11 +330,10 @@ parseHTML :: HtmlLBS -> Cursor
parseHTML html = fromDocument $ HD.parseLBS html parseHTML html = fromDocument $ HD.parseLBS html
-- | Query the last response using CSS selectors, returns a list of matched fragments -- | Query the last response using CSS selectors, returns a list of matched fragments
htmlQuery' :: MonadIO m htmlQuery' :: (state -> Maybe SResponse)
=> (state -> Maybe SResponse)
-> [T.Text] -> [T.Text]
-> Query -> 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 -> 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 case findBySelector (simpleBody res) query of
Left err -> failure $ query <> " did not parse: " <> T.pack (show err) 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. -- | Add a parameter with the given name and value to the request body.
addPostParam :: T.Text -> T.Text -> RequestBuilder site () addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
addPostParam name value = 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." where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
addPostData (MultipleItemsPostData posts) = addPostData (MultipleItemsPostData posts) =
MultipleItemsPostData $ ReqKvPart name value : posts MultipleItemsPostData $ ReqKvPart name value : posts
-- | Add a parameter with the given name and value to the query string. -- | Add a parameter with the given name and value to the query string.
addGetParam :: T.Text -> T.Text -> RequestBuilder site () 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 = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd : rbdGets rbd
} }
@ -523,7 +524,7 @@ addFile :: T.Text -- ^ The parameter name for the file.
-> RequestBuilder site () -> RequestBuilder site ()
addFile name path mimetype = do addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path 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." where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
addPostData (MultipleItemsPostData posts) contents = addPostData (MultipleItemsPostData posts) contents =
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts 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. -- 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 :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
genericNameFromLabel match label = do genericNameFromLabel match label = do
mres <- fmap rbdResponse getState mres <- fmap rbdResponse getSIO
res <- res <-
case mres of case mres of
Nothing -> failure "genericNameFromLabel: No response available" Nothing -> failure "genericNameFromLabel: No response available"
@ -799,7 +800,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- Since 1.4.3.2 -- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do getRequestCookies = do
requestBuilderData <- getState requestBuilderData <- getSIO
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
Just h -> return h Just h -> return h
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up." Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
@ -907,7 +908,7 @@ getLocation = do
-- > request $ do -- > request $ do
-- > setMethod methodPut -- > setMethod methodPut
setMethod :: H.Method -> RequestBuilder site () 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. -- | Sets the URL used by the request.
-- --
@ -922,7 +923,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
=> url => url
-> RequestBuilder site () -> RequestBuilder site ()
setUrl url' = do setUrl url' = do
site <- fmap rbdSite getState site <- fmap rbdSite getSIO
eurl <- Yesod.Core.Unsafe.runFakeHandler eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty M.empty
(const $ error "Yesod.Test: No logger available") (const $ error "Yesod.Test: No logger available")
@ -930,7 +931,7 @@ setUrl url' = do
(toTextUrl url') (toTextUrl url')
url <- either (error . show) return eurl url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url let (urlPath, urlQuery) = T.break (== '?') url
modifyState $ \rbd -> rbd modifySIO $ \rbd -> rbd
{ rbdPath = { rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest ("http:":_:rest) -> rest
@ -969,7 +970,7 @@ clickOn query = do
-- > request $ do -- > request $ do
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)] -- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
setRequestBody :: BSL8.ByteString -> RequestBuilder site () 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. -- | 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 -- > request $ do
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0") -- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
addRequestHeader :: H.Header -> RequestBuilder site () addRequestHeader :: H.Header -> RequestBuilder site ()
addRequestHeader header = modifyState $ \rbd -> rbd addRequestHeader header = modifySIO $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd { rbdHeaders = header : rbdHeaders rbd
} }
@ -999,9 +1000,9 @@ addRequestHeader header = modifyState $ \rbd -> rbd
request :: RequestBuilder site () request :: RequestBuilder site ()
-> YesodExample site () -> YesodExample site ()
request reqBuilder = do 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 [] { rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes , rbdResponse = mRes
, rbdMethod = "GET" , rbdMethod = "GET"
@ -1041,7 +1042,7 @@ request reqBuilder = do
}) app }) app
let newCookies = parseSetCookies $ simpleHeaders response let newCookies = parseSetCookies $ simpleHeaders response
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies 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 where
isFile (ReqFilePart _ _ _ _) = True isFile (ReqFilePart _ _ _ _) = True
isFile _ = False isFile _ = False
@ -1145,14 +1146,14 @@ testApp :: site -> Middleware -> TestApp site
testApp site middleware = (site, middleware) testApp site middleware = (site, middleware)
type YSpec site = Hspec.SpecWith (TestApp site) type YSpec site = Hspec.SpecWith (TestApp site)
instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData site)) IO a) where instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
type Arg (ReaderT (IORef (YesodExampleData site)) IO a) = TestApp site type Arg (SIO (YesodExampleData site) a) = TestApp site
evaluateExample example params action = evaluateExample example params action =
Hspec.evaluateExample Hspec.evaluateExample
(action $ \(site, middleware) -> do (action $ \(site, middleware) -> do
app <- toWaiAppPlain site app <- toWaiAppPlain site
_ <- evalStateT example YesodExampleData _ <- evalSIO example YesodExampleData
{ yedApp = middleware app { yedApp = middleware app
, yedSite = site , yedSite = site
, yedCookies = M.empty , yedCookies = M.empty
@ -1162,24 +1163,26 @@ instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData s
params params
($ ()) ($ ())
getState :: MonadIO m => ReaderT (IORef s) m s -- | State + IO
getState = ReaderT $ liftIO . readIORef --
-- @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 () getSIO :: SIO s s
putState x = ReaderT $ \ref -> liftIO $ writeIORef ref $! x getSIO = SIO $ ReaderT readIORef
modifyState :: MonadIO m => (s -> s) -> ReaderT (IORef s) m () putSIO :: s -> SIO s ()
modifyState f = ReaderT $ \ref -> liftIO $ do putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
x <- readIORef ref
writeIORef ref $! f x
evalStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m a modifySIO :: (s -> s) -> SIO s ()
evalStateT (ReaderT f) s = do modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
ref <- liftIO $ newIORef s
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 f ref
readIORef 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

2
yesod-test/test/main.hs
View File

@ -37,7 +37,7 @@ import Data.ByteString.Lazy.Char8 ()
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Text.HTML.DOM as HD import qualified Text.HTML.DOM as HD
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
import UnliftIO (tryAny, SomeException, try) import UnliftIO.Exception (tryAny, SomeException, try)
parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery parseQuery_ = either error id . parseQuery

8
yesod-test/yesod-test.cabal
View File

@ -1,5 +1,5 @@
name: yesod-test name: yesod-test
version: 1.5.9.1 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Nubis <nubis@woobiz.com.ar> author: Nubis <nubis@woobiz.com.ar>
@ -27,7 +27,6 @@ library
, hspec-core == 2.* , hspec-core == 2.*
, html-conduit >= 0.1 , html-conduit >= 0.1
, http-types >= 0.7 , http-types >= 0.7
, monad-control
, network >= 2.2 , network >= 2.2
, persistent >= 1.0 , persistent >= 1.0
, pretty-show >= 1.6 , pretty-show >= 1.6
@ -38,7 +37,8 @@ library
, wai-extra , wai-extra
, xml-conduit >= 1.0 , xml-conduit >= 1.0
, xml-types >= 0.3 , xml-types >= 0.3
, yesod-core >= 1.4.14 , yesod-core >= 1.6
, conduit
exposed-modules: Yesod.Test exposed-modules: Yesod.Test
Yesod.Test.CssQuery Yesod.Test.CssQuery
@ -58,7 +58,7 @@ test-suite test
, containers , containers
, html-conduit , html-conduit
, yesod-core , yesod-core
, yesod-form >= 1.4.14 , yesod-form >= 1.6
, text , text
, wai , wai
, http-types , http-types

4
yesod-websockets/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 0.3.0
* Upgrade to yesod-core 1.6
## 0.2.6 ## 0.2.6
* Fix warnings * Fix warnings

151
yesod-websockets/Yesod/WebSockets.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Yesod.WebSockets module Yesod.WebSockets
@ -34,10 +33,9 @@ module Yesod.WebSockets
, WS.ConnectionOptions (..) , WS.ConnectionOptions (..)
) where ) where
import Control.Monad (forever, void, when) import Control.Monad (forever, when)
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask)
import qualified Data.Conduit as C import Conduit
import qualified Data.Conduit.List as CL
import qualified Network.Wai.Handler.WebSockets as WaiWS import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y import qualified Yesod.Core as Y
@ -55,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection
-- instead. -- instead.
-- --
-- Since 0.1.0 -- 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 webSockets = webSocketsOptions WS.defaultConnectionOptions
-- | Varient of 'webSockets' which allows you to specify -- | Varient of 'webSockets' which allows you to specify
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection. -- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
-- --
-- Since 0.2.5 -- Since 0.2.5
webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m) webSocketsOptions
=> WS.ConnectionOptions :: (MonadUnliftIO m, Y.MonadHandler m)
-> WebSocketsT m () => WS.ConnectionOptions
-> m () -> WebSocketsT m ()
#if MIN_VERSION_websockets(0,10,0) -> m ()
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing [] 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' -- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
-- setttings when upgrading to a websocket connection. -- setttings when upgrading to a websocket connection.
-- --
-- Since 0.2.4 -- Since 0.2.4
webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m) webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest)) => (WS.RequestHead -> m (Maybe WS.AcceptRequest))
-- ^ A Nothing indicates that the websocket upgrade request should not happen -- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows -- 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. -- setttings when upgrading to a websocket connection.
-- --
-- Since 0.2.5 -- Since 0.2.5
webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m) webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions => WS.ConnectionOptions
-- ^ Custom websockets options -- ^ Custom websockets options
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest)) -> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
@ -125,100 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
sink sink
-- | Wrapper for capturing exceptions -- | Wrapper for capturing exceptions
wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ()) wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x => (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 :: (MonadIO m, MonadReader WS.Connection m)
wrapWS ws x = ReaderT $ liftIO . flip ws x => (WS.Connection -> a -> IO ())
-> a
-> m ()
wrapWS ws x = do
conn <- ask
liftIO $ ws conn x
-- | Receive a piece of data from the client. -- | Receive a piece of data from the client.
-- --
-- Since 0.1.0 -- Since 0.1.0
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a receiveData
receiveData = ReaderT $ liftIO . WS.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. -- | Receive a piece of data from the client.
-- Capture SomeException as the result or operation -- Capture SomeException as the result or operation
-- Since 0.2.2 -- Since 0.2.2
receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a) receiveDataE
receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData :: (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. -- | Receive an application message.
-- Capture SomeException as the result or operation -- Capture SomeException as the result or operation
-- Since 0.2.3 -- Since 0.2.3
receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage) receiveDataMessageE
receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage :: (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. -- | Send a textual message to the client.
-- --
-- Since 0.1.0 -- 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 sendTextData = wrapWS WS.sendTextData
-- | Send a textual message to the client. -- | Send a textual message to the client.
-- Capture SomeException as the result or operation -- Capture SomeException as the result or operation
-- and can be used like -- and can be used like
-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)` -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
-- Since 0.2.2 -- 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 sendTextDataE = wrapWSE WS.sendTextData
-- | Send a binary message to the client. -- | Send a binary message to the client.
-- --
-- Since 0.1.0 -- 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 sendBinaryData = wrapWS WS.sendBinaryData
-- | Send a binary message to the client. -- | Send a binary message to the client.
-- Capture SomeException as the result of operation -- Capture SomeException as the result of operation
-- Since 0.2.2 -- 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 sendBinaryDataE = wrapWSE WS.sendBinaryData
-- | Send a ping message to the client. -- | Send a ping message to the client.
-- --
-- Since 0.2.2 -- 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 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 -- Capture SomeException as the result of operation
-- Since 0.2.2 -- 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 sendPingE = wrapWSE WS.sendPing
-- | Send a DataMessage to the client. -- | Send a DataMessage to the client.
-- Capture SomeException as the result of operation -- Capture SomeException as the result of operation
-- Since 0.2.3 -- Since 0.2.3
sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ()) sendDataMessageE
sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x) :: (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 -- 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 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 -- Capture SomeException as the result of operation
-- Since 0.2.2 -- 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 sendCloseE = wrapWSE WS.sendClose
-- | A @Source@ of WebSockets data from the user. -- | A @Source@ of WebSockets data from the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a sourceWS
sourceWS = forever $ Y.lift receiveData >>= C.yield :: (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. -- | A @Sink@ for sending textual data to the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSText
sinkWSText = CL.mapM_ sendTextData :: (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. -- | A @Sink@ for sending binary data to the user.
-- --
-- Since 0.1.0 -- Since 0.1.0
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSBinary
sinkWSBinary = CL.mapM_ sendBinaryData :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
=> ConduitT a o m ()
sinkWSBinary = mapM_C sendBinaryData

9
yesod-websockets/yesod-websockets.cabal
View File

@ -1,5 +1,5 @@
name: yesod-websockets name: yesod-websockets
version: 0.2.6 version: 0.3.0
synopsis: WebSockets support for Yesod synopsis: WebSockets support for Yesod
description: WebSockets support for Yesod description: WebSockets support for Yesod
homepage: https://github.com/yesodweb/yesod homepage: https://github.com/yesodweb/yesod
@ -21,11 +21,12 @@ library
, wai , wai
, wai-websockets >= 2.1 , wai-websockets >= 2.1
, websockets >= 0.9 , websockets >= 0.10
, transformers >= 0.2 , transformers >= 0.2
, yesod-core >= 1.4 , yesod-core >= 1.6
, unliftio , unliftio
, conduit >= 1.0.15.1 , conduit >= 1.3
, mtl
source-repository head source-repository head
type: git type: git

4
yesod/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.0
* Upgrade to yesod-core 1.6
## 1.4.5 ## 1.4.5
* Fix warnings * Fix warnings

2
yesod/Yesod/Default/Util.hs
View File

@ -40,7 +40,7 @@ addStaticContentExternal
-> Text -- ^ filename extension -> Text -- ^ filename extension
-> Text -- ^ mime type -> Text -- ^ mime type
-> L.ByteString -- ^ file contents -> 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 addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn' exists <- liftIO $ doesFileExist fn'

9
yesod/yesod.cabal
View File

@ -1,5 +1,5 @@
name: yesod name: yesod
version: 1.4.5 version: 1.6.0
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com> author: Michael Snoyman <michael@snoyman.com>
@ -18,10 +18,9 @@ library
cpp-options: -DWINDOWS cpp-options: -DWINDOWS
build-depends: base >= 4.6 && < 5 build-depends: base >= 4.6 && < 5
, yesod-core >= 1.4 && < 1.5 , yesod-core >= 1.6 && < 1.7
, yesod-persistent >= 1.4 && < 1.5 , yesod-persistent >= 1.6 && < 1.7
, yesod-form >= 1.4 && < 1.5 , yesod-form >= 1.6 && < 1.7
, monad-control >= 0.3 && < 1.1
, transformers >= 0.2.2 , transformers >= 0.2.2
, wai >= 1.3 , wai >= 1.3
, wai-extra >= 1.3 , wai-extra >= 1.3