diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index 9a5d3a0e..8efefe3c 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -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 diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index 3176f6bd..38f6d047 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -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 diff --git a/yesod-bin/Build.hs b/yesod-bin/Build.hs deleted file mode 100644 index aca37e74..00000000 --- a/yesod-bin/Build.hs +++ /dev/null @@ -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 diff --git a/yesod-bin/ChangeLog.md b/yesod-bin/ChangeLog.md index f82a8fbd..04daaf82 100644 --- a/yesod-bin/ChangeLog.md +++ b/yesod-bin/ChangeLog.md @@ -1,6 +1,7 @@ ## 1.6.0 * Upgrade to conduit 1.3.0 +* Remove configure, build, touch, and test commands ## 1.5.3 diff --git a/yesod-bin/Devel.hs b/yesod-bin/Devel.hs index c60b17d6..4daa9cca 100644 --- a/yesod-bin/Devel.hs +++ b/yesod-bin/Devel.hs @@ -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) diff --git a/yesod-bin/main.hs b/yesod-bin/main.hs index 566f8cf9..3f3a071b 100755 --- a/yesod-bin/main.hs +++ b/yesod-bin/main.hs @@ -2,37 +2,18 @@ {-# LANGUAGE RecordWildCards #-} module Main (main) where -import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) import Options.Applicative -import System.Environment (getEnvironment) -import System.Exit (ExitCode (ExitSuccess), exitWith, exitFailure) -import System.Process (rawSystem) +import System.Exit (exitFailure) import AddHandler (addHandler) import Devel (DevelOpts (..), devel, develSignal) import Keter (keter) import Options (injectDefaults) import qualified Paths_yesod_bin -import System.IO (hPutStrLn, stderr) import HsFile (mkHsFile) -#ifndef WINDOWS -import Build (touch) - -touch' :: IO () -touch' = touch - -windowsWarning :: String -windowsWarning = "" -#else -touch' :: IO () -touch' = return () - -windowsWarning :: String -windowsWarning = " (does not work on Windows)" -#endif data CabalPgm = Cabal | CabalDev deriving (Show, Eq) @@ -91,17 +72,16 @@ main = do c -> c }) ] optParser' - let cabal = rawSystem' (cabalCommand o) case optCommand o of Init _ -> initErrorMsg HsFiles -> mkHsFile - Configure -> cabal ["configure"] - Build es -> touch' >> cabal ("build":es) - Touch -> touch' + Configure -> cabalErrorMsg + Build _ -> cabalErrorMsg + Touch -> cabalErrorMsg Keter{..} -> keter (cabalCommand o) _keterNoRebuild _keterNoCopyTo _keterBuildArgs Version -> putStrLn ("yesod-bin version: " ++ showVersion Paths_yesod_bin.version) AddHandler{..} -> addHandler addHandlerRoute addHandlerPattern addHandlerMethods - Test -> cabalTest cabal + Test -> cabalErrorMsg Devel{..} -> devel DevelOpts { verbose = optVerbose o , successHook = develSuccessHook @@ -113,19 +93,6 @@ main = do } develExtraArgs DevelSignal -> develSignal where - cabalTest cabal = do - env <- getEnvironment - case lookup "STACK_EXE" env of - Nothing -> do - touch' - _ <- cabal ["configure", "--enable-tests", "-flibrary-only"] - _ <- cabal ["build"] - cabal ["test"] - Just _ -> do - hPutStrLn stderr "'yesod test' is no longer needed with Stack" - hPutStrLn stderr "Instead, please just run 'stack test'" - exitFailure - initErrorMsg = do mapM_ putStrLn [ "The init command has been removed." @@ -136,6 +103,13 @@ main = do ] exitFailure + cabalErrorMsg = do + mapM_ putStrLn + [ "The configure, build, touch, and test commands have been removed." + , "Please use 'stack' for building your project." + ] + exitFailure + optParser' :: ParserInfo Options optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) @@ -148,17 +122,17 @@ optParser = Options <> command "hsfiles" (info (pure HsFiles) (progDesc "Create a hsfiles file for the current folder")) <> command "configure" (info (pure Configure) - (progDesc "Configure a project for building")) + (progDesc "DEPRECATED")) <> command "build" (info (helper <*> (Build <$> extraCabalArgs)) - (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "touch" (info (pure Touch) - (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) + (progDesc "DEPRECATED")) <> command "devel" (info (helper <*> develOptions) (progDesc "Run project with the devel server")) <> command "devel-signal" (info (helper <*> pure DevelSignal) (progDesc "Used internally by the devel command")) <> command "test" (info (pure Test) - (progDesc "Build and run the integration tests")) + (progDesc "DEPRECATED")) <> command "add-handler" (info (helper <*> addHandlerOptions) (progDesc ("Add a new handler and module to the project." ++ " Interactively asks for input if you do not specify arguments."))) @@ -217,10 +191,3 @@ addHandlerOptions = AddHandler -- | Optional @String@ argument optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr m = option (Just <$> str) $ value Nothing <> m - --- | Like @rawSystem@, but exits if it receives a non-success result. -rawSystem' :: String -> [String] -> IO () -rawSystem' x y = do - res <- rawSystem x y - unless (res == ExitSuccess) $ exitWith res - diff --git a/yesod-bin/yesod-bin.cabal b/yesod-bin/yesod-bin.cabal index df153e75..f1333a39 100644 --- a/yesod-bin/yesod-bin.cabal +++ b/yesod-bin/yesod-bin.cabal @@ -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 diff --git a/yesod-test/Yesod/Test.hs b/yesod-test/Yesod/Test.hs index 307619cc..b15dab4b 100644 --- a/yesod-test/Yesod/Test.hs +++ b/yesod-test/Yesod/Test.hs @@ -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 diff --git a/yesod-test/test/main.hs b/yesod-test/test/main.hs index e6756d7d..a08c102a 100644 --- a/yesod-test/test/main.hs +++ b/yesod-test/test/main.hs @@ -37,7 +37,7 @@ import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) -import Control.Exception.Lifted(SomeException, try) +import UnliftIO.Exception (SomeException, try) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery diff --git a/yesod-test/yesod-test.cabal b/yesod-test/yesod-test.cabal index 6585217c..3c930575 100644 --- a/yesod-test/yesod-test.cabal +++ b/yesod-test/yesod-test.cabal @@ -61,6 +61,7 @@ test-suite test , text , wai , http-types + , unliftio source-repository head type: git