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

Further transformer cleanup

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-18 17:06:46 +02:00
parent 8e265f6ebc
commit 1b22e6a908
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
13 changed files with 78 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
stack.yaml
View File

@ -15,3 +15,5 @@ packages:
- ./yesod-websockets
extra-deps:
- unliftio-core-0.1.0.0
- unliftio-0.2.0.0
- ../.stable/authenticate/authenticate

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

@ -15,7 +15,7 @@ module Yesod.Auth.OAuth
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Arrow ((***))
import Control.Exception.Lifted
import Control.Exception (Exception, throwIO)
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.ByteString (ByteString)

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

@ -28,7 +28,6 @@ library
, text >= 0.7
, yesod-form >= 1.4 && < 1.5
, transformers >= 0.2.2 && < 0.6
, lifted-base >= 0.2 && < 0.3
, unliftio-core
exposed-modules: Yesod.Auth.OAuth
ghc-options: -Wall

2
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -78,7 +78,7 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
tm <- getRouteToParent
return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
manager <- authHttpManager
memail <- liftResourceT $ checkAssertion audience assertion manager
memail <- checkAssertion audience assertion manager
case memail of
Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure"

13
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -20,7 +20,7 @@ import Yesod.Form
import Yesod.Core
import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try)
import UnliftIO.Exception (tryAny)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
@ -71,11 +71,9 @@ $newline never
render <- getUrlRender
let complete' = render $ tm complete
manager <- authHttpManager
eres <- liftResourceT $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager
case eres of
Left err -> do
loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err
Right x -> redirect x
Nothing -> loginErrorMessageI LoginR Msg.NoOpenID
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
@ -91,13 +89,12 @@ $newline never
completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent
completeHelper idType gets' = do
manager <- authHttpManager
eres <- liftResourceT $ try $ OpenId.authenticateClaimed gets' manager
eres <- tryAny $ OpenId.authenticateClaimed gets' manager
either onFailure onSuccess eres
where
onFailure err = do
tm <- getRouteToParent
loginErrorMessage (tm LoginR) $ T.pack $
show (err :: SomeException)
loginErrorMessage (tm LoginR) $ T.pack $ show err
onSuccess oir = do
let claimed =
case OpenId.oirClaimed oir of

3
yesod-auth/Yesod/Auth/Rpxnow.hs
View File

@ -42,8 +42,7 @@ $newline never
[] -> invalidArgs ["token: Value not supplied"]
x:_ -> return $ unpack x
manager <- authHttpManager
Rpxnow.Identifier ident extra <-
liftResourceT $ Rpxnow.authenticate apiKey token manager
Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager
let creds =
Creds "rpxnow" ident
$ maybe id (\x -> (:) ("verifiedEmail", x))

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

@ -21,7 +21,7 @@ flag network-uri
library
build-depends: base >= 4 && < 5
, authenticate >= 1.3
, authenticate >= 1.3.4
, bytestring >= 0.9.1.4
, yesod-core >= 1.4.31 && < 1.5
, wai >= 1.4
@ -44,7 +44,6 @@ library
, http-client-tls
, http-conduit >= 2.1
, aeson >= 0.7
, lifted-base >= 0.1
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, http-types
@ -63,6 +62,7 @@ library
, conduit-extra
, nonce >= 1.0.2 && < 1.1
, unliftio-core
, unliftio
if flag(network-uri)
build-depends: network-uri >= 2.6

22
yesod-bin/Build.hs
View File

