Further transformer cleanup

stack.yaml

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

yesod-auth-oauth/Yesod/Auth/OAuth.hs

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

yesod-auth-oauth/yesod-auth-oauth.cabal

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

yesod-auth/Yesod/Auth/BrowserId.hs

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

yesod-auth/Yesod/Auth/OpenId.hs

@@ -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
+                    Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err
-                        loginErrorMessage (tm LoginR) $ T.pack $
-                                show (err :: SomeException)
                     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 $
+        loginErrorMessage (tm LoginR) $ T.pack $ show err
-                show (err :: SomeException)
     onSuccess oir = do
             let claimed =
                     case OpenId.oirClaimed oir of

yesod-auth/Yesod/Auth/Rpxnow.hs

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

yesod-auth/yesod-auth.cabal

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

yesod-bin/Build.hs

@@ -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           UnliftIO.Exception (tryIO, IOException, handleAny, catchAny, tryAny)
-import           Control.Exception.Lifted (handle)
 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)

yesod-bin/Devel.hs

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

yesod-bin/yesod-bin.cabal

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

yesod-test/Yesod/Test.hs

@@ -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)
+              -> (SResponse -> ReaderT (IORef state) m a)
-              -> ST.StateT state m a
+              -> ReaderT (IORef state) m a
-withResponse' getter errTrace f = maybe err f . getter =<< ST.get
+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
+instance YesodDispatch site => Hspec.Example (ReaderT (IORef (YesodExampleData site)) IO a) where
-    type Arg (ST.StateT (YesodExampleData site) IO a) = TestApp site
+    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

yesod-test/test/main.hs

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

yesod-test/yesod-test.cabal

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