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

Get it all compiling again

Browse Source
This commit is contained in:
Michael Snoyman 2018-01-15 17:08:55 +02:00
parent 915d9e2fa6
commit a210ce59d7
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
10 changed files with 79 additions and 355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -12,7 +12,7 @@ module Yesod.Auth.OAuth
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Exception.Lifted
import UnliftIO.Exception
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import Data.Maybe
@ -20,7 +20,6 @@ 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
yesod-auth-oauth/yesod-auth-oauth.cabal
View File

@ -28,6 +28,7 @@ library
, text >= 0.7
, yesod-form >= 1.6 && < 1.7
, transformers >= 0.2.2 && < 0.6
, unliftio
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

269
yesod-bin/Build.hs
View File

@ -1,269 +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 (SomeException, try, IOException, handle)
import Control.Monad (when, filterM, forM, forM_, (>=>))
import Control.Monad.Trans.State (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 . try . S.readFile
touch :: IO ()
touch = do
m <- handle (\(_ :: SomeException) -> 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
go (x, (ys, ct)) = do
isChanged <- handle (\(_ :: SomeException) -> return True) $ lift $
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 = try' (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
_ <- try' (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
try' :: IO x -> IO (Either SomeException x)
try' = try
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 <- try' $ 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
yesod-bin/ChangeLog.md
View File

@ -1,6 +1,7 @@
## 1.6.0
* Upgrade to conduit 1.3.0
* Remove configure, build, touch, and test commands
## 1.5.3

4
yesod-bin/Devel.hs
View File

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

65
yesod-bin/main.hs
View File

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

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

@ -57,7 +57,6 @@ executable yesod
, http-client-tls
, http-client >= 0.4.7
, project-template >= 0.1.1
, safe-exceptions
, say
, stm
, transformers
@ -68,13 +67,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

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

@ -135,7 +135,8 @@ import qualified Network.Socket.Internal as Sock
import Data.CaseInsensitive (CI)
import Network.Wai
import Network.Wai.Test hiding (assertHeader, assertNoHeader, request)
import qualified Control.Monad.Trans.State as ST
import Control.Monad.Trans.Reader
import Data.IORef
import Control.Monad.IO.Class
import System.IO
import Yesod.Core.Unsafe (runFakeHandler)
@ -180,7 +181,7 @@ data YesodExampleData site = YesodExampleData
-- | A single test case, to be run with 'yit'.
--
-- Since 1.2.0
type YesodExample site = ST.StateT (YesodExampleData site) IO
type YesodExample site = ReaderT (IORef (YesodExampleData site)) IO
-- | Mapping from cookie name to value.
--
@ -203,13 +204,13 @@ data YesodSpecTree site
--
-- Since 1.2.0
getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite ST.get
getTestYesod = fmap yedSite rsget
-- | Get the most recently provided response value, if available.
--
-- Since 1.2.0
getResponse :: YesodExample site (Maybe SResponse)
getResponse = fmap yedResponse ST.get
getResponse = fmap yedResponse rsget
data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData
@ -232,7 +233,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 = ST.StateT (RequestBuilderData site) IO
type RequestBuilder site = ReaderT (IORef (RequestBuilderData site)) IO
-- | Start describing a Tests suite keeping cookies and a reference to the tested 'Application'
-- and 'ConnectionPool'
@ -249,7 +250,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
ST.evalStateT y YesodExampleData
rsevalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -269,7 +270,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
site <- getSiteAction'
app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData
rsevalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -290,7 +291,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
ST.evalStateT y YesodExampleData
rsevalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -306,9 +307,9 @@ yit label example = tell [YesodSpecItem label example]
withResponse' :: MonadIO m
=> (state -> Maybe SResponse)
-> [T.Text]
-> (SResponse -> ST.StateT state m a)
-> ST.StateT state m a
withResponse' getter errTrace f = maybe err f . getter =<< ST.get
-> (SResponse -> ReaderT (IORef state) m a)
-> ReaderT (IORef state) m a
withResponse' getter errTrace f = maybe err f . getter =<< rsget
where err = failure msg
msg = if null errTrace
then "There was no response, you should make a request."
@ -331,7 +332,7 @@ htmlQuery' :: MonadIO m
=> (state -> Maybe SResponse)
-> [T.Text]
-> Query
-> ST.StateT state m [HtmlLBS]
-> ReaderT (IORef state) m [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)
@ -496,14 +497,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 =
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd)) }
rsmodify $ \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 = ST.modify $ \rbd -> rbd
addGetParam name value = rsmodify $ \rbd -> rbd
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd
}
@ -522,7 +523,7 @@ addFile :: T.Text -- ^ The parameter name for the file.
-> RequestBuilder site ()
addFile name path mimetype = do
contents <- liftIO $ BSL8.readFile path
ST.modify $ \rbd -> rbd { rbdPostData = (addPostData (rbdPostData rbd) contents) }
rsmodify $ \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
@ -531,7 +532,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 ST.get
mres <- fmap rbdResponse rsget
res <-
case mres of
Nothing -> failure "genericNameFromLabel: No response available"
@ -798,7 +799,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do
requestBuilderData <- ST.get
requestBuilderData <- rsget
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."
@ -906,7 +907,7 @@ getLocation = do
-- > request $ do
-- > setMethod methodPut
setMethod :: H.Method -> RequestBuilder site ()
setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }
setMethod m = rsmodify $ \rbd -> rbd { rbdMethod = m }
-- | Sets the URL used by the request.
--
@ -921,7 +922,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
=> url
-> RequestBuilder site ()
setUrl url' = do
site <- fmap rbdSite ST.get
site <- fmap rbdSite rsget
eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
@ -929,7 +930,7 @@ setUrl url' = do
(toTextUrl url')
url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url
ST.modify $ \rbd -> rbd
rsmodify $ \rbd -> rbd
{ rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest
@ -968,7 +969,7 @@ clickOn query = do
-- > request $ do
-- > setRequestBody $ encode $ object ["age" .= (1 :: Integer)]
setRequestBody :: BSL8.ByteString -> RequestBuilder site ()
setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData body }
setRequestBody body = rsmodify $ \rbd -> rbd { rbdPostData = BinaryPostData body }
-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.
--
@ -978,7 +979,7 @@ setRequestBody body = ST.modify $ \rbd -> rbd { rbdPostData = BinaryPostData bod
-- > request $ do
-- > addRequestHeader (hUserAgent, "Chrome/41.0.2228.0")
addRequestHeader :: H.Header -> RequestBuilder site ()
addRequestHeader header = ST.modify $ \rbd -> rbd
addRequestHeader header = rsmodify $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd
}
@ -998,9 +999,9 @@ addRequestHeader header = ST.modify $ \rbd -> rbd
request :: RequestBuilder site ()
-> YesodExample site ()
request reqBuilder = do
YesodExampleData app site oldCookies mRes <- ST.get
YesodExampleData app site oldCookies mRes <- rsget
RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData
RequestBuilderData {..} <- liftIO $ rsexecStateT reqBuilder RequestBuilderData
{ rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes
, rbdMethod = "GET"
@ -1040,7 +1041,7 @@ request reqBuilder = do
}) app
let newCookies = parseSetCookies $ simpleHeaders response
cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
ST.put $ YesodExampleData app site cookies' (Just response)
rsput $ YesodExampleData app site cookies' (Just response)
where
isFile (ReqFilePart _ _ _ _) = True
isFile _ = False
@ -1144,14 +1145,14 @@ testApp :: site -> Middleware -> TestApp site
testApp site middleware = (site, middleware)
type YSpec site = Hspec.SpecWith (TestApp site)
instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site) IO a) where
type Arg (ST.StateT (YesodExampleData site) IO a) = TestApp site
instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData site)) IO a) where
type Arg (ReaderT (IORef (YesodExampleData site)) IO a) = TestApp site
evaluateExample example params action =
Hspec.evaluateExample
(action $ \(site, middleware) -> do
app <- toWaiAppPlain site
_ <- ST.evalStateT example YesodExampleData
_ <- rsevalStateT example YesodExampleData
{ yedApp = middleware app
, yedSite = site
, yedCookies = M.empty
@ -1160,3 +1161,29 @@ instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site)
return ())
params
($ ())
rsget :: MonadIO m => ReaderT (IORef s) m s
rsget = ReaderT $ liftIO . readIORef
rsput :: MonadIO m => s -> ReaderT (IORef s) m ()
rsput s = ReaderT $ \ref -> liftIO $ writeIORef ref $! s
rsmodify :: MonadIO m => (s -> s) -> ReaderT (IORef s) m ()
rsmodify f = ReaderT $ \ref -> liftIO $ modifyIORef' ref f
rsevalStateT
:: MonadIO m
=> ReaderT (IORef s) m a
-> s
-> m a
rsevalStateT (ReaderT f) s = liftIO (newIORef s) >>= f
rsexecStateT
:: MonadIO m
=> ReaderT (IORef s) m ()
-> s
-> m s
rsexecStateT (ReaderT f) s = do
ref <- liftIO $ newIORef s
f ref
liftIO $ readIORef ref

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

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

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

@ -61,6 +61,7 @@ test-suite test
, text
, wai
, http-types
, unliftio
source-repository head
type: git