@ -20,10 +20,9 @@ import Data.Text.Encoding.Error (lenientDecode)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Exception (SomeException, try, IOException)
import Control.Exception.Lifted (handle)
import UnliftIO.Exception (tryIO, IOException, handleAny, catchAny, tryAny)
import Control.Monad (when, filterM, forM, forM_, (>=>))
import Control.Monad.Trans.State (StateT, get, put, execStateT)
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)
@ -45,11 +44,11 @@ import Text.Cassius (cassiusUsedIdentifiers)
import Text.Lucius (luciusUsedIdentifiers)
safeReadFile :: MonadIO m => FilePath -> m (Either IOException ByteString)
safeReadFile = liftIO . try . S.readFile
safeReadFile = liftIO . tryIO . S.readFile
touch :: IO ()
touch = do
m <- handle (\(_ :: SomeException) -> return Map.empty) $ readFile touchCache >>= readIO
m <- handleAny (\_ -> return Map.empty) $ readFile touchCache >>= readIO
x <- fmap snd (getDeps [])
m' <- execStateT (execWriterT $ touchDeps id updateFileTime x) m
createDirectoryIfMissing True $ takeDirectory touchCache
@ -87,8 +86,10 @@ touchDeps :: (FilePath -> FilePath) ->
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 <- handle (\(_ :: SomeException) -> return True) $ lift $
isChanged <- lift $ ignoreStateEx True $
case ct of
AlwaysOutdated -> return True
CompareUsedIdentifiers getDerefs -> do
@ -113,7 +114,7 @@ touchDeps f action deps = (mapM_ go . Map.toList) deps
removeHi :: FilePath -> FilePath -> IO ()
removeHi _ hs = mapM_ removeFile' hiFiles
where
removeFile' file = try' (removeFile file) >> return ()
removeFile' file = tryAny (removeFile file) >> return ()
hiFiles = map (\e -> "dist/build" </> removeSrc (replaceExtension hs e))
["hi", "p_hi"]
@ -122,7 +123,7 @@ updateFileTime :: FilePath -> FilePath -> IO ()
updateFileTime x hs = do
(_ , modx) <- getFileStatus' x
(access, _ ) <- getFileStatus' hs
_ <- try' (setFileTimes hs access modx)
_ <- tryAny (setFileTimes hs access modx)
return ()
hiFile :: FilePath -> FilePath
@ -133,9 +134,6 @@ 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
@ -145,7 +143,7 @@ isNewerThan f1 f2 = do
getFileStatus' :: FilePath ->
IO (System.Posix.Types.EpochTime, System.Posix.Types.EpochTime)
getFileStatus' fp = do
efs <- try' $ getFileStatus fp
efs <- tryAny $ getFileStatus fp
case efs of
Left _ -> return (0, 0)
Right fs -> return (accessTime fs, modificationTime fs)

2
yesod-bin/Devel.hs
View File

@ -12,7 +12,7 @@ import Control.Applicative ((<|>))
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)

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

@ -52,13 +52,12 @@ executable yesod
, conduit-extra
, resourcet >= 0.3 && < 1.2
, base64-bytestring
, lifted-base
, http-reverse-proxy >= 0.4
, network >= 2.5
, http-client-tls
, http-client >= 0.4.7
, project-template >= 0.1.1
, safe-exceptions
, unliftio
, say
, stm
, transformers

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

