Merge branch 'better-monads' into no-transformers
This commit is contained in:
Michael Snoyman
commit
6830a9840c
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.2
|
||||
|
||||
* Fix warnings
|
||||
|
||||
@ -15,16 +15,15 @@ module Yesod.Auth.OAuth
|
||||
) where
|
||||
import Control.Applicative as A ((<$>), (<*>))
|
||||
import Control.Arrow ((***))
|
||||
import Control.Exception (Exception, throwIO)
|
||||
import UnliftIO.Exception
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO)
|
||||
import UnliftIO (MonadUnliftIO)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Data.Typeable
|
||||
import Web.Authenticate.OAuth
|
||||
import Yesod.Auth
|
||||
import Yesod.Form
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-auth-oauth
|
||||
version: 1.4.2
|
||||
version: 1.6.0
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Hiromi Ishii
|
||||
@ -23,12 +23,12 @@ library
|
||||
build-depends: base >= 4 && < 4.3
|
||||
build-depends: authenticate-oauth >= 1.5 && < 1.7
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-auth >= 1.4 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-auth >= 1.6 && < 1.7
|
||||
, text >= 0.7
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
, transformers >= 0.2.2 && < 0.6
|
||||
, unliftio-core
|
||||
, unliftio
|
||||
exposed-modules: Yesod.Auth.OAuth
|
||||
ghc-options: -Wall
|
||||
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.21
|
||||
|
||||
* Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)
|
||||
|
||||
@ -50,7 +50,7 @@ module Yesod.Auth
|
||||
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO)
|
||||
import UnliftIO (withRunInIO, MonadUnliftIO)
|
||||
|
||||
import Yesod.Auth.Routes
|
||||
import Data.Aeson hiding (json)
|
||||
@ -314,8 +314,8 @@ loginErrorMessageMasterI dest msg = do
|
||||
|
||||
-- | For HTML, set the message and redirect to the route.
|
||||
-- For JSON, send the message and a 401 status
|
||||
loginErrorMessage :: YesodAuth master
|
||||
=> Route master
|
||||
loginErrorMessage
|
||||
:: Route master
|
||||
-> Text
|
||||
-> AuthHandler master TypedContent
|
||||
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
|
||||
|
||||
@ -84,7 +84,7 @@ import qualified Data.Aeson.Encode as A
|
||||
import Data.Aeson.Parser (json')
|
||||
import Data.Aeson.Types (FromJSON (parseJSON), parseEither,
|
||||
parseMaybe, withObject, withText)
|
||||
import Data.Conduit (($$+-), ($$), (.|), runConduit)
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Attoparsec (sinkParser)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
@ -274,7 +274,7 @@ getPerson :: Manager -> Token -> AuthHandler site (Maybe Person)
|
||||
getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do
|
||||
req <- personValueRequest token
|
||||
res <- http req manager
|
||||
responseBody res $$+- sinkParser json'
|
||||
runConduit $ responseBody res .| sinkParser json'
|
||||
)
|
||||
|
||||
personValueRequest :: MonadIO m => Token -> m Request
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-auth
|
||||
version: 1.4.21
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -23,7 +23,7 @@ library
|
||||
build-depends: base >= 4 && < 5
|
||||
, authenticate >= 1.3.4
|
||||
, bytestring >= 0.9.1.4
|
||||
, yesod-core >= 1.4.31 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, wai >= 1.4
|
||||
, template-haskell
|
||||
, base16-bytestring
|
||||
@ -32,13 +32,13 @@ library
|
||||
, random >= 1.0.0.2
|
||||
, text >= 0.7
|
||||
, mime-mail >= 0.3
|
||||
, yesod-persistent >= 1.4
|
||||
, yesod-persistent >= 1.6
|
||||
, shakespeare
|
||||
, containers
|
||||
, unordered-containers
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
, transformers >= 0.2.2
|
||||
, persistent >= 2.5 && < 2.8
|
||||
, persistent >= 2.8 && < 2.9
|
||||
, persistent-template >= 2.1 && < 2.8
|
||||
, http-client >= 0.5
|
||||
, http-client-tls
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
module AddHandler (addHandler) where
|
||||
|
||||
@ -8,7 +9,11 @@ import Data.List (isPrefixOf, isSuffixOf, stripPrefix)
|
||||
import Data.Maybe (fromMaybe, listToMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as TIO
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
import Distribution.PackageDescription.Parse (readGenericPackageDescription)
|
||||
#else
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
#endif
|
||||
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
|
||||
import Distribution.PackageDescription (allBuildInfo, hsSourceDirs)
|
||||
import Distribution.Verbosity (normal)
|
||||
@ -224,7 +229,11 @@ uncapitalize "" = ""
|
||||
|
||||
getSrcDir :: FilePath -> IO FilePath
|
||||
getSrcDir cabal = do
|
||||
#if MIN_VERSION_Cabal(2, 0, 0)
|
||||
pd <- flattenPackageDescription <$> readGenericPackageDescription normal cabal
|
||||
#else
|
||||
pd <- flattenPackageDescription <$> readPackageDescription normal cabal
|
||||
#endif
|
||||
let buildInfo = allBuildInfo pd
|
||||
srcDirs = concatMap hsSourceDirs buildInfo
|
||||
return $ fromMaybe "." $ listToMaybe srcDirs
|
||||
|
||||
@ -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
|
||||
@ -1,3 +1,8 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to conduit 1.3.0
|
||||
* Remove configure, build, touch, and test commands
|
||||
|
||||
## 1.5.3
|
||||
|
||||
* Support typed-process-0.2.0.0
|
||||
|
||||
@ -9,8 +9,8 @@ module Devel
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import UnliftIO (race_)
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (race_)
|
||||
import Control.Concurrent.STM
|
||||
import qualified UnliftIO.Exception as Ex
|
||||
import Control.Monad (forever, unless, void,
|
||||
|
||||
@ -3,7 +3,6 @@
|
||||
module HsFile (mkHsFile) where
|
||||
import Text.ProjectTemplate (createTemplate)
|
||||
import Conduit
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import qualified Data.ByteString as BS
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.String (fromString)
|
||||
|
||||
@ -2,37 +2,18 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Monoid
|
||||
import Data.Version (showVersion)
|
||||
import Options.Applicative
|
||||
import System.Environment (getEnvironment)
|
||||
import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure)
|
||||
import System.Process (rawSystem)
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import AddHandler (addHandler)
|
||||
import Devel (DevelOpts (..), devel, develSignal)
|
||||
import Keter (keter)
|
||||
import Options (injectDefaults)
|
||||
import qualified Paths_yesod_bin
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
|
||||
import HsFile (mkHsFile)
|
||||
#ifndef WINDOWS
|
||||
import Build (touch)
|
||||
|
||||
touch' :: IO ()
|
||||
touch' = touch
|
||||
|
||||
windowsWarning :: String
|
||||
windowsWarning = ""
|
||||
#else
|
||||
touch' :: IO ()
|
||||
touch' = return ()
|
||||
|
||||
windowsWarning :: String
|
||||
windowsWarning = " (does not work on Windows)"
|
||||
#endif
|
||||
|
||||
data CabalPgm = Cabal | CabalDev deriving (Show, Eq)
|
||||
|
||||
@ -91,17 +72,16 @@ main = do
|
||||
c -> c
|
||||
})
|
||||
] optParser'
|
||||
let cabal = rawSystem' (cabalCommand o)
|
||||
case optCommand o of
|
||||
Init _ -> initErrorMsg
|
||||
HsFiles -> mkHsFile
|
||||
Configure -> cabal ["configure"]
|
||||
Build es -> touch' >> cabal ("build":es)
|
||||
Touch -> touch'
|
||||
Configure -> cabalErrorMsg
|
||||
Build _ -> cabalErrorMsg
|
||||
Touch -> cabalErrorMsg
|
||||
Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs
|
||||
Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version)
|
||||
AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods
|
||||
Test -> cabalTest cabal
|
||||
Test -> cabalErrorMsg
|
||||
Devel{..} -> devel DevelOpts
|
||||
{ verbose = optVerbose o
|
||||
, successHook = develSuccessHook
|
||||
@ -113,19 +93,6 @@ main = do
|
||||
} develExtraArgs
|
||||
DevelSignal -> develSignal
|
||||
where
|
||||
cabalTest cabal = do
|
||||
env <- getEnvironment
|
||||
case lookup "STACK_EXE" env of
|
||||
Nothing -> do
|
||||
touch'
|
||||
_ <- cabal ["configure", "--enable-tests", "-flibrary-only"]
|
||||
_ <- cabal ["build"]
|
||||
cabal ["test"]
|
||||
Just _ -> do
|
||||
hPutStrLn stderr "'yesod test' is no longer needed with Stack"
|
||||
hPutStrLn stderr "Instead, please just run 'stack test'"
|
||||
exitFailure
|
||||
|
||||
initErrorMsg = do
|
||||
mapM_ putStrLn
|
||||
[ "The init command has been removed."
|
||||
@ -136,6 +103,13 @@ main = do
|
||||
]
|
||||
exitFailure
|
||||
|
||||
cabalErrorMsg = do
|
||||
mapM_ putStrLn
|
||||
[ "The configure, build, touch, and test commands have been removed."
|
||||
, "Please use 'stack' for building your project."
|
||||
]
|
||||
exitFailure
|
||||
|
||||
optParser' :: ParserInfo Options
|
||||
optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" )
|
||||
|
||||
@ -148,17 +122,17 @@ optParser = Options
|
||||
<> command "hsfiles" (info (pure HsFiles)
|
||||
(progDesc "Create a hsfiles file for the current folder"))
|
||||
<> command "configure" (info (pure Configure)
|
||||
(progDesc "Configure a project for building"))
|
||||
(progDesc "DEPRECATED"))
|
||||
<> command "build" (info (helper <*> (Build <$> extraCabalArgs))
|
||||
(progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning))
|
||||
(progDesc "DEPRECATED"))
|
||||
<> command "touch" (info (pure Touch)
|
||||
(progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning))
|
||||
(progDesc "DEPRECATED"))
|
||||
<> command "devel" (info (helper <*> develOptions)
|
||||
(progDesc "Run project with the devel server"))
|
||||
<> command "devel-signal" (info (helper <*> pure DevelSignal)
|
||||
(progDesc "Used internally by the devel command"))
|
||||
<> command "test" (info (pure Test)
|
||||
(progDesc "Build and run the integration tests"))
|
||||
(progDesc "DEPRECATED"))
|
||||
<> command "add-handler" (info (helper <*> addHandlerOptions)
|
||||
(progDesc ("Add a new handler and module to the project."
|
||||
++ " Interactively asks for input if you do not specify arguments.")))
|
||||
@ -217,10 +191,3 @@ addHandlerOptions = AddHandler
|
||||
-- | Optional @String@ argument
|
||||
optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String)
|
||||
optStr m = option (Just <$> str) $ value Nothing <> m
|
||||
|
||||
-- | Like @rawSystem@, but exits if it receives a non-success result.
|
||||
rawSystem' :: String -> [String] -> IO ()
|
||||
rawSystem' x y = do
|
||||
res <- rawSystem x y
|
||||
unless (res == ExitSuccess) $ exitWith res
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-bin
|
||||
version: 1.5.3
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -68,13 +68,11 @@ executable yesod
|
||||
, data-default-class
|
||||
, streaming-commons
|
||||
, warp-tls >= 3.0.1
|
||||
, async
|
||||
, deepseq
|
||||
, unliftio
|
||||
|
||||
ghc-options: -Wall -threaded -rtsopts
|
||||
main-is: main.hs
|
||||
other-modules: Devel
|
||||
Build
|
||||
Keter
|
||||
AddHandler
|
||||
Paths_yesod_bin
|
||||
|
||||
@ -1,13 +1,15 @@
|
||||
## 1.5.0
|
||||
|
||||
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
|
||||
|
||||
## 1.4.38
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to conduit 1.3.0
|
||||
* Switch to `MonadUnliftIO`
|
||||
* Drop `mwc-random` and `blaze-builder` dependencies
|
||||
* Strictify some internal data structures
|
||||
* Add `CI` wrapper to first field in `Header` data constructor
|
||||
[#1418](https://github.com/yesodweb/yesod/issues/1418)
|
||||
* Internal only change, users of stable API are unaffected: `WidgetT`
|
||||
holds its data in an `IORef` so that it is isomorphic to `ReaderT`,
|
||||
avoiding state-loss issues..
|
||||
* Instances for `MonadUnliftIO`
|
||||
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
|
||||
|
||||
## 1.4.37.2
|
||||
|
||||
|
||||
@ -31,7 +31,6 @@ module Yesod.Core
|
||||
-- * Logging
|
||||
, defaultMakeLogger
|
||||
, defaultMessageLoggerSource
|
||||
, defaultShouldLog
|
||||
, defaultShouldLogIO
|
||||
, formatLogMessage
|
||||
, LogLevel (..)
|
||||
@ -146,7 +145,7 @@ import qualified Yesod.Core.Internal.Run
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import Yesod.Routes.Class
|
||||
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..))
|
||||
import UnliftIO (MonadIO (..), MonadUnliftIO (..))
|
||||
|
||||
import Control.Monad.Trans.Resource (MonadResource (..))
|
||||
import Yesod.Core.Internal.LiteApp
|
||||
|
||||
@ -12,7 +12,7 @@ import Yesod.Core.Content (ToTypedContent (..))
|
||||
import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute)
|
||||
import Yesod.Core.Class.Handler
|
||||
import Yesod.Core.Class.Yesod
|
||||
import Control.Monad.Trans.Reader (ReaderT (..), ask)
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
|
||||
@ -14,7 +14,6 @@ module Yesod.Core.Class.Handler
|
||||
|
||||
import Yesod.Core.Types
|
||||
import Control.Monad.Logger (MonadLogger)
|
||||
import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO)
|
||||
import Control.Monad.Trans.Resource (MonadResource)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
|
||||
@ -10,7 +10,7 @@ import Yesod.Core.Handler
|
||||
|
||||
import Yesod.Routes.Class
|
||||
|
||||
import Data.ByteString.Builder (Builder, toLazyByteString)
|
||||
import Data.ByteString.Builder (Builder)
|
||||
import Data.Text.Encoding (encodeUtf8Builder)
|
||||
import Control.Arrow ((***), second)
|
||||
import Control.Exception (bracket)
|
||||
@ -24,7 +24,6 @@ import Control.Monad.Logger (LogLevel (LevelInfo, LevelO
|
||||
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.Char8 as BL8
|
||||
import Data.Aeson (object, (.=))
|
||||
import Data.List (foldl', nub)
|
||||
import qualified Data.Map as Map
|
||||
@ -37,9 +36,8 @@ import Data.Text.Lazy.Builder (toLazyText)
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Word (Word64)
|
||||
import Language.Haskell.TH.Syntax (Loc (..))
|
||||
import Network.HTTP.Types (encodePath, renderQueryText)
|
||||
import Network.HTTP.Types (encodePath)
|
||||
import qualified Network.Wai as W
|
||||
import Data.Default (def)
|
||||
import Network.Wai.Parse (lbsBackEnd,
|
||||
tempFileBackEnd)
|
||||
import Network.Wai.Logger (ZonedDate, clockDateCacher)
|
||||
@ -52,7 +50,7 @@ import Text.Hamlet
|
||||
import Text.Julius
|
||||
import qualified Web.ClientSession as CS
|
||||
import Web.Cookie (SetCookie (..), parseCookies, sameSiteLax,
|
||||
sameSiteStrict, SameSiteOption)
|
||||
sameSiteStrict, SameSiteOption, defaultSetCookie)
|
||||
import Yesod.Core.Types
|
||||
import Yesod.Core.Internal.Session
|
||||
import Yesod.Core.Widget
|
||||
@ -66,18 +64,14 @@ class RenderRoute site => Yesod site where
|
||||
-- | An absolute URL to the root of the application. Do not include
|
||||
-- trailing slash.
|
||||
--
|
||||
-- Default value: 'ApprootRelative'. This is valid under the following
|
||||
-- conditions:
|
||||
-- Default value: 'guessApproot'. If you know your application root
|
||||
-- statically, it will be more efficient and more reliable to instead use
|
||||
-- 'ApprootStatic' or 'ApprootMaster'. If you do not need full absolute
|
||||
-- URLs, you can use 'ApprootRelative' instead.
|
||||
--
|
||||
-- * Your application is served from the root of the domain.
|
||||
--
|
||||
-- * You do not use any features that require absolute URLs, such as Atom
|
||||
-- feeds and XML sitemaps.
|
||||
--
|
||||
-- If this is not true, you should override with a different
|
||||
-- implementation.
|
||||
-- Note: Prior to yesod-core 1.5, the default value was 'ApprootRelative'.
|
||||
approot :: Approot site
|
||||
approot = ApprootRelative
|
||||
approot = guessApproot
|
||||
|
||||
-- | Output error response pages.
|
||||
--
|
||||
@ -103,12 +97,6 @@ class RenderRoute site => Yesod site where
|
||||
^{pageBody p}
|
||||
|]
|
||||
|
||||
-- | Override the rendering function for a particular URL. One use case for
|
||||
-- this is to offload static hosting to a different domain name to avoid
|
||||
-- sending cookies.
|
||||
urlRenderOverride :: site -> Route site -> Maybe Builder
|
||||
urlRenderOverride _ _ = Nothing
|
||||
|
||||
-- | Override the rendering function for a particular URL and query string
|
||||
-- parameters. One use case for this is to offload static hosting to a
|
||||
-- different domain name to avoid sending cookies.
|
||||
@ -121,15 +109,7 @@ class RenderRoute site => Yesod site where
|
||||
-> Route site
|
||||
-> [(T.Text, T.Text)] -- ^ query string
|
||||
-> Maybe Builder
|
||||
urlParamRenderOverride y route params = addParams params <$> urlRenderOverride y route
|
||||
where
|
||||
addParams [] routeBldr = routeBldr
|
||||
addParams nonEmptyParams routeBldr =
|
||||
let routeBS = toLazyByteString routeBldr
|
||||
qsSeparator = if BL8.elem '?' routeBS then "&" else "?"
|
||||
valueToMaybe t = if t == "" then Nothing else Just t
|
||||
queryText = map (id *** valueToMaybe) nonEmptyParams
|
||||
in routeBldr `mappend` qsSeparator `mappend` renderQueryText False queryText
|
||||
urlParamRenderOverride _ _ _ = Nothing
|
||||
|
||||
-- | Determine if a request is authorized or not.
|
||||
--
|
||||
@ -280,22 +260,11 @@ class RenderRoute site => Yesod site where
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Default: the 'defaultShouldLog' function.
|
||||
shouldLog :: site -> LogSource -> LogLevel -> Bool
|
||||
shouldLog _ = defaultShouldLog
|
||||
|
||||
-- | Should we log the given log source/level combination.
|
||||
--
|
||||
-- Note that this is almost identical to @shouldLog@, except the result
|
||||
-- lives in @IO@. This allows you to dynamically alter the logging level of
|
||||
-- your application by having this result depend on, e.g., an @IORef@.
|
||||
--
|
||||
-- The default implementation simply uses @shouldLog@. Future versions of
|
||||
-- Yesod will remove @shouldLog@ and use this method exclusively.
|
||||
-- Default: the 'defaultShouldLogIO' function.
|
||||
--
|
||||
-- Since 1.2.4
|
||||
shouldLogIO :: site -> LogSource -> LogLevel -> IO Bool
|
||||
shouldLogIO a b c = return (shouldLog a b c)
|
||||
shouldLogIO _ = defaultShouldLogIO
|
||||
|
||||
-- | A Yesod middleware, which will wrap every handler function. This
|
||||
-- allows you to run code before and after a normal handler.
|
||||
@ -332,7 +301,6 @@ class RenderRoute site => Yesod site where
|
||||
<h1>#{title}
|
||||
^{body}
|
||||
|]
|
||||
{-# DEPRECATED urlRenderOverride "Use urlParamRenderOverride instead" #-}
|
||||
|
||||
-- | Default implementation of 'makeLogger'. Sends to stdout and
|
||||
-- automatically flushes on each write.
|
||||
@ -369,15 +337,8 @@ defaultMessageLoggerSource ckLoggable logger loc source level msg = do
|
||||
-- above 'LevelInfo'.
|
||||
--
|
||||
-- Since 1.4.10
|
||||
defaultShouldLog :: LogSource -> LogLevel -> Bool
|
||||
defaultShouldLog _ level = level >= LevelInfo
|
||||
|
||||
-- | A default implementation of 'shouldLogIO' that can be used with
|
||||
-- 'defaultMessageLoggerSource'. Just uses 'defaultShouldLog'.
|
||||
--
|
||||
-- Since 1.4.10
|
||||
defaultShouldLogIO :: LogSource -> LogLevel -> IO Bool
|
||||
defaultShouldLogIO a b = return $ defaultShouldLog a b
|
||||
defaultShouldLogIO _ level = return $ level >= LevelInfo
|
||||
|
||||
-- | Default implementation of 'yesodMiddleware'. Adds the response header
|
||||
-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
|
||||
@ -871,7 +832,7 @@ loadClientSession key getCachedDate sessionName req = load
|
||||
save date sess' = do
|
||||
-- We should never cache the IV! Be careful!
|
||||
iv <- liftIO CS.randomIV
|
||||
return [AddCookie def
|
||||
return [AddCookie defaultSetCookie
|
||||
{ setCookieName = sessionName
|
||||
, setCookieValue = encodeClientSession key iv date host sess'
|
||||
, setCookiePath = Just "/"
|
||||
|
||||
@ -61,10 +61,9 @@ import Data.Monoid (mempty)
|
||||
#endif
|
||||
import Text.Hamlet (Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)
|
||||
import Data.Conduit (Flush (Chunk), ResumableSource, mapOutput)
|
||||
import Data.Conduit (Flush (Chunk), SealedConduitT, mapOutput)
|
||||
import Control.Monad (liftM)
|
||||
import Control.Monad.Trans.Resource (ResourceT)
|
||||
import Data.Conduit.Internal (ResumableSource (ResumableSource))
|
||||
import qualified Data.Conduit.Internal as CI
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
@ -122,8 +121,8 @@ instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (Resource
|
||||
|
||||
instance ToFlushBuilder builder => ToContent (CI.ConduitT () builder (ResourceT IO) ()) where
|
||||
toContent src = ContentSource $ mapOutput toFlushBuilder src
|
||||
instance ToFlushBuilder builder => ToContent (ResumableSource (ResourceT IO) builder) where
|
||||
toContent (ResumableSource src) = toContent src
|
||||
instance ToFlushBuilder builder => ToContent (SealedConduitT () builder (ResourceT IO) ()) where
|
||||
toContent (CI.SealedConduitT src) = toContent src
|
||||
|
||||
-- | A class for all data which can be sent in a streaming response. Note that
|
||||
-- for textual data, instances must use UTF-8 encoding.
|
||||
|
||||
@ -63,6 +63,7 @@ import Yesod.Core.Class.Dispatch
|
||||
import Yesod.Core.Internal.Run
|
||||
import Safe (readMay)
|
||||
import System.Environment (getEnvironment)
|
||||
import qualified System.Random as Random
|
||||
import Control.AutoUpdate (mkAutoUpdate, defaultUpdateSettings, updateAction, updateFreq)
|
||||
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
|
||||
@ -78,7 +79,6 @@ import Control.Monad.Logger
|
||||
import Control.Monad (when)
|
||||
import qualified Paths_yesod_core
|
||||
import Data.Version (showVersion)
|
||||
import qualified System.Random.MWC as MWC
|
||||
|
||||
-- | Convert the given argument into a WAI application, executable with any WAI
|
||||
-- handler. This function will provide no middlewares; if you want commonly
|
||||
@ -87,16 +87,18 @@ toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
|
||||
toWaiAppPlain site = do
|
||||
logger <- makeLogger site
|
||||
sb <- makeSessionBackend site
|
||||
gen <- MWC.createSystemRandom
|
||||
getMaxExpires <- getGetMaxExpires
|
||||
return $ toWaiAppYre YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreSite = site
|
||||
, yreSessionBackend = sb
|
||||
, yreGen = gen
|
||||
, yreGen = defaultGen
|
||||
, yreGetMaxExpires = getMaxExpires
|
||||
}
|
||||
|
||||
defaultGen :: IO Int
|
||||
defaultGen = Random.getStdRandom Random.next
|
||||
|
||||
-- | Pure low level function to construct WAI application. Usefull
|
||||
-- when you need not standard way to run your app, or want to embed it
|
||||
-- inside another app.
|
||||
@ -151,13 +153,12 @@ toWaiApp site = do
|
||||
toWaiAppLogger :: YesodDispatch site => Logger -> site -> IO W.Application
|
||||
toWaiAppLogger logger site = do
|
||||
sb <- makeSessionBackend site
|
||||
gen <- MWC.createSystemRandom
|
||||
getMaxExpires <- getGetMaxExpires
|
||||
let yre = YesodRunnerEnv
|
||||
{ yreLogger = logger
|
||||
, yreSite = site
|
||||
, yreSessionBackend = sb
|
||||
, yreGen = gen
|
||||
, yreGen = defaultGen
|
||||
, yreGetMaxExpires = getMaxExpires
|
||||
}
|
||||
messageLoggerSource
|
||||
|
||||
@ -193,13 +193,14 @@ import Control.Applicative ((<$>))
|
||||
import Data.Monoid (mempty, mappend)
|
||||
#endif
|
||||
import Control.Applicative ((<|>))
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Control.Exception (evaluate, SomeException, throwIO)
|
||||
import Control.Exception (handle)
|
||||
|
||||
import Control.Monad (void, liftM, unless)
|
||||
import qualified Control.Monad.Trans.Writer as Writer
|
||||
|
||||
import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
|
||||
import UnliftIO (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
|
||||
|
||||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.Wai as W
|
||||
@ -228,7 +229,7 @@ import Data.Monoid (Endo (..))
|
||||
import Data.Text (Text)
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import Text.Shakespeare.I18N (RenderMessage (..))
|
||||
import Web.Cookie (SetCookie (..))
|
||||
import Web.Cookie (SetCookie (..), defaultSetCookie)
|
||||
import Yesod.Core.Content (ToTypedContent (..), simpleContentType, contentTypeTypes, HasContentType (..), ToContent (..), ToFlushBuilder (..))
|
||||
import Yesod.Core.Internal.Util (formatRFC1123)
|
||||
import Text.Blaze.Html (preEscapedToHtml, toHtml)
|
||||
@ -250,7 +251,6 @@ import Data.Conduit (ConduitT, transPipe, Flush (Flush), yield, Void)
|
||||
import qualified Yesod.Core.TypeCache as Cache
|
||||
import qualified Data.Word8 as W8
|
||||
import qualified Data.Foldable as Fold
|
||||
import Data.Default
|
||||
import Control.Monad.Logger (MonadLogger, logWarnS)
|
||||
|
||||
type HandlerT site (m :: * -> *) = HandlerFor site
|
||||
@ -782,7 +782,7 @@ setLanguage = setSession langKey
|
||||
--
|
||||
-- @since 1.2.0
|
||||
addHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
addHeader a = addHeaderInternal . Header (encodeUtf8 a) . encodeUtf8
|
||||
addHeader a = addHeaderInternal . Header (CI.mk $ encodeUtf8 a) . encodeUtf8
|
||||
|
||||
-- | Deprecated synonym for addHeader.
|
||||
setHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
@ -800,10 +800,10 @@ replaceOrAddHeader :: MonadHandler m => Text -> Text -> m ()
|
||||
replaceOrAddHeader a b =
|
||||
modify $ \g -> g {ghsHeaders = replaceHeader (ghsHeaders g)}
|
||||
where
|
||||
repHeader = Header (encodeUtf8 a) (encodeUtf8 b)
|
||||
repHeader = Header (CI.mk $ encodeUtf8 a) (encodeUtf8 b)
|
||||
|
||||
sameHeaderName :: Header -> Header -> Bool
|
||||
sameHeaderName (Header n1 _) (Header n2 _) = T.toLower (decodeUtf8 n1) == T.toLower (decodeUtf8 n2)
|
||||
sameHeaderName (Header n1 _) (Header n2 _) = n1 == n2
|
||||
sameHeaderName _ _ = False
|
||||
|
||||
replaceIndividualHeader :: [Header] -> [Header]
|
||||
@ -1457,7 +1457,10 @@ defaultCsrfCookieName = "XSRF-TOKEN"
|
||||
--
|
||||
-- @since 1.4.14
|
||||
setCsrfCookie :: MonadHandler m => m ()
|
||||
setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName, setCookiePath = Just "/" }
|
||||
setCsrfCookie = setCsrfCookieWithCookie defaultSetCookie
|
||||
{ setCookieName = defaultCsrfCookieName
|
||||
, setCookiePath = Just "/"
|
||||
}
|
||||
|
||||
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie.
|
||||
--
|
||||
|
||||
@ -35,14 +35,11 @@ import Data.Text.Encoding (decodeUtf8With, decodeUtf8)
|
||||
import Data.Text.Encoding.Error (lenientDecode)
|
||||
import Conduit
|
||||
import Data.Word (Word8, Word64)
|
||||
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
|
||||
import Control.Exception (throwIO)
|
||||
import Control.Monad ((<=<), liftM)
|
||||
import Yesod.Core.Types
|
||||
import qualified Data.Map as Map
|
||||
import Data.IORef
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Control.Monad.Primitive (PrimMonad, PrimState)
|
||||
import qualified Data.Vector.Storable as V
|
||||
import Data.ByteString.Internal (ByteString (PS))
|
||||
import qualified Data.Word8 as Word8
|
||||
@ -74,7 +71,7 @@ parseWaiRequest :: W.Request
|
||||
-> SessionMap
|
||||
-> Bool
|
||||
-> Maybe Word64 -- ^ max body size
|
||||
-> Either (IO YesodRequest) (MWC.GenIO -> IO YesodRequest)
|
||||
-> Either (IO YesodRequest) (IO Int -> IO YesodRequest)
|
||||
parseWaiRequest env session useToken mmaxBodySize =
|
||||
-- In most cases, we won't need to generate any random values. Therefore,
|
||||
-- we split our results: if we need a random generator, return a Right
|
||||
@ -154,16 +151,21 @@ addTwoLetters (toAdd, exist) (l:ls) =
|
||||
-- | Generate a random String of alphanumerical characters
|
||||
-- (a-z, A-Z, and 0-9) of the given length using the given
|
||||
-- random number generator.
|
||||
randomString :: PrimMonad m => Int -> MWC.Gen (PrimState m) -> m Text
|
||||
randomString :: Monad m => Int -> m Int -> m Text
|
||||
randomString len gen =
|
||||
liftM (decodeUtf8 . fromByteVector) $ V.replicateM len asciiChar
|
||||
where
|
||||
asciiChar = liftM toAscii $ MWC.uniformR (0, 61) gen
|
||||
|
||||
toAscii i
|
||||
| i < 26 = i + Word8._A
|
||||
| i < 52 = i + Word8._a - 26
|
||||
| otherwise = i + Word8._0 - 52
|
||||
asciiChar =
|
||||
let loop = do
|
||||
x <- gen
|
||||
let y = fromIntegral $ x `mod` 64
|
||||
case () of
|
||||
()
|
||||
| y < 26 -> return $ y + Word8._A
|
||||
| y < 52 -> return $ y + Word8._a - 26
|
||||
| y < 62 -> return $ y + Word8._0 - 52
|
||||
| otherwise -> loop
|
||||
in loop
|
||||
|
||||
fromByteVector :: V.Vector Word8 -> ByteString
|
||||
fromByteVector v =
|
||||
@ -177,10 +179,10 @@ mkFileInfoLBS name ct lbs =
|
||||
FileInfo name ct (sourceLazy lbs) (`L.writeFile` lbs)
|
||||
|
||||
mkFileInfoFile :: Text -> Text -> FilePath -> FileInfo
|
||||
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runResourceT $ sourceFile fp $$ sinkFile dst)
|
||||
mkFileInfoFile name ct fp = FileInfo name ct (sourceFile fp) (\dst -> runConduitRes $ sourceFile fp .| sinkFile dst)
|
||||
|
||||
mkFileInfoSource :: Text -> Text -> Source (ResourceT IO) ByteString -> FileInfo
|
||||
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runResourceT $ src $$ sinkFile dst)
|
||||
mkFileInfoSource :: Text -> Text -> ConduitT () ByteString (ResourceT IO) () -> FileInfo
|
||||
mkFileInfoSource name ct src = FileInfo name ct src (\dst -> runConduitRes $ src .| sinkFile dst)
|
||||
|
||||
tokenKey :: IsString a => a
|
||||
tokenKey = "_TOKEN"
|
||||
|
||||
@ -8,7 +8,6 @@ import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.Wai
|
||||
import Control.Monad (mplus)
|
||||
import Control.Monad.Trans.Resource (runInternalState, InternalState)
|
||||
@ -24,8 +23,7 @@ import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.Map as Map
|
||||
import Yesod.Core.Internal.Request (tokenKey)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Conduit (Flush (..), ($$), transPipe)
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Conduit
|
||||
|
||||
yarToResponse :: YesodResponse
|
||||
-> (SessionMap -> IO [Header]) -- ^ save session
|
||||
@ -53,9 +51,9 @@ yarToResponse (YRPlain s' hs ct c newSess) saveSession yreq _req is sendResponse
|
||||
sendResponse $ ResponseBuilder s hs' b
|
||||
go (ContentFile fp p) = sendResponse $ ResponseFile s finalHeaders fp p
|
||||
go (ContentSource body) = sendResponse $ responseStream s finalHeaders
|
||||
$ \sendChunk flush ->
|
||||
$ \sendChunk flush -> runConduit $
|
||||
transPipe (`runInternalState` is) body
|
||||
$$ CL.mapM_ (\mchunk ->
|
||||
.| mapM_C (\mchunk ->
|
||||
case mchunk of
|
||||
Flush -> flush
|
||||
Chunk builder -> sendChunk builder)
|
||||
@ -93,7 +91,7 @@ headerToPair (DeleteCookie key path) =
|
||||
, "; expires=Thu, 01-Jan-1970 00:00:00 GMT"
|
||||
]
|
||||
)
|
||||
headerToPair (Header key value) = (CI.mk key, value)
|
||||
headerToPair (Header key value) = (key, value)
|
||||
|
||||
evaluateContent :: Content -> IO (Either ErrorResponse Content)
|
||||
evaluateContent (ContentBuilder b mlen) = handle f $ do
|
||||
|
||||
@ -16,8 +16,6 @@ import Control.Applicative ((<$>))
|
||||
import Yesod.Core.Internal.Response
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Control.Exception (fromException, evaluate)
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
|
||||
liftLoc)
|
||||
@ -45,38 +43,21 @@ import Yesod.Core.Internal.Request (parseWaiRequest,
|
||||
import Yesod.Core.Internal.Util (getCurrentMaxExpiresRFC1123)
|
||||
import Yesod.Routes.Class (Route, renderRoute)
|
||||
import Control.DeepSeq (($!!), NFData)
|
||||
import UnliftIO.Exception
|
||||
|
||||
-- | Catch all synchronous exceptions, ignoring asynchronous
|
||||
-- exceptions.
|
||||
--
|
||||
-- Ideally we'd use this from a different library
|
||||
catchSync :: IO a -> (E.SomeException -> IO a) -> IO a
|
||||
catchSync thing after = thing `E.catch` \e ->
|
||||
if isAsyncException e
|
||||
then E.throwIO e
|
||||
else after e
|
||||
|
||||
-- | Determine if an exception is asynchronous
|
||||
--
|
||||
-- Also worth being upstream
|
||||
isAsyncException :: E.SomeException -> Bool
|
||||
isAsyncException e =
|
||||
case fromException e of
|
||||
Just E.SomeAsyncException{} -> True
|
||||
Nothing -> False
|
||||
|
||||
-- | Convert an exception into an ErrorResponse
|
||||
toErrorHandler :: E.SomeException -> IO ErrorResponse
|
||||
toErrorHandler e0 = flip catchSync errFromShow $
|
||||
-- | Convert a synchronous exception into an ErrorResponse
|
||||
toErrorHandler :: SomeException -> IO ErrorResponse
|
||||
toErrorHandler e0 = handleAny errFromShow $
|
||||
case fromException e0 of
|
||||
Just (HCError x) -> evaluate $!! x
|
||||
_
|
||||
| isAsyncException e0 -> E.throwIO e0
|
||||
| otherwise -> errFromShow e0
|
||||
_ -> errFromShow e0
|
||||
|
||||
-- | Generate an @ErrorResponse@ based on the shown version of the exception
|
||||
errFromShow :: E.SomeException -> IO ErrorResponse
|
||||
errFromShow x = evaluate $!! InternalError $! T.pack $! show x
|
||||
errFromShow :: SomeException -> IO ErrorResponse
|
||||
errFromShow x = do
|
||||
text <- evaluate (T.pack $ show x) `catchAny` \_ ->
|
||||
return (T.pack "Yesod.Core.Internal.Run.errFromShow: show of an exception threw an exception")
|
||||
return $ InternalError text
|
||||
|
||||
-- | Do a basic run of a handler, getting some contents and the final
|
||||
-- @GHState@. The @GHState@ unfortunately may contain some impure
|
||||
@ -95,7 +76,7 @@ basicRunHandler rhe handler yreq resState = do
|
||||
|
||||
-- Run the handler itself, capturing any runtime exceptions and
|
||||
-- converting them into a @HandlerContents@
|
||||
contents' <- catchSync
|
||||
contents' <- catchAny
|
||||
(do
|
||||
res <- unHandlerFor handler (hd istate)
|
||||
tc <- evaluate (toTypedContent res)
|
||||
@ -135,7 +116,7 @@ handleError :: RunHandlerEnv site
|
||||
-> IO YesodResponse
|
||||
handleError rhe yreq resState finalSession headers e0 = do
|
||||
-- Find any evil hidden impure exceptions
|
||||
e <- (evaluate $!! e0) `catchSync` errFromShow
|
||||
e <- (evaluate $!! e0) `catchAny` errFromShow
|
||||
|
||||
-- Generate a response, leveraging the updated session and
|
||||
-- response headers
|
||||
@ -200,7 +181,7 @@ evalFallback :: (Monoid w, NFData w)
|
||||
=> HandlerContents
|
||||
-> w
|
||||
-> IO (w, HandlerContents)
|
||||
evalFallback contents val = catchSync
|
||||
evalFallback contents val = catchAny
|
||||
(fmap (, contents) (evaluate $!! val))
|
||||
(fmap ((mempty, ) . HCError) . toErrorHandler)
|
||||
|
||||
@ -218,13 +199,14 @@ runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -
|
||||
-- propagating exceptions into the contents
|
||||
(finalSession, contents1) <- evalFallback contents0 (ghsSession state)
|
||||
(headers, contents2) <- evalFallback contents1 (appEndo (ghsHeaders state) [])
|
||||
contents3 <- (evaluate contents2) `catchAny` (fmap HCError . toErrorHandler)
|
||||
|
||||
-- Convert the HandlerContents into the final YesodResponse
|
||||
handleContents
|
||||
(handleError rhe yreq resState finalSession headers)
|
||||
finalSession
|
||||
headers
|
||||
contents2
|
||||
contents3
|
||||
|
||||
safeEh :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
|
||||
-> ErrorResponse
|
||||
|
||||
@ -25,6 +25,7 @@ import Control.Monad.Logger (LogLevel, LogSource,
|
||||
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.CaseInsensitive (CI)
|
||||
import Data.Conduit (Flush, ConduitT)
|
||||
import Data.IORef (IORef, modifyIORef')
|
||||
import Data.Map (Map, unionWith)
|
||||
@ -46,7 +47,6 @@ import Network.Wai (FilePart,
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.Parse as NWP
|
||||
import System.Log.FastLogger (LogStr, LoggerSet, toLogStr, pushLogStr)
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Network.Wai.Logger (DateCacheGetter)
|
||||
import Text.Blaze.Html (Html, toHtml)
|
||||
import Text.Hamlet (HtmlUrl)
|
||||
@ -61,7 +61,7 @@ import Control.DeepSeq.Generics (genericRnf)
|
||||
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
|
||||
import Control.Monad.Logger (MonadLoggerIO (..))
|
||||
import Data.Semigroup (Semigroup)
|
||||
import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..))
|
||||
import UnliftIO (MonadUnliftIO (..), UnliftIO (..))
|
||||
|
||||
-- Sessions
|
||||
type SessionMap = Map Text ByteString
|
||||
@ -74,7 +74,7 @@ newtype SessionBackend = SessionBackend
|
||||
-> IO (SessionMap, SaveSession) -- ^ Return the session data and a function to save the session
|
||||
}
|
||||
|
||||
data SessionCookie = SessionCookie (Either UTCTime ByteString) ByteString SessionMap
|
||||
data SessionCookie = SessionCookie !(Either UTCTime ByteString) !ByteString !SessionMap
|
||||
deriving (Show, Read)
|
||||
instance Serialize SessionCookie where
|
||||
put (SessionCookie a b c) = do
|
||||
@ -152,13 +152,13 @@ data Approot master = ApprootRelative -- ^ No application root.
|
||||
|
||||
type ResolvedApproot = Text
|
||||
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized Text
|
||||
data AuthResult = Authorized | AuthenticationRequired | Unauthorized !Text
|
||||
deriving (Eq, Show, Read)
|
||||
|
||||
data ScriptLoadPosition master
|
||||
= BottomOfBody
|
||||
| BottomOfHeadBlocking
|
||||
| BottomOfHeadAsync (BottomOfHeadAsync master)
|
||||
| BottomOfHeadAsync !(BottomOfHeadAsync master)
|
||||
|
||||
type BottomOfHeadAsync master
|
||||
= [Text] -- ^ urls to load asynchronously
|
||||
@ -171,7 +171,7 @@ type Texts = [Text]
|
||||
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
|
||||
|
||||
-- | Like 'WaiSubsite', but applies parent site's middleware and isAuthorized.
|
||||
--
|
||||
--
|
||||
-- @since 1.4.34
|
||||
newtype WaiSubsiteWithAuth = WaiSubsiteWithAuth { runWaiSubsiteWithAuth :: W.Application }
|
||||
|
||||
@ -199,8 +199,9 @@ data YesodRunnerEnv site = YesodRunnerEnv
|
||||
{ yreLogger :: !Logger
|
||||
, yreSite :: !site
|
||||
, yreSessionBackend :: !(Maybe SessionBackend)
|
||||
, yreGen :: !MWC.GenIO
|
||||
, yreGetMaxExpires :: IO Text
|
||||
, yreGen :: !(IO Int)
|
||||
-- ^ Generate a random number
|
||||
, yreGetMaxExpires :: !(IO Text)
|
||||
}
|
||||
|
||||
data YesodSubRunnerEnv sub parent = YesodSubRunnerEnv
|
||||
@ -225,11 +226,11 @@ newtype HandlerFor site a = HandlerFor
|
||||
|
||||
data GHState = GHState
|
||||
{ ghsSession :: !SessionMap
|
||||
, ghsRBC :: Maybe RequestBodyContents
|
||||
, ghsIdent :: Int
|
||||
, ghsCache :: TypeMap
|
||||
, ghsCacheBy :: KeyedTypeMap
|
||||
, ghsHeaders :: Endo [Header]
|
||||
, ghsRBC :: !(Maybe RequestBodyContents)
|
||||
, ghsIdent :: !Int
|
||||
, ghsCache :: !TypeMap
|
||||
, ghsCacheBy :: !KeyedTypeMap
|
||||
, ghsHeaders :: !(Endo [Header])
|
||||
}
|
||||
|
||||
-- | An extension of the basic WAI 'W.Application' datatype to provide extra
|
||||
@ -283,9 +284,9 @@ newtype CssBuilder = CssBuilder { unCssBuilder :: TBuilder.Builder }
|
||||
--
|
||||
-- > PageContent url -> HtmlUrl url
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: Html
|
||||
, pageHead :: HtmlUrl url
|
||||
, pageBody :: HtmlUrl url
|
||||
{ pageTitle :: !Html
|
||||
, pageHead :: !(HtmlUrl url)
|
||||
, pageBody :: !(HtmlUrl url)
|
||||
}
|
||||
|
||||
data Content = ContentBuilder !BB.Builder !(Maybe Int) -- ^ The content and optional content length.
|
||||
@ -312,11 +313,11 @@ newtype DontFullyEvaluate a = DontFullyEvaluate { unDontFullyEvaluate :: a }
|
||||
-- | Responses to indicate some form of an error occurred.
|
||||
data ErrorResponse =
|
||||
NotFound
|
||||
| InternalError Text
|
||||
| InvalidArgs [Text]
|
||||
| InternalError !Text
|
||||
| InvalidArgs ![Text]
|
||||
| NotAuthenticated
|
||||
| PermissionDenied Text
|
||||
| BadMethod H.Method
|
||||
| PermissionDenied !Text
|
||||
| BadMethod !H.Method
|
||||
deriving (Show, Eq, Typeable, Generic)
|
||||
instance NFData ErrorResponse where
|
||||
rnf = genericRnf
|
||||
@ -324,9 +325,11 @@ instance NFData ErrorResponse where
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
data Header =
|
||||
AddCookie SetCookie
|
||||
| DeleteCookie ByteString ByteString
|
||||
| Header ByteString ByteString
|
||||
AddCookie !SetCookie
|
||||
| DeleteCookie !ByteString !ByteString
|
||||
-- ^ name and path
|
||||
| Header !(CI ByteString) !ByteString
|
||||
-- ^ key and value
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- FIXME In the next major version bump, let's just add strictness annotations
|
||||
@ -337,16 +340,16 @@ instance NFData Header where
|
||||
rnf (DeleteCookie x y) = x `seq` y `seq` ()
|
||||
rnf (Header x y) = x `seq` y `seq` ()
|
||||
|
||||
data Location url = Local url | Remote Text
|
||||
data Location url = Local !url | Remote !Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | A diff list that does not directly enforce uniqueness.
|
||||
-- When creating a widget Yesod will use nub to make it unique.
|
||||
newtype UniqueList x = UniqueList ([x] -> [x])
|
||||
|
||||
data Script url = Script { scriptLocation :: Location url, scriptAttributes :: [(Text, Text)] }
|
||||
data Script url = Script { scriptLocation :: !(Location url), scriptAttributes :: ![(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
data Stylesheet url = Stylesheet { styleLocation :: Location url, styleAttributes :: [(Text, Text)] }
|
||||
data Stylesheet url = Stylesheet { styleLocation :: !(Location url), styleAttributes :: ![(Text, Text)] }
|
||||
deriving (Show, Eq)
|
||||
newtype Title = Title { unTitle :: Html }
|
||||
|
||||
@ -382,13 +385,13 @@ instance Monoid (GWData a) where
|
||||
instance Semigroup (GWData a)
|
||||
|
||||
data HandlerContents =
|
||||
HCContent H.Status !TypedContent
|
||||
| HCError ErrorResponse
|
||||
| HCSendFile ContentType FilePath (Maybe FilePart)
|
||||
| HCRedirect H.Status Text
|
||||
| HCCreated Text
|
||||
| HCWai W.Response
|
||||
| HCWaiApp W.Application
|
||||
HCContent !H.Status !TypedContent
|
||||
| HCError !ErrorResponse
|
||||
| HCSendFile !ContentType !FilePath !(Maybe FilePart)
|
||||
| HCRedirect !H.Status !Text
|
||||
| HCCreated !Text
|
||||
| HCWai !W.Response
|
||||
| HCWaiApp !W.Application
|
||||
deriving Typeable
|
||||
|
||||
instance Show HandlerContents where
|
||||
|
||||
@ -5,22 +5,20 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
module Main where
|
||||
|
||||
import Criterion.Main
|
||||
import Gauge.Main
|
||||
import Text.Hamlet
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Text.Blaze.Html.Renderer.Utf8 as Utf8
|
||||
import Data.Monoid (mconcat)
|
||||
import Text.Blaze.Html5 (table, tr, td)
|
||||
import Text.Blaze.Html (toHtml)
|
||||
import Yesod.Core.Widget
|
||||
import Yesod.Core.Types
|
||||
import Data.Int
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ bench "bigTable html" $ nf bigTableHtml bigTableData
|
||||
, bench "bigTable hamlet" $ nf bigTableHamlet bigTableData
|
||||
, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
|
||||
--, bench "bigTable widget" $ nfIO (bigTableWidget bigTableData)
|
||||
, bench "bigTable blaze" $ nf bigTableBlaze bigTableData
|
||||
]
|
||||
where
|
||||
@ -49,6 +47,7 @@ bigTableHamlet rows = L.length $ Utf8.renderHtml $ ($ id) [hamlet|
|
||||
<td>#{show cell}
|
||||
|]
|
||||
|
||||
{-
|
||||
bigTableWidget :: Show a => [[a]] -> IO Int64
|
||||
bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whamlet|
|
||||
<table>
|
||||
@ -62,6 +61,7 @@ bigTableWidget rows = fmap (L.length . Utf8.renderHtml . ($ render)) (run [whaml
|
||||
run (WidgetT w) = do
|
||||
(_, GWData { gwdBody = Body x }) <- w undefined
|
||||
return x
|
||||
-}
|
||||
|
||||
bigTableBlaze :: Show a => [[a]] -> Int64
|
||||
bigTableBlaze t = L.length $ Utf8.renderHtml $ table $ Data.Monoid.mconcat $ map row t
|
||||
|
||||
@ -10,9 +10,11 @@ import Data.Map (singleton)
|
||||
import Yesod.Core
|
||||
import Data.Word (Word64)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import qualified System.Random.MWC as MWC
|
||||
import Control.Monad.ST
|
||||
import Control.Monad (replicateM)
|
||||
import System.Random
|
||||
|
||||
gen :: IO Int
|
||||
gen = getStdRandom next
|
||||
|
||||
randomStringSpecs :: Spec
|
||||
randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
|
||||
@ -21,21 +23,19 @@ randomStringSpecs = describe "Yesod.Internal.Request.randomString" $ do
|
||||
|
||||
-- NOTE: this testcase may break on other systems/architectures if
|
||||
-- mkStdGen is not identical everywhere (is it?).
|
||||
_looksRandom :: Bool
|
||||
_looksRandom = runST $ do
|
||||
gen <- MWC.create
|
||||
_looksRandom :: IO ()
|
||||
_looksRandom = do
|
||||
s <- randomString 20 gen
|
||||
return $ s == "VH9SkhtptqPs6GqtofVg"
|
||||
s `shouldBe` "VH9SkhtptqPs6GqtofVg"
|
||||
|
||||
noRepeat :: Int -> Int -> Bool
|
||||
noRepeat len n = runST $ do
|
||||
gen <- MWC.create
|
||||
noRepeat :: Int -> Int -> IO ()
|
||||
noRepeat len n = do
|
||||
ss <- replicateM n $ randomString len gen
|
||||
return $ length (nub ss) == n
|
||||
length (nub ss) `shouldBe` n
|
||||
|
||||
|
||||
-- For convenience instead of "(undefined :: StdGen)".
|
||||
g :: MWC.GenIO
|
||||
g :: IO Int
|
||||
g = error "test/YesodCoreTest/InternalRequest.g"
|
||||
|
||||
parseWaiRequest' :: Request
|
||||
|
||||
@ -39,8 +39,8 @@ getHomeR = do
|
||||
_ <- register $ writeIORef ref 1
|
||||
sendRawResponse $ \src sink -> liftIO $ do
|
||||
val <- readIORef ref
|
||||
yield (S8.pack $ show val) $$ sink
|
||||
src $$ CL.map (S8.map toUpper) =$ sink
|
||||
runConduit $ yield (S8.pack $ show val) .| sink
|
||||
runConduit $ src .| CL.map (S8.map toUpper) .| sink
|
||||
|
||||
getWaiStreamR :: Handler ()
|
||||
getWaiStreamR = sendWaiResponse $ responseStream status200 [] $ \send flush -> do
|
||||
@ -76,18 +76,18 @@ specs = do
|
||||
withAsync (warp port App) $ \_ -> do
|
||||
threadDelay 100000
|
||||
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
|
||||
yield "GET / HTTP/1.1\r\n\r\nhello" $$ appSink ad
|
||||
(appSource ad $$ CB.take 6) >>= (`shouldBe` "0HELLO")
|
||||
yield "WORLd" $$ appSink ad
|
||||
(appSource ad $$ await) >>= (`shouldBe` Just "WORLD")
|
||||
runConduit $ yield "GET / HTTP/1.1\r\n\r\nhello" .| appSink ad
|
||||
runConduit (appSource ad .| CB.take 6) >>= (`shouldBe` "0HELLO")
|
||||
runConduit $ yield "WORLd" .| appSink ad
|
||||
runConduit (appSource ad .| await) >>= (`shouldBe` Just "WORLD")
|
||||
|
||||
let body req = do
|
||||
port <- getFreePort
|
||||
withAsync (warp port App) $ \_ -> do
|
||||
threadDelay 100000
|
||||
runTCPClient (clientSettings port "127.0.0.1") $ \ad -> do
|
||||
yield req $$ appSink ad
|
||||
appSource ad $$ CB.lines =$ do
|
||||
runConduit $ yield req .| appSink ad
|
||||
runConduit $ appSource ad .| CB.lines .| do
|
||||
let loop = do
|
||||
x <- await
|
||||
case x of
|
||||
|
||||
@ -42,11 +42,11 @@ postPostR = do
|
||||
return $ RepPlain $ toContent $ T.concat val
|
||||
|
||||
postConsumeR = do
|
||||
body <- rawRequestBody $$ consume
|
||||
body <- runConduit $ rawRequestBody .| consume
|
||||
return $ RepPlain $ toContent $ S.concat body
|
||||
|
||||
postPartialConsumeR = do
|
||||
body <- rawRequestBody $$ isolate 5 =$ consume
|
||||
body <- runConduit $ rawRequestBody .| isolate 5 .| consume
|
||||
return $ RepPlain $ toContent $ S.concat body
|
||||
|
||||
postUnusedR = return $ RepPlain ""
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-core
|
||||
version: 1.4.38
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -52,22 +52,18 @@ library
|
||||
, resourcet >= 1.2
|
||||
, blaze-html >= 0.5
|
||||
, blaze-markup >= 0.7.1
|
||||
-- FIXME remove!
|
||||
, data-default
|
||||
, safe
|
||||
, warp >= 3.0.2
|
||||
, unix-compat
|
||||
, conduit-extra
|
||||
, deepseq >= 1.3
|
||||
, deepseq-generics
|
||||
-- FIXME remove
|
||||
, mwc-random
|
||||
, primitive
|
||||
, word8
|
||||
, auto-update
|
||||
, semigroups
|
||||
, byteable
|
||||
, unliftio-core
|
||||
, unliftio
|
||||
|
||||
exposed-modules: Yesod.Core
|
||||
Yesod.Core.Content
|
||||
@ -199,7 +195,6 @@ test-suite tests
|
||||
, shakespeare
|
||||
, streaming-commons
|
||||
, wai-extra
|
||||
, mwc-random
|
||||
, cookie >= 0.4.1 && < 0.5
|
||||
, unliftio
|
||||
ghc-options: -Wall
|
||||
@ -209,7 +204,7 @@ benchmark widgets
|
||||
type: exitcode-stdio-1.0
|
||||
hs-source-dirs: bench
|
||||
build-depends: base
|
||||
, criterion
|
||||
, gauge
|
||||
, bytestring
|
||||
, text
|
||||
, transformers
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.1
|
||||
|
||||
* Fix warnings
|
||||
|
||||
@ -13,7 +13,7 @@ import Control.Monad (when)
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Monoid (Monoid (..))
|
||||
import Yesod.Core
|
||||
import qualified Data.Conduit as C
|
||||
import Data.Conduit
|
||||
import qualified Network.Wai as W
|
||||
import qualified Network.Wai.EventSource as ES
|
||||
import qualified Network.Wai.EventSource.EventStream as ES
|
||||
@ -32,32 +32,35 @@ prepareForEventSource = do
|
||||
|
||||
|
||||
-- | (Internal) Source with a event stream content-type.
|
||||
respondEventStream :: C.Source (HandlerT site IO) (C.Flush Builder)
|
||||
-> HandlerT site IO TypedContent
|
||||
respondEventStream :: ConduitT () (Flush Builder) (HandlerFor site) ()
|
||||
-> HandlerFor site TypedContent
|
||||
respondEventStream = respondSource "text/event-stream"
|
||||
|
||||
|
||||
-- | Returns a Server-Sent Event stream from a 'C.Source' of
|
||||
-- | Returns a Server-Sent Event stream from a 'Source' of
|
||||
-- 'ES.ServerEvent'@s@. The HTTP socket is flushed after every
|
||||
-- event. The connection is closed either when the 'C.Source'
|
||||
-- event. The connection is closed either when the 'Source'
|
||||
-- finishes outputting data or a 'ES.CloseEvent' is outputted,
|
||||
-- whichever comes first.
|
||||
repEventSource :: (EventSourcePolyfill -> C.Source (HandlerT site IO) ES.ServerEvent)
|
||||
-> HandlerT site IO TypedContent
|
||||
repEventSource :: (EventSourcePolyfill -> ConduitT () ES.ServerEvent (HandlerFor site) ())
|
||||
-> HandlerFor site TypedContent
|
||||
repEventSource src =
|
||||
prepareForEventSource >>=
|
||||
respondEventStream . sourceToSource . src
|
||||
|
||||
-- | Convert a ServerEvent source into a Builder source of serialized
|
||||
-- events.
|
||||
sourceToSource :: Monad m => C.Source m ES.ServerEvent -> C.Source m (C.Flush Builder)
|
||||
sourceToSource
|
||||
:: Monad m
|
||||
=> ConduitT () ES.ServerEvent m ()
|
||||
-> ConduitT () (Flush Builder) m ()
|
||||
sourceToSource src =
|
||||
src C.$= C.awaitForever eventToFlushBuilder
|
||||
src .| awaitForever eventToFlushBuilder
|
||||
where
|
||||
eventToFlushBuilder event =
|
||||
case ES.eventToBuilder event of
|
||||
Nothing -> return ()
|
||||
Just x -> C.yield (C.Chunk x) >> C.yield C.Flush
|
||||
Just x -> yield (Chunk x) >> yield Flush
|
||||
|
||||
|
||||
-- | Return a Server-Sent Event stream given a 'HandlerT' action
|
||||
@ -68,8 +71,8 @@ sourceToSource src =
|
||||
-- The connection is closed as soon as an 'ES.CloseEvent' is
|
||||
-- outputted, after which no other events are sent to the client.
|
||||
pollingEventSource :: s
|
||||
-> (EventSourcePolyfill -> s -> HandlerT site IO ([ES.ServerEvent], s))
|
||||
-> HandlerT site IO TypedContent
|
||||
-> (EventSourcePolyfill -> s -> HandlerFor site ([ES.ServerEvent], s))
|
||||
-> HandlerFor site TypedContent
|
||||
pollingEventSource initial act = do
|
||||
polyfill <- prepareForEventSource
|
||||
let -- Get new events to be sent.
|
||||
@ -79,8 +82,8 @@ pollingEventSource initial act = do
|
||||
[] -> getEvents s'
|
||||
_ -> do
|
||||
let (builder, continue) = joinEvents evs mempty
|
||||
C.yield (C.Chunk builder)
|
||||
C.yield C.Flush
|
||||
yield (Chunk builder)
|
||||
yield Flush
|
||||
when continue (getEvents s')
|
||||
|
||||
-- Join all events in a single Builder. Returns @False@
|
||||
@ -103,7 +106,7 @@ pollingEventSource initial act = do
|
||||
-- outputted, after which no other events are sent to the client.
|
||||
ioToRepEventSource :: s
|
||||
-> (EventSourcePolyfill -> s -> IO ([ES.ServerEvent], s))
|
||||
-> HandlerT site IO TypedContent
|
||||
-> HandlerFor site TypedContent
|
||||
ioToRepEventSource initial act = pollingEventSource initial act'
|
||||
where act' p s = liftIO (act p s)
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-eventsource
|
||||
version: 1.4.1
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Felipe Lessa <felipe.lessa@gmail.com>
|
||||
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core == 1.4.*
|
||||
, yesod-core == 1.6.*
|
||||
, conduit >= 1.3
|
||||
, wai >= 1.3
|
||||
, wai-eventsource >= 1.3
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.16
|
||||
|
||||
* Korean translation
|
||||
|
||||
@ -186,7 +186,7 @@ renderBootstrap3 formLayout aform fragment = do
|
||||
|
||||
|
||||
-- | (Internal) Render a help widget for tooltips and errors.
|
||||
helpWidget :: FieldView site -> WidgetT site IO ()
|
||||
helpWidget :: FieldView site -> WidgetFor site ()
|
||||
helpWidget view = [whamlet|
|
||||
$maybe tt <- fvTooltip view
|
||||
<span .help-block>#{tt}
|
||||
|
||||
@ -161,10 +161,9 @@ $newline never
|
||||
}
|
||||
where showVal = either id (pack . show)
|
||||
|
||||
-- | An alias for 'timeFieldTypeText'.
|
||||
-- | An alias for 'timeFieldTypeTime'.
|
||||
timeField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m TimeOfDay
|
||||
timeField = timeFieldTypeText
|
||||
{-# DEPRECATED timeField "'timeField' currently defaults to an input of type=\"text\". In the next major release, it will default to type=\"time\". To opt in to the new functionality, use 'timeFieldTypeTime'. To keep the existing behavior, use 'timeFieldTypeText'. See 'https://github.com/yesodweb/yesod/pull/874' for details." #-}
|
||||
timeField = timeFieldTypeTime
|
||||
|
||||
-- | Creates an input with @type="time"@. <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"
|
||||
|
||||
-- | Creates an input with @type="text"@, parsing the time from an [H]H:MM[:SS] format, with an optional AM or PM (if not given, AM is assumed for compatibility with the 24 hour clock system).
|
||||
--
|
||||
-- This function exists for backwards compatibility with the old implementation of 'timeField', which used to use @type="text"@. Consider using 'timeField' or 'timeFieldTypeTime' for improved UX and validation from the browser.
|
||||
--
|
||||
-- Add the @time@ package and import the "Data.Time.LocalTime" module to use this function.
|
||||
--
|
||||
@ -420,15 +421,15 @@ urlField = Field
|
||||
-- > areq (selectFieldList [("Value 1" :: Text, "value1"),("Value 2", "value2")]) "Which value?" Nothing
|
||||
selectFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
|
||||
=> [(msg, a)]
|
||||
-> Field (HandlerT site IO) a
|
||||
-> Field (HandlerFor site) a
|
||||
selectFieldList = selectField . optionsPairs
|
||||
|
||||
-- | Creates a @\<select>@ tag for selecting one option. Example usage:
|
||||
--
|
||||
-- > areq (selectField $ optionsPairs [(MsgValue1, "value1"),(MsgValue2, "value2")]) "Which value?" Nothing
|
||||
selectField :: (Eq a, RenderMessage site FormMessage)
|
||||
=> HandlerT site IO (OptionList a)
|
||||
-> Field (HandlerT site IO) a
|
||||
=> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
selectField = selectFieldHelper
|
||||
(\theId name attrs inside -> [whamlet|
|
||||
$newline never
|
||||
@ -446,13 +447,13 @@ $newline never
|
||||
-- | Creates a @\<select>@ tag for selecting multiple options.
|
||||
multiSelectFieldList :: (Eq a, RenderMessage site msg)
|
||||
=> [(msg, a)]
|
||||
-> Field (HandlerT site IO) [a]
|
||||
-> Field (HandlerFor site) [a]
|
||||
multiSelectFieldList = multiSelectField . optionsPairs
|
||||
|
||||
-- | Creates a @\<select>@ tag for selecting multiple options.
|
||||
multiSelectField :: Eq a
|
||||
=> HandlerT site IO (OptionList a)
|
||||
-> Field (HandlerT site IO) [a]
|
||||
=> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) [a]
|
||||
multiSelectField ioptlist =
|
||||
Field parse view UrlEncoded
|
||||
where
|
||||
@ -478,18 +479,18 @@ multiSelectField ioptlist =
|
||||
-- | Creates an input with @type="radio"@ for selecting one option.
|
||||
radioFieldList :: (Eq a, RenderMessage site FormMessage, RenderMessage site msg)
|
||||
=> [(msg, a)]
|
||||
-> Field (HandlerT site IO) a
|
||||
-> Field (HandlerFor site) a
|
||||
radioFieldList = radioField . optionsPairs
|
||||
|
||||
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
|
||||
checkboxesFieldList :: (Eq a, RenderMessage site msg) => [(msg, a)]
|
||||
-> Field (HandlerT site IO) [a]
|
||||
-> Field (HandlerFor site) [a]
|
||||
checkboxesFieldList = checkboxesField . optionsPairs
|
||||
|
||||
-- | Creates an input with @type="checkbox"@ for selecting multiple options.
|
||||
checkboxesField :: Eq a
|
||||
=> HandlerT site IO (OptionList a)
|
||||
-> Field (HandlerT site IO) [a]
|
||||
=> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) [a]
|
||||
checkboxesField ioptlist = (multiSelectField ioptlist)
|
||||
{ fieldView =
|
||||
\theId name attrs val _isReq -> do
|
||||
@ -506,8 +507,8 @@ checkboxesField ioptlist = (multiSelectField ioptlist)
|
||||
}
|
||||
-- | Creates an input with @type="radio"@ for selecting one option.
|
||||
radioField :: (Eq a, RenderMessage site FormMessage)
|
||||
=> HandlerT site IO (OptionList a)
|
||||
-> Field (HandlerT site IO) a
|
||||
=> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
radioField = selectFieldHelper
|
||||
(\theId _name _attrs inside -> [whamlet|
|
||||
$newline never
|
||||
@ -663,7 +664,7 @@ optionsPersist :: ( YesodPersist site
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
-> HandlerT site IO (OptionList (Entity a))
|
||||
-> HandlerFor site (OptionList (Entity a))
|
||||
#else
|
||||
optionsPersist :: ( YesodPersist site, PersistEntity a
|
||||
, PersistQuery (PersistEntityBackend a)
|
||||
@ -674,7 +675,7 @@ optionsPersist :: ( YesodPersist site, PersistEntity a
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
-> HandlerT site IO (OptionList (Entity a))
|
||||
-> HandlerFor site (OptionList (Entity a))
|
||||
#endif
|
||||
optionsPersist filts ords toDisplay = fmap mkOptionList $ do
|
||||
mr <- getMessageRender
|
||||
@ -701,7 +702,7 @@ optionsPersistKey
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
-> HandlerT site IO (OptionList (Key a))
|
||||
-> HandlerFor site (OptionList (Key a))
|
||||
#else
|
||||
optionsPersistKey
|
||||
:: (YesodPersist site
|
||||
@ -714,7 +715,7 @@ optionsPersistKey
|
||||
=> [Filter a]
|
||||
-> [SelectOpt a]
|
||||
-> (a -> msg)
|
||||
-> HandlerT site IO (OptionList (Key a))
|
||||
-> HandlerFor site (OptionList (Key a))
|
||||
#endif
|
||||
|
||||
optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
|
||||
@ -728,11 +729,11 @@ optionsPersistKey filts ords toDisplay = fmap mkOptionList $ do
|
||||
|
||||
selectFieldHelper
|
||||
:: (Eq a, RenderMessage site FormMessage)
|
||||
=> (Text -> Text -> [(Text, Text)] -> WidgetT site IO () -> WidgetT site IO ())
|
||||
-> (Text -> Text -> Bool -> WidgetT site IO ())
|
||||
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetT site IO ())
|
||||
-> HandlerT site IO (OptionList a)
|
||||
-> Field (HandlerT site IO) a
|
||||
=> (Text -> Text -> [(Text, Text)] -> WidgetFor site () -> WidgetFor site ())
|
||||
-> (Text -> Text -> Bool -> WidgetFor site ())
|
||||
-> (Text -> Text -> [(Text, Text)] -> Text -> Bool -> Text -> WidgetFor site ())
|
||||
-> HandlerFor site (OptionList a)
|
||||
-> Field (HandlerFor site) a
|
||||
selectFieldHelper outside onOpt inside opts' = Field
|
||||
{ fieldParse = \x _ -> do
|
||||
opts <- opts'
|
||||
|
||||
@ -385,8 +385,8 @@ getHelper form env = do
|
||||
identifyForm
|
||||
:: Monad m
|
||||
=> Text -- ^ Form identification string.
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
-> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
|
||||
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
|
||||
-> (Html -> MForm m (FormResult a, WidgetFor (HandlerSite m) ()))
|
||||
identifyForm identVal form = \fragment -> do
|
||||
-- Create hidden <input>.
|
||||
let fragment' =
|
||||
@ -418,7 +418,7 @@ identifyFormKey = "_formid"
|
||||
type FormRender m a =
|
||||
AForm m a
|
||||
-> Html
|
||||
-> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
|
||||
-> MForm m (FormResult a, WidgetFor (HandlerSite m) ())
|
||||
|
||||
renderTable, renderDivs, renderDivsNoLabels :: Monad m => FormRender m a
|
||||
-- | Render a form into a series of tr tags. Note that, in order to allow
|
||||
|
||||
@ -53,16 +53,16 @@ class YesodJquery a where
|
||||
urlJqueryUiDateTimePicker :: a -> Either (Route a) Text
|
||||
urlJqueryUiDateTimePicker _ = Right "http://github.com/gregwebs/jquery.ui.datetimepicker/raw/master/jquery.ui.datetimepicker.js"
|
||||
|
||||
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day
|
||||
jqueryDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
|
||||
jqueryDayField = flip jqueryDayField' "date"
|
||||
|
||||
-- | Use jQuery's datepicker as the underlying implementation.
|
||||
--
|
||||
-- Since 1.4.3
|
||||
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) Day
|
||||
jqueryDatePickerDayField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerFor site) Day
|
||||
jqueryDatePickerDayField = flip jqueryDayField' "text"
|
||||
|
||||
jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerT site IO) Day
|
||||
jqueryDayField' :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Text -> Field (HandlerFor site) Day
|
||||
jqueryDayField' jds inputType = Field
|
||||
{ fieldParse = parseHelper $ maybe
|
||||
(Left MsgInvalidDay)
|
||||
@ -107,13 +107,13 @@ $(function(){
|
||||
]
|
||||
|
||||
jqueryAutocompleteField :: (RenderMessage site FormMessage, YesodJquery site)
|
||||
=> Route site -> Field (HandlerT site IO) Text
|
||||
=> Route site -> Field (HandlerFor site) Text
|
||||
jqueryAutocompleteField = jqueryAutocompleteField' 2
|
||||
|
||||
jqueryAutocompleteField' :: (RenderMessage site FormMessage, YesodJquery site)
|
||||
=> Int -- ^ autocomplete minimum length
|
||||
-> Route site
|
||||
-> Field (HandlerT site IO) Text
|
||||
-> Field (HandlerFor site) Text
|
||||
jqueryAutocompleteField' minLen src = Field
|
||||
{ fieldParse = parseHelper $ Right
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
|
||||
@ -44,17 +44,17 @@ up i = do
|
||||
|
||||
-- | Generate a form that accepts 0 or more values from the user, allowing the
|
||||
-- user to specify that a new row is necessary.
|
||||
inputList :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)
|
||||
inputList :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
|
||||
=> Html
|
||||
-- ^ label for the form
|
||||
-> ([[FieldView site]] -> xml)
|
||||
-- ^ how to display the rows, usually either 'massDivs' or 'massTable'
|
||||
-> (Maybe a -> AForm (HandlerT site IO) a)
|
||||
-> (Maybe a -> AForm (HandlerFor site) a)
|
||||
-- ^ display a single row of the form, where @Maybe a@ gives the
|
||||
-- previously submitted value
|
||||
-> Maybe [a]
|
||||
-- ^ default initial values for the form
|
||||
-> AForm (HandlerT site IO) [a]
|
||||
-> AForm (HandlerFor site) [a]
|
||||
inputList label fixXml single mdef = formToAForm $ do
|
||||
theId <- lift newIdent
|
||||
down 1
|
||||
@ -94,9 +94,9 @@ $newline never
|
||||
, fvRequired = False
|
||||
}])
|
||||
|
||||
withDelete :: (xml ~ WidgetT site IO (), RenderMessage site FormMessage)
|
||||
=> AForm (HandlerT site IO) a
|
||||
-> MForm (HandlerT site IO) (Either xml (FormResult a, [FieldView site]))
|
||||
withDelete :: (xml ~ WidgetFor site (), RenderMessage site FormMessage)
|
||||
=> AForm (HandlerFor site) a
|
||||
-> MForm (HandlerFor site) (Either xml (FormResult a, [FieldView site]))
|
||||
withDelete af = do
|
||||
down 1
|
||||
deleteName <- newFormIdent
|
||||
@ -129,7 +129,7 @@ fixme eithers =
|
||||
|
||||
massDivs, massTable
|
||||
:: [[FieldView site]]
|
||||
-> WidgetT site IO ()
|
||||
-> WidgetFor site ()
|
||||
massDivs viewss = [whamlet|
|
||||
$newline never
|
||||
$forall views <- viewss
|
||||
|
||||
@ -29,7 +29,7 @@ class Yesod a => YesodNic a where
|
||||
urlNicEdit :: a -> Either (Route a) Text
|
||||
urlNicEdit _ = Right "http://js.nicedit.com/nicEdit-latest.js"
|
||||
|
||||
nicHtmlField :: YesodNic site => Field (HandlerT site IO) Html
|
||||
nicHtmlField :: YesodNic site => Field (HandlerFor site) Html
|
||||
nicHtmlField = Field
|
||||
{ fieldParse = \e _ -> return . Right . fmap (preEscapedToMarkup . sanitizeBalance) . listToMaybe $ e
|
||||
, fieldView = \theId name attrs val _isReq -> do
|
||||
|
||||
@ -189,7 +189,7 @@ data FieldView site = FieldView
|
||||
{ fvLabel :: Html
|
||||
, fvTooltip :: Maybe Html
|
||||
, fvId :: Text
|
||||
, fvInput :: WidgetT site IO ()
|
||||
, fvInput :: WidgetFor site ()
|
||||
, fvErrors :: Maybe Html
|
||||
, fvRequired :: Bool
|
||||
}
|
||||
@ -200,7 +200,7 @@ type FieldViewFunc m a
|
||||
-> [(Text, Text)] -- ^ Attributes
|
||||
-> Either Text a -- ^ Either (invalid text) or (legitimate result)
|
||||
-> Bool -- ^ Required?
|
||||
-> WidgetT (HandlerSite m) IO ()
|
||||
-> WidgetFor (HandlerSite m) ()
|
||||
|
||||
data Field m a = Field
|
||||
{ fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe a))
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-form
|
||||
version: 1.4.16
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -20,8 +20,8 @@ flag network-uri
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.4.14 && < 1.5
|
||||
, yesod-persistent >= 1.4 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-persistent >= 1.6 && < 1.7
|
||||
, time >= 1.1.4
|
||||
, shakespeare >= 2.0
|
||||
, persistent
|
||||
|
||||
@ -1,5 +1,9 @@
|
||||
# Changelog
|
||||
|
||||
## 1.6.1
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.6
|
||||
|
||||
* Create new datatype `EntryEnclosure` for self-documentation of `feedEntryEnclosure`.
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-newsfeed
|
||||
version: 1.6
|
||||
version: 1.6.1.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman, Patrick Brisbin
|
||||
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, time >= 1.1.4
|
||||
, shakespeare >= 2.0
|
||||
, bytestring >= 0.9.1.4
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.4.3
|
||||
|
||||
* Fix overly powerful constraints on get404 and getBy404.
|
||||
|
||||
@ -37,11 +37,11 @@ import qualified Database.Persist.Sql as SQL
|
||||
unSqlPersistT :: a -> a
|
||||
unSqlPersistT = id
|
||||
|
||||
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerT site IO)
|
||||
type YesodDB site = ReaderT (YesodPersistBackend site) (HandlerFor site)
|
||||
|
||||
class Monad (YesodDB site) => YesodPersist site where
|
||||
type YesodPersistBackend site
|
||||
runDB :: YesodDB site a -> HandlerT site IO a
|
||||
runDB :: YesodDB site a -> HandlerFor site a
|
||||
|
||||
-- | Helper for creating 'runDB'.
|
||||
--
|
||||
@ -49,8 +49,8 @@ class Monad (YesodDB site) => YesodPersist site where
|
||||
defaultRunDB :: PersistConfig c
|
||||
=> (site -> c)
|
||||
-> (site -> PersistConfigPool c)
|
||||
-> PersistConfigBackend c (HandlerT site IO) a
|
||||
-> HandlerT site IO a
|
||||
-> PersistConfigBackend c (HandlerFor site) a
|
||||
-> HandlerFor site a
|
||||
defaultRunDB getConfig getPool f = do
|
||||
master <- getYesod
|
||||
Database.Persist.runPool
|
||||
@ -74,10 +74,10 @@ class YesodPersist site => YesodPersistRunner site where
|
||||
-- least, a rollback will be used instead.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
getDBRunner :: HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||
getDBRunner :: HandlerFor site (DBRunner site, HandlerFor site ())
|
||||
|
||||
newtype DBRunner site = DBRunner
|
||||
{ runDBRunner :: forall a. YesodDB site a -> HandlerT site IO a
|
||||
{ runDBRunner :: forall a. YesodDB site a -> HandlerFor site a
|
||||
}
|
||||
|
||||
-- | Helper for implementing 'getDBRunner'.
|
||||
@ -86,11 +86,11 @@ newtype DBRunner site = DBRunner
|
||||
#if MIN_VERSION_persistent(2,5,0)
|
||||
defaultGetDBRunner :: (SQL.IsSqlBackend backend, YesodPersistBackend site ~ backend)
|
||||
=> (site -> Pool backend)
|
||||
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||
-> HandlerFor site (DBRunner site, HandlerFor site ())
|
||||
#else
|
||||
defaultGetDBRunner :: YesodPersistBackend site ~ SQL.SqlBackend
|
||||
=> (site -> Pool SQL.SqlBackend)
|
||||
-> HandlerT site IO (DBRunner site, HandlerT site IO ())
|
||||
-> HandlerFor site (DBRunner site, HandlerFor site ())
|
||||
#endif
|
||||
defaultGetDBRunner getPool = do
|
||||
pool <- fmap getPool getYesod
|
||||
@ -118,8 +118,8 @@ defaultGetDBRunner getPool = do
|
||||
--
|
||||
-- Since 1.2.0
|
||||
runDBSource :: YesodPersistRunner site
|
||||
=> Source (YesodDB site) a
|
||||
-> Source (HandlerT site IO) a
|
||||
=> ConduitT () a (YesodDB site) ()
|
||||
-> ConduitT () a (HandlerFor site) ()
|
||||
runDBSource src = do
|
||||
(dbrunner, cleanup) <- lift getDBRunner
|
||||
transPipe (runDBRunner dbrunner) src
|
||||
@ -128,8 +128,8 @@ runDBSource src = do
|
||||
-- | Extends 'respondSource' to create a streaming database response body.
|
||||
respondSourceDB :: YesodPersistRunner site
|
||||
=> ContentType
|
||||
-> Source (YesodDB site) (Flush Builder)
|
||||
-> HandlerT site IO TypedContent
|
||||
-> ConduitT () (Flush Builder) (YesodDB site) ()
|
||||
-> HandlerFor site TypedContent
|
||||
respondSourceDB ctype = respondSource ctype . runDBSource
|
||||
|
||||
-- | Get the given entity by ID, or return a 404 not found if it doesn't exist.
|
||||
|
||||
@ -45,7 +45,7 @@ getHomeR = do
|
||||
insert_ $ Person "Charlie"
|
||||
insert_ $ Person "Alice"
|
||||
insert_ $ Person "Bob"
|
||||
respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder
|
||||
respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder
|
||||
where
|
||||
toBuilder (Entity _ (Person name)) = do
|
||||
yield $ Chunk $ fromText name
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-persistent
|
||||
version: 1.4.3
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -15,8 +15,8 @@ extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.4.0 && < 1.5
|
||||
, persistent >= 2.1 && < 2.8
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, persistent >= 2.8 && < 2.9
|
||||
, persistent-template >= 2.1 && < 2.8
|
||||
, transformers >= 0.2.2
|
||||
, blaze-builder
|
||||
|
||||
@ -0,0 +1,3 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
@ -74,19 +74,19 @@ robots smurl = do
|
||||
-- | Serve a stream of @SitemapUrl@s as a sitemap.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
sitemap :: Source (HandlerT site IO) (SitemapUrl (Route site))
|
||||
-> HandlerT site IO TypedContent
|
||||
sitemap :: ConduitT () (SitemapUrl (Route site)) (HandlerFor site) ()
|
||||
-> HandlerFor site TypedContent
|
||||
sitemap urls = do
|
||||
render <- getUrlRender
|
||||
respondSource typeXml $ do
|
||||
yield Flush
|
||||
urls $= sitemapConduit render $= renderBuilder def $= CL.map Chunk
|
||||
urls .| sitemapConduit render .| renderBuilder def .| CL.map Chunk
|
||||
|
||||
-- | Convenience wrapper for @sitemap@ for the case when the input is an
|
||||
-- in-memory list.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
sitemapList :: [SitemapUrl (Route site)] -> HandlerT site IO TypedContent
|
||||
sitemapList :: [SitemapUrl (Route site)] -> HandlerFor site TypedContent
|
||||
sitemapList = sitemap . mapM_ yield
|
||||
|
||||
-- | Convert a stream of @SitemapUrl@s to XML @Event@s using the given URL
|
||||
@ -97,7 +97,7 @@ sitemapList = sitemap . mapM_ yield
|
||||
-- Since 1.2.0
|
||||
sitemapConduit :: Monad m
|
||||
=> (a -> Text)
|
||||
-> Conduit (SitemapUrl a) m Event
|
||||
-> ConduitT (SitemapUrl a) Event m ()
|
||||
sitemapConduit render = do
|
||||
yield EventBeginDocument
|
||||
element "urlset" [] $ awaitForever goUrl
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-sitemap
|
||||
version: 1.4.0.1
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -15,7 +15,7 @@ extra-source-files: README.md ChangeLog.md
|
||||
|
||||
library
|
||||
build-depends: base >= 4 && < 5
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, time >= 1.1.4
|
||||
, xml-conduit >= 1.0
|
||||
, text
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.5.3.1
|
||||
|
||||
* Switch to cryptonite
|
||||
|
||||
@ -57,10 +57,7 @@ import Network.HTTP.Types.Status (status404)
|
||||
import Network.Wai (responseLBS, pathInfo)
|
||||
import Network.Wai.Application.Static (staticApp)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Yesod.Core
|
||||
( HandlerT
|
||||
, YesodSubDispatch(..)
|
||||
)
|
||||
import Yesod.Core (YesodSubDispatch(..))
|
||||
import Yesod.Core.Types
|
||||
( YesodSubRunnerEnv(..)
|
||||
, YesodRunnerEnv(..)
|
||||
|
||||
@ -25,7 +25,7 @@ import Network.Wai
|
||||
import Network.Wai.Application.Static (defaultWebAppSettings, staticApp)
|
||||
import WaiAppStatic.Types
|
||||
import Yesod.Core
|
||||
( HandlerT
|
||||
( HandlerFor
|
||||
, ParseRoute(..)
|
||||
, RenderRoute(..)
|
||||
, getYesod
|
||||
@ -136,7 +136,7 @@ develApp settings extra req sendResponse = do
|
||||
|
||||
-- | The type of 'addStaticContent'
|
||||
type AddStaticContent site = T.Text -> T.Text -> BL.ByteString
|
||||
-> HandlerT site IO (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
|
||||
-> HandlerFor site (Maybe (Either T.Text (Route site, [(T.Text, T.Text)])))
|
||||
|
||||
-- | Helper for embedStaticContent and embedLicensedStaticContent.
|
||||
staticContentHelper :: (site -> EmbeddedStatic)
|
||||
|
||||
@ -68,7 +68,6 @@ import qualified System.FilePath as FP
|
||||
import Control.Monad
|
||||
import Data.FileEmbed (embedDir)
|
||||
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Types
|
||||
|
||||
@ -94,7 +93,6 @@ import qualified Data.ByteString as S
|
||||
import System.PosixCompat.Files (getFileStatus, modificationTime)
|
||||
import System.Posix.Types (EpochTime)
|
||||
import Conduit
|
||||
import Data.Functor.Identity (runIdentity)
|
||||
import System.FilePath ((</>), (<.>), takeDirectory)
|
||||
import qualified System.FilePath as F
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-static
|
||||
version: 1.5.3.1
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -29,7 +29,7 @@ library
|
||||
build-depends: base >= 4 && < 5
|
||||
, containers >= 0.2
|
||||
, old-time >= 1.0
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, base64-bytestring >= 0.1.0.1
|
||||
, byteable >= 0.1
|
||||
, bytestring >= 0.9.1.4
|
||||
@ -91,7 +91,7 @@ test-suite tests
|
||||
YesodStaticTest
|
||||
build-depends: base
|
||||
, hspec >= 1.3
|
||||
, yesod-test >= 1.4
|
||||
, yesod-test >= 1.6
|
||||
, wai-extra
|
||||
, HUnit
|
||||
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6.0
|
||||
|
||||
## 1.5.9.1
|
||||
|
||||
* Fixes a Haddock syntax error in 1.5.9 [#1473](https://github.com/yesodweb/yesod/pull/1473)
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
{-|
|
||||
Yesod.Test is a pragmatic framework for testing web applications built
|
||||
@ -63,6 +64,7 @@ module Yesod.Test
|
||||
, addFile
|
||||
, setRequestBody
|
||||
, RequestBuilder
|
||||
, SIO
|
||||
, setUrl
|
||||
, clickOn
|
||||
|
||||
@ -136,6 +138,7 @@ import Data.CaseInsensitive (CI)
|
||||
import Network.Wai
|
||||
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
|
||||
import Control.Monad.Trans.Reader (ReaderT (..))
|
||||
import Conduit (MonadThrow)
|
||||
import Control.Monad.IO.Class
|
||||
import System.IO
|
||||
import Yesod.Core.Unsafe (runFakeHandler)
|
||||
@ -181,7 +184,7 @@ data YesodExampleData site = YesodExampleData
|
||||
-- | A single test case, to be run with 'yit'.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
type YesodExample site = ReaderT (IORef (YesodExampleData site)) IO
|
||||
type YesodExample site = SIO (YesodExampleData site)
|
||||
|
||||
-- | Mapping from cookie name to value.
|
||||
--
|
||||
@ -204,13 +207,13 @@ data YesodSpecTree site
|
||||
--
|
||||
-- Since 1.2.0
|
||||
getTestYesod :: YesodExample site site
|
||||
getTestYesod = fmap yedSite getState
|
||||
getTestYesod = fmap yedSite getSIO
|
||||
|
||||
-- | Get the most recently provided response value, if available.
|
||||
--
|
||||
-- Since 1.2.0
|
||||
getResponse :: YesodExample site (Maybe SResponse)
|
||||
getResponse = fmap yedResponse getState
|
||||
getResponse = fmap yedResponse getSIO
|
||||
|
||||
data RequestBuilderData site = RequestBuilderData
|
||||
{ rbdPostData :: RBDPostData
|
||||
@ -233,7 +236,7 @@ data RequestPart
|
||||
-- | The 'RequestBuilder' state monad constructs a URL encoded string of arguments
|
||||
-- to send with your requests. Some of the functions that run on it use the current
|
||||
-- response to analyze the forms that the server is expecting to receive.
|
||||
type RequestBuilder site = ReaderT (IORef (RequestBuilderData site)) IO
|
||||
type RequestBuilder site = SIO (RequestBuilderData site)
|
||||
|
||||
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
|
||||
-- and 'ConnectionPool'
|
||||
@ -250,7 +253,7 @@ yesodSpec site yspecs =
|
||||
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
|
||||
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
|
||||
app <- toWaiAppPlain site
|
||||
evalStateT y YesodExampleData
|
||||
evalSIO y YesodExampleData
|
||||
{ yedApp = app
|
||||
, yedSite = site
|
||||
, yedCookies = M.empty
|
||||
@ -270,7 +273,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
|
||||
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
|
||||
site <- getSiteAction'
|
||||
app <- toWaiAppPlain site
|
||||
evalStateT y YesodExampleData
|
||||
evalSIO y YesodExampleData
|
||||
{ yedApp = app
|
||||
, yedSite = site
|
||||
, yedCookies = M.empty
|
||||
@ -291,7 +294,7 @@ yesodSpecApp site getApp yspecs =
|
||||
unYesod (YesodSpecGroup x y) = Hspec.specGroup x $ map unYesod y
|
||||
unYesod (YesodSpecItem x y) = Hspec.specItem x $ do
|
||||
app <- getApp
|
||||
evalStateT y YesodExampleData
|
||||
evalSIO y YesodExampleData
|
||||
{ yedApp = app
|
||||
, yedSite = site
|
||||
, yedCookies = M.empty
|
||||
@ -304,12 +307,11 @@ yit label example = tell [YesodSpecItem label example]
|
||||
|
||||
-- Performs a given action using the last response. Use this to create
|
||||
-- response-level assertions
|
||||
withResponse' :: MonadIO m
|
||||
=> (state -> Maybe SResponse)
|
||||
withResponse' :: (state -> Maybe SResponse)
|
||||
-> [T.Text]
|
||||
-> (SResponse -> ReaderT (IORef state) m a)
|
||||
-> ReaderT (IORef state) m a
|
||||
withResponse' getter errTrace f = maybe err f . getter =<< getState
|
||||
-> (SResponse -> SIO state a)
|
||||
-> SIO state a
|
||||
withResponse' getter errTrace f = maybe err f . getter =<< getSIO
|
||||
where err = failure msg
|
||||
msg = if null errTrace
|
||||
then "There was no response, you should make a request."
|
||||
@ -328,11 +330,10 @@ parseHTML :: HtmlLBS -> Cursor
|
||||
parseHTML html = fromDocument $ HD.parseLBS html
|
||||
|
||||
-- | Query the last response using CSS selectors, returns a list of matched fragments
|
||||
htmlQuery' :: MonadIO m
|
||||
=> (state -> Maybe SResponse)
|
||||
htmlQuery' :: (state -> Maybe SResponse)
|
||||
-> [T.Text]
|
||||
-> Query
|
||||
-> ReaderT (IORef state) m [HtmlLBS]
|
||||
-> SIO state [HtmlLBS]
|
||||
htmlQuery' getter errTrace query = withResponse' getter ("Tried to invoke htmlQuery' in order to read HTML of a previous response." : errTrace) $ \ res ->
|
||||
case findBySelector (simpleBody res) query of
|
||||
Left err -> failure $ query <> " did not parse: " <> T.pack (show err)
|
||||
@ -497,14 +498,14 @@ printMatches query = do
|
||||
-- | Add a parameter with the given name and value to the request body.
|
||||
addPostParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addPostParam name value =
|
||||
modifyState $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
|
||||
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
|
||||
where addPostData (BinaryPostData _) = error "Trying to add post param to binary content."
|
||||
addPostData (MultipleItemsPostData posts) =
|
||||
MultipleItemsPostData $ ReqKvPart name value : posts
|
||||
|
||||
-- | Add a parameter with the given name and value to the query string.
|
||||
addGetParam :: T.Text -> T.Text -> RequestBuilder site ()
|
||||
addGetParam name value = modifyState $ \rbd -> rbd
|
||||
addGetParam name value = modifySIO $ \rbd -> rbd
|
||||
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
|
||||
: rbdGets rbd
|
||||
}
|
||||
@ -523,7 +524,7 @@ addFile :: T.Text -- ^ The parameter name for the file.
|
||||
-> RequestBuilder site ()
|
||||
addFile name path mimetype = do
|
||||
contents <- liftIO $ BSL8.readFile path
|
||||
modifyState $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
|
||||
modifySIO $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
|
||||
where addPostData (BinaryPostData _) _ = error "Trying to add file after setting binary content."
|
||||
addPostData (MultipleItemsPostData posts) contents =
|
||||
MultipleItemsPostData $ ReqFilePart name path contents mimetype : posts
|
||||
@ -532,7 +533,7 @@ addFile name path mimetype = do
|
||||
-- This looks up the name of a field based on the contents of the label pointing to it.
|
||||
genericNameFromLabel :: (T.Text -> T.Text -> Bool) -> T.Text -> RequestBuilder site T.Text
|
||||
genericNameFromLabel match label = do
|
||||
mres <- fmap rbdResponse getState
|
||||
mres <- fmap rbdResponse getSIO
|
||||
res <-
|
||||
case mres of
|
||||
Nothing -> failure "genericNameFromLabel: No response available"
|
||||
@ -799,7 +800,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
|
||||
-- Since 1.4.3.2
|
||||
getRequestCookies :: RequestBuilder site Cookies
|
||||
getRequestCookies = do
|
||||
requestBuilderData <- getState
|
||||
requestBuilderData <- getSIO
|
||||
headers <- case simpleHeaders Control.Applicative.<$> rbdResponse requestBuilderData of
|
||||
Just h -> return h
|
||||
Nothing -> failure "getRequestCookies: No request has been made yet; the cookies can't be looked up."
|
||||
@ -907,7 +908,7 @@ getLocation = do
|
||||
-- > request $ do
|
||||
-- > setMethod methodPut
|
||||
setMethod :: H.Method -> RequestBuilder site ()
|
||||
setMethod m = modifyState $ \rbd -> rbd { rbdMethod = m }
|
||||
setMethod m = modifySIO $ \rbd -> rbd { rbdMethod = m }
|
||||
|
||||
-- | Sets the URL used by the request.
|
||||
--
|
||||
@ -922,7 +923,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
|
||||
=> url
|
||||
-> RequestBuilder site ()
|
||||
setUrl url' = do
|
||||
site <- fmap rbdSite getState
|
||||
site <- fmap rbdSite getSIO
|
||||
eurl <- Yesod.Core.Unsafe.runFakeHandler
|
||||
M.empty
|
||||
(const $ error "Yesod.Test: No logger available")
|
||||
@ -930,7 +931,7 @@ setUrl url' = do
|
||||
(toTextUrl url')
|
||||
url <- either (error . show) return eurl
|
||||
let (urlPath, urlQuery) = T.break (== '?') url
|
||||
modifyState $ \rbd -> rbd
|
||||
modifySIO $ \rbd -> rbd
|
||||
{ rbdPath =
|
||||
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
|
||||
("http:":_:rest) -> rest
|
||||
@ -969,7 +970,7 @@ clickOn query = do
|
||||
-- > request $ do
|
||||
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
|
||||
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
|
||||
setRequestBody body = modifyState $ \rbd -> rbd { rbdPostData = BinaryPostData body }
|
||||
setRequestBody body = modifySIO $ \rbd -> rbd { rbdPostData = BinaryPostData body }
|
||||
|
||||
-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.
|
||||
--
|
||||
@ -979,7 +980,7 @@ setRequestBody body = modifyState $ \rbd -> rbd { rbdPostData = BinaryPostData b
|
||||
-- > request $ do
|
||||
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
|
||||
addRequestHeader :: H.Header -> RequestBuilder site ()
|
||||
addRequestHeader header = modifyState $ \rbd -> rbd
|
||||
addRequestHeader header = modifySIO $ \rbd -> rbd
|
||||
{ rbdHeaders = header : rbdHeaders rbd
|
||||
}
|
||||
|
||||
@ -999,9 +1000,9 @@ addRequestHeader header = modifyState $ \rbd -> rbd
|
||||
request :: RequestBuilder site ()
|
||||
-> YesodExample site ()
|
||||
request reqBuilder = do
|
||||
YesodExampleData app site oldCookies mRes <- getState
|
||||
YesodExampleData app site oldCookies mRes <- getSIO
|
||||
|
||||
RequestBuilderData {..} <- liftIO $ execStateT reqBuilder RequestBuilderData
|
||||
RequestBuilderData {..} <- liftIO $ execSIO reqBuilder RequestBuilderData
|
||||
{ rbdPostData = MultipleItemsPostData []
|
||||
, rbdResponse = mRes
|
||||
, rbdMethod = "GET"
|
||||
@ -1041,7 +1042,7 @@ request reqBuilder = do
|
||||
}) app
|
||||
let newCookies = parseSetCookies $ simpleHeaders response
|
||||
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
|
||||
putState $ YesodExampleData app site cookies' (Just response)
|
||||
putSIO $ YesodExampleData app site cookies' (Just response)
|
||||
where
|
||||
isFile (ReqFilePart _ _ _ _) = True
|
||||
isFile _ = False
|
||||
@ -1145,14 +1146,14 @@ testApp :: site -> Middleware -> TestApp site
|
||||
testApp site middleware = (site, middleware)
|
||||
type YSpec site = Hspec.SpecWith (TestApp site)
|
||||
|
||||
instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData site)) IO a) where
|
||||
type Arg (ReaderT (IORef (YesodExampleData site)) IO a) = TestApp site
|
||||
instance YesodDispatch site => Hspec.Example (SIO (YesodExampleData site) a) where
|
||||
type Arg (SIO (YesodExampleData site) a) = TestApp site
|
||||
|
||||
evaluateExample example params action =
|
||||
Hspec.evaluateExample
|
||||
(action $ \(site, middleware) -> do
|
||||
app <- toWaiAppPlain site
|
||||
_ <- evalStateT example YesodExampleData
|
||||
_ <- evalSIO example YesodExampleData
|
||||
{ yedApp = middleware app
|
||||
, yedSite = site
|
||||
, yedCookies = M.empty
|
||||
@ -1162,24 +1163,26 @@ instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData s
|
||||
params
|
||||
($ ())
|
||||
|
||||
getState :: MonadIO m => ReaderT (IORef s) m s
|
||||
getState = ReaderT $ liftIO . readIORef
|
||||
-- | State + IO
|
||||
--
|
||||
-- @since 1.6.0
|
||||
newtype SIO s a = SIO (ReaderT (IORef s) IO a)
|
||||
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadUnliftIO)
|
||||
|
||||
putState :: MonadIO m => s -> ReaderT (IORef s) m ()
|
||||
putState x = ReaderT $ \ref -> liftIO $ writeIORef ref $! x
|
||||
getSIO :: SIO s s
|
||||
getSIO = SIO $ ReaderT readIORef
|
||||
|
||||
modifyState :: MonadIO m => (s -> s) -> ReaderT (IORef s) m ()
|
||||
modifyState f = ReaderT $ \ref -> liftIO $ do
|
||||
x <- readIORef ref
|
||||
writeIORef ref $! f x
|
||||
putSIO :: s -> SIO s ()
|
||||
putSIO s = SIO $ ReaderT $ \ref -> writeIORef ref $! s
|
||||
|
||||
evalStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m a
|
||||
evalStateT (ReaderT f) s = do
|
||||
ref <- liftIO $ newIORef s
|
||||
modifySIO :: (s -> s) -> SIO s ()
|
||||
modifySIO f = SIO $ ReaderT $ \ref -> modifyIORef' ref f
|
||||
|
||||
evalSIO :: SIO s a -> s -> IO a
|
||||
evalSIO (SIO (ReaderT f)) s = newIORef s >>= f
|
||||
|
||||
execSIO :: SIO s () -> s -> IO s
|
||||
execSIO (SIO (ReaderT f)) s = do
|
||||
ref <- newIORef s
|
||||
f ref
|
||||
|
||||
execStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m s
|
||||
execStateT (ReaderT f) s = do
|
||||
ref <- liftIO $ newIORef s
|
||||
_ <- f ref
|
||||
liftIO $ readIORef ref
|
||||
readIORef ref
|
||||
|
||||
@ -37,7 +37,7 @@ import Data.ByteString.Lazy.Char8 ()
|
||||
import qualified Data.Map as Map
|
||||
import qualified Text.HTML.DOM as HD
|
||||
import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415)
|
||||
import UnliftIO (tryAny, SomeException, try)
|
||||
import UnliftIO.Exception (tryAny, SomeException, try)
|
||||
|
||||
parseQuery_ :: Text -> [[SelectorGroup]]
|
||||
parseQuery_ = either error id . parseQuery
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-test
|
||||
version: 1.5.9.1
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Nubis <nubis@woobiz.com.ar>
|
||||
@ -27,7 +27,6 @@ library
|
||||
, hspec-core == 2.*
|
||||
, html-conduit >= 0.1
|
||||
, http-types >= 0.7
|
||||
, monad-control
|
||||
, network >= 2.2
|
||||
, persistent >= 1.0
|
||||
, pretty-show >= 1.6
|
||||
@ -38,7 +37,8 @@ library
|
||||
, wai-extra
|
||||
, xml-conduit >= 1.0
|
||||
, xml-types >= 0.3
|
||||
, yesod-core >= 1.4.14
|
||||
, yesod-core >= 1.6
|
||||
, conduit
|
||||
|
||||
exposed-modules: Yesod.Test
|
||||
Yesod.Test.CssQuery
|
||||
@ -58,7 +58,7 @@ test-suite test
|
||||
, containers
|
||||
, html-conduit
|
||||
, yesod-core
|
||||
, yesod-form >= 1.4.14
|
||||
, yesod-form >= 1.6
|
||||
, text
|
||||
, wai
|
||||
, http-types
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 0.3.0
|
||||
|
||||
* Upgrade to yesod-core 1.6
|
||||
|
||||
## 0.2.6
|
||||
|
||||
* Fix warnings
|
||||
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
module Yesod.WebSockets
|
||||
@ -34,10 +33,9 @@ module Yesod.WebSockets
|
||||
, WS.ConnectionOptions (..)
|
||||
) where
|
||||
|
||||
import Control.Monad (forever, void, when)
|
||||
import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT))
|
||||
import qualified Data.Conduit as C
|
||||
import qualified Data.Conduit.List as CL
|
||||
import Control.Monad (forever, when)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask)
|
||||
import Conduit
|
||||
import qualified Network.Wai.Handler.WebSockets as WaiWS
|
||||
import qualified Network.WebSockets as WS
|
||||
import qualified Yesod.Core as Y
|
||||
@ -55,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection
|
||||
-- instead.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
webSockets :: (Y.MonadUnliftIO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
|
||||
webSockets
|
||||
:: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WebSocketsT m ()
|
||||
-> m ()
|
||||
webSockets = webSocketsOptions WS.defaultConnectionOptions
|
||||
|
||||
-- | Varient of 'webSockets' which allows you to specify
|
||||
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.5
|
||||
webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-> WebSocketsT m ()
|
||||
-> m ()
|
||||
#if MIN_VERSION_websockets(0,10,0)
|
||||
webSocketsOptions
|
||||
:: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-> WebSocketsT m ()
|
||||
-> m ()
|
||||
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
|
||||
#else
|
||||
webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing
|
||||
#endif
|
||||
|
||||
-- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
|
||||
-- setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.4
|
||||
webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
|
||||
-- ^ A Nothing indicates that the websocket upgrade request should not happen
|
||||
-- and instead the rest of the handler will be called instead. This allows
|
||||
@ -93,7 +91,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
|
||||
-- setttings when upgrading to a websocket connection.
|
||||
--
|
||||
-- Since 0.2.5
|
||||
webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
|
||||
webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
|
||||
=> WS.ConnectionOptions
|
||||
-- ^ Custom websockets options
|
||||
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
|
||||
@ -125,100 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
|
||||
sink
|
||||
|
||||
-- | Wrapper for capturing exceptions
|
||||
wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ())
|
||||
wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x
|
||||
wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> (WS.Connection -> a -> IO ())
|
||||
-> a
|
||||
-> m (Either SomeException ())
|
||||
wrapWSE ws x = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ ws conn x
|
||||
|
||||
wrapWS :: MonadIO m => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m ()
|
||||
wrapWS ws x = ReaderT $ liftIO . flip ws x
|
||||
wrapWS :: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> (WS.Connection -> a -> IO ())
|
||||
-> a
|
||||
-> m ()
|
||||
wrapWS ws x = do
|
||||
conn <- ask
|
||||
liftIO $ ws conn x
|
||||
|
||||
-- | Receive a piece of data from the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
|
||||
receiveData = ReaderT $ liftIO . WS.receiveData
|
||||
receiveData
|
||||
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
|
||||
=> m a
|
||||
receiveData = do
|
||||
conn <- ask
|
||||
liftIO $ WS.receiveData conn
|
||||
|
||||
-- | Receive a piece of data from the client.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- Since 0.2.2
|
||||
receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a)
|
||||
receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData
|
||||
receiveDataE
|
||||
:: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
|
||||
=> m (Either SomeException a)
|
||||
receiveDataE = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.receiveData conn
|
||||
|
||||
-- | Receive an application message.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- Since 0.2.3
|
||||
receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage)
|
||||
receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage
|
||||
receiveDataMessageE
|
||||
:: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> m (Either SomeException WS.DataMessage)
|
||||
receiveDataMessageE = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.receiveDataMessage conn
|
||||
|
||||
-- | Send a textual message to the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendTextData
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m ()
|
||||
sendTextData = wrapWS WS.sendTextData
|
||||
|
||||
-- | Send a textual message to the client.
|
||||
-- Capture SomeException as the result or operation
|
||||
-- and can be used like
|
||||
-- and can be used like
|
||||
-- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
|
||||
-- Since 0.2.2
|
||||
sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendTextDataE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendTextDataE = wrapWSE WS.sendTextData
|
||||
|
||||
-- | Send a binary message to the client.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendBinaryData
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m ()
|
||||
sendBinaryData = wrapWS WS.sendBinaryData
|
||||
|
||||
-- | Send a binary message to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendBinaryDataE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendBinaryDataE = wrapWSE WS.sendBinaryData
|
||||
|
||||
-- | Send a ping message to the client.
|
||||
--
|
||||
-- Since 0.2.2
|
||||
sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendPing
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> WebSocketsT m ()
|
||||
sendPing = wrapWS WS.sendPing
|
||||
|
||||
-- | Send a ping message to the client.
|
||||
-- | Send a ping message to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendPingE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendPingE = wrapWSE WS.sendPing
|
||||
|
||||
-- | Send a DataMessage to the client.
|
||||
-- | Send a DataMessage to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.3
|
||||
sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ())
|
||||
sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x)
|
||||
sendDataMessageE
|
||||
:: (MonadIO m, MonadReader WS.Connection m)
|
||||
=> WS.DataMessage
|
||||
-> m (Either SomeException ())
|
||||
sendDataMessageE x = do
|
||||
conn <- ask
|
||||
liftIO $ tryAny $ WS.sendDataMessage conn x
|
||||
|
||||
-- | Send a close request to the client.
|
||||
--
|
||||
-- | Send a close request to the client.
|
||||
--
|
||||
-- Since 0.2.2
|
||||
sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
|
||||
sendClose
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> WebSocketsT m ()
|
||||
sendClose = wrapWS WS.sendClose
|
||||
|
||||
-- | Send a close request to the client.
|
||||
-- | Send a close request to the client.
|
||||
-- Capture SomeException as the result of operation
|
||||
-- Since 0.2.2
|
||||
sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
|
||||
sendCloseE
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> a
|
||||
-> m (Either SomeException ())
|
||||
sendCloseE = wrapWSE WS.sendClose
|
||||
|
||||
-- | A @Source@ of WebSockets data from the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
|
||||
sourceWS = forever $ Y.lift receiveData >>= C.yield
|
||||
sourceWS
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT i a m ()
|
||||
sourceWS = forever $ lift receiveData >>= yield
|
||||
|
||||
-- | A @Sink@ for sending textual data to the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
|
||||
sinkWSText = CL.mapM_ sendTextData
|
||||
sinkWSText
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT a o m ()
|
||||
sinkWSText = mapM_C sendTextData
|
||||
|
||||
-- | A @Sink@ for sending binary data to the user.
|
||||
--
|
||||
-- Since 0.1.0
|
||||
sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
|
||||
sinkWSBinary = CL.mapM_ sendBinaryData
|
||||
sinkWSBinary
|
||||
:: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
|
||||
=> ConduitT a o m ()
|
||||
sinkWSBinary = mapM_C sendBinaryData
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod-websockets
|
||||
version: 0.2.6
|
||||
version: 0.3.0
|
||||
synopsis: WebSockets support for Yesod
|
||||
description: WebSockets support for Yesod
|
||||
homepage: https://github.com/yesodweb/yesod
|
||||
@ -21,11 +21,12 @@ library
|
||||
, wai
|
||||
|
||||
, wai-websockets >= 2.1
|
||||
, websockets >= 0.9
|
||||
, websockets >= 0.10
|
||||
, transformers >= 0.2
|
||||
, yesod-core >= 1.4
|
||||
, yesod-core >= 1.6
|
||||
, unliftio
|
||||
, conduit >= 1.0.15.1
|
||||
, conduit >= 1.3
|
||||
, mtl
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
@ -1,3 +1,7 @@
|
||||
## 1.6.0
|
||||
|
||||
* Upgrade to yesod-core 1.6
|
||||
|
||||
## 1.4.5
|
||||
|
||||
* Fix warnings
|
||||
|
||||
@ -40,7 +40,7 @@ addStaticContentExternal
|
||||
-> Text -- ^ filename extension
|
||||
-> Text -- ^ mime type
|
||||
-> L.ByteString -- ^ file contents
|
||||
-> HandlerT master IO (Maybe (Either Text (Route master, [(Text, Text)])))
|
||||
-> HandlerFor master (Maybe (Either Text (Route master, [(Text, Text)])))
|
||||
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
|
||||
liftIO $ createDirectoryIfMissing True statictmp
|
||||
exists <- liftIO $ doesFileExist fn'
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
name: yesod
|
||||
version: 1.4.5
|
||||
version: 1.6.0
|
||||
license: MIT
|
||||
license-file: LICENSE
|
||||
author: Michael Snoyman <michael@snoyman.com>
|
||||
@ -18,10 +18,9 @@ library
|
||||
cpp-options: -DWINDOWS
|
||||
|
||||
build-depends: base >= 4.6 && < 5
|
||||
, yesod-core >= 1.4 && < 1.5
|
||||
, yesod-persistent >= 1.4 && < 1.5
|
||||
, yesod-form >= 1.4 && < 1.5
|
||||
, monad-control >= 0.3 && < 1.1
|
||||
, yesod-core >= 1.6 && < 1.7
|
||||
, yesod-persistent >= 1.6 && < 1.7
|
||||
, yesod-form >= 1.6 && < 1.7
|
||||
, transformers >= 0.2.2
|
||||
, wai >= 1.3
|
||||
, wai-extra >= 1.3
|
||||
|
||||
Loading…
Reference in New Issue
Block a user