@ -133,7 +133,7 @@ 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 (ReaderT (..))
import Control.Monad.IO.Class
import System.IO
import Yesod.Core.Unsafe (runFakeHandler)
@ -145,6 +145,7 @@ import Text.XML.Cursor hiding (element)
import qualified Text.XML.Cursor as C
import qualified Text.HTML.DOM as HD
import Control.Monad.Trans.Writer
import Data.IORef
import qualified Data.Map as M
import qualified Web.Cookie as Cookie
import qualified Blaze.ByteString.Builder as Builder
@ -176,7 +177,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.
--
@ -199,13 +200,13 @@ data YesodSpecTree site
--
-- Since 1.2.0
getTestYesod :: YesodExample site site
getTestYesod = fmap yedSite ST.get
getTestYesod = fmap yedSite getState
-- | 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 getState
data RequestBuilderData site = RequestBuilderData
{ rbdPostData :: RBDPostData
@ -228,7 +229,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'
@ -245,7 +246,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
evalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -265,7 +266,7 @@ yesodSpecWithSiteGenerator getSiteAction yspecs =
unYesod getSiteAction' (YesodSpecItem x y) = Hspec.specItem x $ do
site <- getSiteAction'
app <- toWaiAppPlain site
ST.evalStateT y YesodExampleData
evalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -286,7 +287,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
evalStateT y YesodExampleData
{ yedApp = app
, yedSite = site
, yedCookies = M.empty
@ -302,9 +303,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 =<< getState
where err = failure msg
msg = if null errTrace
then "There was no response, you should make a request."
@ -327,7 +328,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)
@ -492,14 +493,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)) }
modifyState $ \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 = modifyState $ \rbd -> rbd
{ rbdGets = (TE.encodeUtf8 name, Just $ TE.encodeUtf8 value)
: rbdGets rbd
}
@ -518,7 +519,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) }
modifyState $ \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
@ -526,7 +527,7 @@ addFile name path mimetype = do
-- This looks up the name of a field based on the contents of the label pointing to it.
nameFromLabel :: T.Text -> RequestBuilder site T.Text
nameFromLabel label = do
mres <- fmap rbdResponse ST.get
mres <- fmap rbdResponse getState
res <-
case mres of
Nothing -> failure "nameFromLabel: No response available"
@ -703,7 +704,7 @@ addTokenFromCookieNamedToHeaderNamed cookieName headerName = do
-- Since 1.4.3.2
getRequestCookies :: RequestBuilder site Cookies
getRequestCookies = do
requestBuilderData <- ST.get
requestBuilderData <- getState
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."
@ -811,7 +812,7 @@ getLocation = do
-- > request $ do
-- > setMethod methodPut
setMethod :: H.Method -> RequestBuilder site ()
setMethod m = ST.modify $ \rbd -> rbd { rbdMethod = m }
setMethod m = modifyState $ \rbd -> rbd { rbdMethod = m }
-- | Sets the URL used by the request.
--
@ -826,7 +827,7 @@ setUrl :: (Yesod site, RedirectUrl site url)
=> url
-> RequestBuilder site ()
setUrl url' = do
site <- fmap rbdSite ST.get
site <- fmap rbdSite getState
eurl <- Yesod.Core.Unsafe.runFakeHandler
M.empty
(const $ error "Yesod.Test: No logger available")
@ -834,7 +835,7 @@ setUrl url' = do
(toTextUrl url')
url <- either (error . show) return eurl
let (urlPath, urlQuery) = T.break (== '?') url
ST.modify $ \rbd -> rbd
modifyState $ \rbd -> rbd
{ rbdPath =
case DL.filter (/="") $ H.decodePathSegments $ TE.encodeUtf8 urlPath of
("http:":_:rest) -> rest
@ -873,7 +874,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 = modifyState $ \rbd -> rbd { rbdPostData = BinaryPostData body }
-- | Adds the given header to the request; see "Network.HTTP.Types.Header" for creating 'Header's.
--
@ -883,7 +884,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 = modifyState $ \rbd -> rbd
{ rbdHeaders = header : rbdHeaders rbd
}
@ -903,9 +904,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 <- getState
RequestBuilderData {..} <- liftIO $ ST.execStateT reqBuilder RequestBuilderData
RequestBuilderData {..} <- liftIO $ execStateT reqBuilder RequestBuilderData
{ rbdPostData = MultipleItemsPostData []
, rbdResponse = mRes
, rbdMethod = "GET"
@ -945,7 +946,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)
putState $ YesodExampleData app site cookies' (Just response)
where
isFile (ReqFilePart _ _ _ _) = True
isFile _ = False
@ -1049,14 +1050,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
_ <- evalStateT example YesodExampleData
{ yedApp = middleware app
, yedSite = site
, yedCookies = M.empty
@ -1065,3 +1066,25 @@ instance YesodDispatch site => Hspec.Example (ST.StateT (YesodExampleData site)
return ())
params
($ ())
getState :: MonadIO m => ReaderT (IORef s) m s
getState = ReaderT $ liftIO . readIORef
putState :: MonadIO m => s -> ReaderT (IORef s) m ()
putState x = ReaderT $ \ref -> liftIO $ writeIORef ref $! x
modifyState :: MonadIO m => (s -> s) -> ReaderT (IORef s) m ()
modifyState f = ReaderT $ \ref -> liftIO $ do
x <- readIORef ref
writeIORef ref $! f x
evalStateT :: MonadIO m => ReaderT (IORef s) m a -> s -> m a
evalStateT (ReaderT f) s = do
ref <- liftIO $ 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

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

@ -34,7 +34,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 (tryAny)
parseQuery_ :: Text -> [[SelectorGroup]]
parseQuery_ = either error id . parseQuery
@ -189,7 +189,7 @@ main = hspec $ do
bodyEquals "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>"
get ("/htmlWithLink" :: Text)
(bad :: Either SomeException ()) <- try (clickOn "a#nonexistentlink")
bad <- tryAny (clickOn "a#nonexistentlink")
assertEq "bad link" (isLeft bad) True

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

@ -61,8 +61,8 @@ test-suite test
, yesod-form >= 1.4.14
, text
, wai
, lifted-base
, http-types
, unliftio
source-repository head
type: git