├── .github └── workflows │ └── tests.yml ├── .gitignore ├── LICENSE ├── README.md ├── stack.yaml ├── stack.yaml.lock ├── unliftio-core ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml └── src │ └── Control │ └── Monad │ └── IO │ └── Unlift.hs └── unliftio ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── ConcBench.hs ├── cbits ├── file-posix.c ├── time-osx.c ├── time-posix.c └── time-windows.c ├── package.yaml ├── src ├── UnliftIO.hs └── UnliftIO │ ├── Async.hs │ ├── Chan.hs │ ├── Concurrent.hs │ ├── Directory.hs │ ├── Environment.hs │ ├── Exception.hs │ ├── Exception │ └── Lens.hs │ ├── Foreign.hs │ ├── IO.hs │ ├── IO │ ├── File.hs │ └── File │ │ └── Posix.hs │ ├── IORef.hs │ ├── Internals │ └── Async.hs │ ├── MVar.hs │ ├── Memoize.hs │ ├── Process.hs │ ├── QSem.hs │ ├── QSemN.hs │ ├── STM.hs │ ├── Temporary.hs │ └── Timeout.hs └── test ├── Spec.hs └── UnliftIO ├── AsyncSpec.hs ├── DirectorySpec.hs ├── ExceptionSpec.hs ├── IO └── FileSpec.hs ├── IOSpec.hs ├── MemoizeSpec.hs └── PooledAsyncSpec.hs /.github/workflows/tests.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: 7 | - master 8 | 9 | jobs: 10 | build: 11 | name: CI 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | fail-fast: false 15 | matrix: 16 | os: [ubuntu-latest, macos-latest, windows-latest] 17 | resolver: [nightly, lts-19, lts-18, lts-17, lts-16, lts-14] 18 | 19 | steps: 20 | - name: Clone project 21 | uses: actions/checkout@v2 22 | 23 | # Getting weird OS X errors... 24 | # - name: Cache dependencies 25 | # uses: actions/cache@v1 26 | # with: 27 | # path: ~/.stack 28 | # key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }} 29 | # restore-keys: | 30 | # ${{ runner.os }}-${{ matrix.resolver }}- 31 | 32 | - name: Build and run tests 33 | shell: bash 34 | run: | 35 | set -ex 36 | stack --version 37 | stack test --fast --no-terminal --resolver=${{ matrix.resolver }} 38 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | .HTF/ 21 | tarballs/ 22 | *# 23 | *~ 24 | *.cabal 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | unliftio/LICENSE -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | unliftio/README.md -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.10 2 | packages: 3 | - unliftio 4 | - unliftio-core 5 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 567241 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/10.yaml 11 | sha256: 321b3b9f0c7f76994b39e0dabafdc76478274b4ff74cc5e43d410897a335ad3b 12 | original: lts-17.10 13 | -------------------------------------------------------------------------------- /unliftio-core/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # ChangeLog for unliftio-core 2 | 3 | ## 0.2.1.0 4 | 5 | * Added `Control.Monad.IO.Unlift.liftIOOp` 6 | 7 | ## 0.2.0.2 8 | 9 | * Widen `base` upperbound to `< 4.17` to support ghc-9.2. 10 | 11 | ## 0.2.0.1 12 | 13 | * Remove faulty default implementation of `withRunInIO` [#56](https://github.com/fpco/unliftio/issues/56) 14 | 15 | ## 0.2.0.0 16 | 17 | * Move `askUnliftIO` out of class [#55](https://github.com/fpco/unliftio/issues/55) 18 | 19 | ## 0.1.2.0 20 | 21 | * Add `wrappedWithRunInIO`. 22 | 23 | ## 0.1.1.0 24 | 25 | * Doc improvements. 26 | * Inline functions in `Control.Monad.IO.Unlift` module [#4](https://github.com/fpco/unliftio/pull/4). 27 | * Fully polymorphic `withRunInIO` [#12](https://github.com/fpco/unliftio/pull/12). 28 | * Move `withRunInIO` into the `MonadUnliftIO` typeclass itself[#13](https://github.com/fpco/unliftio/issues/13) 29 | 30 | ## 0.1.0.0 31 | 32 | * Initial release. 33 | -------------------------------------------------------------------------------- /unliftio-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 FP Complete 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /unliftio-core/README.md: -------------------------------------------------------------------------------- 1 | # unliftio-core 2 | 3 | Provides the core `MonadUnliftIO` typeclass, instances for `base` and 4 | `transformers`, and basic utility functions. Typically, you'll want to use the 5 | [unliftio](https://www.stackage.org/package/unliftio) library, which provides 6 | more functionality (and a much better description). 7 | -------------------------------------------------------------------------------- /unliftio-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /unliftio-core/package.yaml: -------------------------------------------------------------------------------- 1 | name: unliftio-core 2 | version: 0.2.1.0 3 | synopsis: The MonadUnliftIO typeclass for unlifting monads to IO 4 | description: Please see the documentation and README at 5 | homepage: https://github.com/fpco/unliftio/tree/master/unliftio-core#readme 6 | license: MIT 7 | author: Michael Snoyman, Francesco Mazzoli 8 | maintainer: michael@snoyman.com 9 | copyright: 2017-2020 FP Complete 10 | category: Control 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | dependencies: 16 | - base >= 4.9 && < 4.19 17 | - transformers >= 0.2 && < 0.7 18 | 19 | library: 20 | source-dirs: 21 | - src 22 | exposed-modules: 23 | - Control.Monad.IO.Unlift 24 | -------------------------------------------------------------------------------- /unliftio-core/src/Control/Monad/IO/Unlift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | Please see the README.md file for information on using this 3 | -- package at . 4 | module Control.Monad.IO.Unlift 5 | ( MonadUnliftIO (..) 6 | , UnliftIO (..) 7 | , askUnliftIO 8 | , askRunInIO 9 | , withUnliftIO 10 | , toIO 11 | , wrappedWithRunInIO 12 | , liftIOOp 13 | , MonadIO (..) 14 | ) where 15 | 16 | import Control.Monad.IO.Class 17 | import Control.Monad.Trans.Reader (ReaderT (..)) 18 | import Control.Monad.Trans.Identity (IdentityT (..)) 19 | 20 | -- | The ability to run any monadic action @m a@ as @IO a@. 21 | -- 22 | -- This is more precisely a natural transformation. We need to new 23 | -- datatype (instead of simply using a @forall@) due to lack of 24 | -- support in GHC for impredicative types. 25 | -- 26 | -- @since 0.1.0.0 27 | newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a } 28 | 29 | -- | Monads which allow their actions to be run in 'IO'. 30 | -- 31 | -- While 'MonadIO' allows an 'IO' action to be lifted into another 32 | -- monad, this class captures the opposite concept: allowing you to 33 | -- capture the monadic context. Note that, in order to meet the laws 34 | -- given below, the intuition is that a monad must have no monadic 35 | -- state, but may have monadic context. This essentially limits 36 | -- 'MonadUnliftIO' to 'ReaderT' and 'IdentityT' transformers on top of 37 | -- 'IO'. 38 | -- 39 | -- Laws. For any function @run@ provided by 'withRunInIO', it must meet the 40 | -- monad transformer laws as reformulated for @MonadUnliftIO@: 41 | -- 42 | -- * @run . return = return@ 43 | -- 44 | -- * @run (m >>= f) = run m >>= run . f@ 45 | -- 46 | -- Instances of @MonadUnliftIO@ must also satisfy the following laws: 47 | -- 48 | -- [Identity law] @withRunInIO (\\run -> run m) = m@ 49 | -- [Inverse law] @withRunInIO (\\_ -> m) = liftIO m@ 50 | -- 51 | -- As an example of an invalid instance, a naive implementation of 52 | -- @MonadUnliftIO (StateT s m)@ might be 53 | -- 54 | -- @ 55 | -- withRunInIO inner = 56 | -- StateT $ \\s -> 57 | -- withRunInIO $ \\run -> 58 | -- inner (run . flip evalStateT s) 59 | -- @ 60 | -- 61 | -- This breaks the identity law because the inner @run m@ would throw away 62 | -- any state changes in @m@. 63 | -- 64 | -- @since 0.1.0.0 65 | class MonadIO m => MonadUnliftIO m where 66 | -- | Convenience function for capturing the monadic context and running an 'IO' 67 | -- action with a runner function. The runner function is used to run a monadic 68 | -- action @m@ in @IO@. 69 | -- 70 | -- @since 0.1.0.0 71 | withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b 72 | 73 | instance MonadUnliftIO IO where 74 | {-# INLINE withRunInIO #-} 75 | withRunInIO inner = inner id 76 | 77 | instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where 78 | {-# INLINE withRunInIO #-} 79 | withRunInIO inner = 80 | ReaderT $ \r -> 81 | withRunInIO $ \run -> 82 | inner (run . flip runReaderT r) 83 | 84 | instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where 85 | {-# INLINE withRunInIO #-} 86 | withRunInIO inner = 87 | IdentityT $ 88 | withRunInIO $ \run -> 89 | inner (run . runIdentityT) 90 | 91 | -- | Capture the current monadic context, providing the ability to 92 | -- run monadic actions in 'IO'. 93 | -- 94 | -- See 'UnliftIO' for an explanation of why we need a helper 95 | -- datatype here. 96 | -- 97 | -- Prior to version 0.2.0.0 of this library, this was a method in the 98 | -- 'MonadUnliftIO' type class. It was moved out due to 99 | -- . 100 | -- 101 | -- @since 0.1.0.0 102 | askUnliftIO :: MonadUnliftIO m => m (UnliftIO m) 103 | askUnliftIO = withRunInIO (\run -> return (UnliftIO run)) 104 | {-# INLINE askUnliftIO #-} 105 | -- Would be better, but GHC hates us 106 | -- askUnliftIO :: m (forall a. m a -> IO a) 107 | 108 | 109 | -- | Same as 'askUnliftIO', but returns a monomorphic function 110 | -- instead of a polymorphic newtype wrapper. If you only need to apply 111 | -- the transformation on one concrete type, this function can be more 112 | -- convenient. 113 | -- 114 | -- @since 0.1.0.0 115 | {-# INLINE askRunInIO #-} 116 | askRunInIO :: MonadUnliftIO m => m (m a -> IO a) 117 | -- withRunInIO return would be nice, but GHC 7.8.4 doesn't like it 118 | askRunInIO = withRunInIO (\run -> (return (\ma -> run ma))) 119 | 120 | -- | Convenience function for capturing the monadic context and running 121 | -- an 'IO' action. The 'UnliftIO' newtype wrapper is rarely needed, so 122 | -- prefer 'withRunInIO' to this function. 123 | -- 124 | -- @since 0.1.0.0 125 | {-# INLINE withUnliftIO #-} 126 | withUnliftIO :: MonadUnliftIO m => (UnliftIO m -> IO a) -> m a 127 | withUnliftIO inner = askUnliftIO >>= liftIO . inner 128 | 129 | -- | Convert an action in @m@ to an action in @IO@. 130 | -- 131 | -- @since 0.1.0.0 132 | {-# INLINE toIO #-} 133 | toIO :: MonadUnliftIO m => m a -> m (IO a) 134 | toIO m = withRunInIO $ \run -> return $ run m 135 | 136 | {- | A helper function for implementing @MonadUnliftIO@ instances. 137 | Useful for the common case where you want to simply delegate to the 138 | underlying transformer. 139 | 140 | Note: You can derive 'MonadUnliftIO' for newtypes without this helper function 141 | in @unliftio-core@ 0.2.0.0 and later. 142 | 143 | @since 0.1.2.0 144 | ==== __Example__ 145 | 146 | > newtype AppT m a = AppT { unAppT :: ReaderT Int (ResourceT m) a } 147 | > deriving (Functor, Applicative, Monad, MonadIO) 148 | > 149 | > -- Same as `deriving newtype (MonadUnliftIO)` 150 | > instance MonadUnliftIO m => MonadUnliftIO (AppT m) where 151 | > withRunInIO = wrappedWithRunInIO AppT unAppT 152 | -} 153 | {-# INLINE wrappedWithRunInIO #-} 154 | wrappedWithRunInIO :: MonadUnliftIO n 155 | => (n b -> m b) 156 | -- ^ The wrapper, for instance @IdentityT@. 157 | -> (forall a. m a -> n a) 158 | -- ^ The inverse, for instance @runIdentityT@. 159 | -> ((forall a. m a -> IO a) -> IO b) 160 | -- ^ The actual function to invoke 'withRunInIO' with. 161 | -> m b 162 | wrappedWithRunInIO wrap unwrap inner = wrap $ withRunInIO $ \run -> 163 | inner $ run . unwrap 164 | 165 | {- | A helper function for lifting @IO a -> IO b@ functions into any @MonadUnliftIO@. 166 | 167 | === __Example__ 168 | 169 | > liftedTry :: (Exception e, MonadUnliftIO m) => m a -> m (Either e a) 170 | > liftedTry m = liftIOOp Control.Exception.try m 171 | 172 | @since 0.2.1.0 173 | -} 174 | liftIOOp :: MonadUnliftIO m => (IO a -> IO b) -> m a -> m b 175 | liftIOOp f x = do 176 | runInIO <- askRunInIO 177 | liftIO $ f $ runInIO x 178 | -------------------------------------------------------------------------------- /unliftio/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for unliftio 2 | 3 | ## 0.2.25.1 4 | 5 | * Forward compatibility with `-Wnoncanonical-monoid-instances` becoming an error 6 | 7 | ## 0.2.25.0 8 | 9 | * Add `UnliftIO.Exception.Lens` 10 | 11 | ## 0.2.24.0 12 | 13 | * Add `UnliftIO.STM.writeTMVar` 14 | * Add `UnliftIO.STM.stateTVar` 15 | 16 | ## 0.2.23.0 17 | 18 | * `UnliftIO.Exception` re-exports the `Handler` and sync/async exception wrappers 19 | from `safe-exceptions`, instead of redefining them. 20 | * With this change, you won't be able to distinguish between an asynchronous 21 | exception from `UnliftIO.Exception.throwTo` and `Control.Exception.Safe.throwTo`. 22 | * [#103](https://github.com/fpco/unliftio/pull/103) 23 | 24 | ## 0.2.22.0 25 | 26 | * Add `UnliftIO.STM.flushTBQueue` 27 | * Add `UnliftIO.STM.lengthTBQueue` 28 | 29 | ## 0.2.21.0 30 | 31 | * Add `UnliftIO.Directory.createDirectoryLink` 32 | * Add `UnliftIO.Directory.removeDirectoryLink` 33 | * Add `UnliftIO.Directory.getSymbolicLinkTarget` 34 | * Add `UnliftIO.Directory.XdgDirectoryList` 35 | * Add `UnliftIO.Directory.getXdgDirectoryList` 36 | 37 | ## 0.2.20.1 38 | 39 | * Fix time-osx.c for aarch64 mac [#91](https://github.com/fpco/unliftio/pull/91) 40 | 41 | ## 0.2.20 42 | 43 | * Add lifted `System.IO.openFile` (https://github.com/fpco/unliftio/pull/88) 44 | 45 | ## 0.2.19 46 | 47 | * Add `Eq` instance for `StringException` (https://github.com/fpco/unliftio/pull/83) 48 | 49 | ## 0.2.18 50 | 51 | * Reexport `asyncExceptionFromException` and `asyncExceptionToException` [#81](https://github.com/fpco/unliftio/issues/81) 52 | 53 | ## 0.2.17 54 | 55 | * Re-export `AsyncCancelled` in `UnliftIO.Async` [#80](https://github.com/fpco/unliftio/pull/80) 56 | * Add `fromExceptionUnwrap` [#80](https://github.com/fpco/unliftio/pull/80) 57 | * Add `catchSyncOrAsync`, `handleSyncOrAsync`, and `trySyncOrAsync` [#80](https://github.com/fpco/unliftio/pull/80) 58 | 59 | ## 0.2.16 60 | 61 | * Add `createFileLink` 62 | 63 | ## 0.2.15 64 | 65 | * Updated documentation mentioning that `MonadUnliftIO` may be derived using 66 | the `newtype` strategy [#72](https://github.com/fpco/unliftio/pull/72) 67 | * Add `mapExceptionM` [#75](https://github.com/fpco/unliftio/pull/75) 68 | 69 | ## 0.2.14 70 | 71 | * Add `UnliftIO.QSem` 72 | * Add `UnliftIO.QSemN` 73 | 74 | ## 0.2.13.1 75 | 76 | * Improve `UnliftIO.Exception` documentation 77 | 78 | ## 0.2.13 79 | 80 | * Add `UnliftIO.STM.orElse` 81 | * Re-export all of `SeekMode` 82 | 83 | ## 0.2.12.1 84 | 85 | * Minor doc improvements 86 | 87 | ## 0.2.12 88 | 89 | * Dropped support for ghc-7.8 90 | * Addition of `UnliftIO.IO.File` module and atomic+durable file writes: 91 | 92 | * `writeBinaryFile` 93 | * `writeBinaryFileAtomic` 94 | * `writeBinaryFileDurable` 95 | * `writeBinaryFileDurableAtomic` 96 | * `withBinaryFileAtomic` 97 | * `withBinaryFileDurable` 98 | * `withBinaryFileDurableAtomic` 99 | * `ensureFileDurable` 100 | 101 | ## 0.2.11 102 | 103 | * Deprecate `forkWithUnmask` in favor of the newly added `forkIOWithUnmask` to 104 | improve consistency. [https://github.com/fpco/unliftio/issues/44] 105 | 106 | ## 0.2.10 107 | 108 | * Add pooling related functions for unliftio 109 | 110 | ## 0.2.9.0 111 | 112 | * Add the new `Conc` datatype as a more efficient alternative to `Concurrently` 113 | 114 | ## 0.2.8.1 115 | 116 | * Support for `stm-2.5.0.0` 117 | 118 | ## 0.2.8.0 119 | 120 | * Add 'UnliftIO.Memoize' 121 | 122 | ## 0.2.7.1 123 | 124 | * Minor doc improvements 125 | 126 | ## 0.2.7.0 127 | 128 | * Re-export `tryPutTMVar` from `UnliftIO.STM` 129 | 130 | ## 0.2.6.0 131 | 132 | * Add `UnliftIO.Directory` 133 | 134 | ## 0.2.5.0 135 | 136 | * Add `UnliftIO.Environment`/`UnliftIO.Foreign`/`UnliftIO.Process` 137 | 138 | ## 0.2.4.0 139 | 140 | * Use more generalized `withRunInIO` in `unliftio-core-0.1.1.0` 141 | * Add `getMonotonicTime` function 142 | 143 | ## 0.2.2.0 144 | 145 | * Add `pureTry` and `pureTryDeep` 146 | 147 | ## 0.2.1.0 148 | 149 | * Add `UnliftIO.STM` 150 | * Add a number of functions to `UnliftIO.IO` 151 | 152 | ## 0.2.0.0 153 | 154 | * Remove `monad-logger` instances (moved into `monad-logger` itself in 155 | release `0.3.26`) 156 | * Remove `resourcet` instances and `UnliftIO.Resource` (moved into `resourcet` 157 | itself in release `1.1.10`) 158 | 159 | ## 0.1.1.0 160 | 161 | * Doc improvements. 162 | * Fix `UnliftIO.Chan` type signatures [#3](https://github.com/fpco/unliftio/pull/3). 163 | * Add `UnliftIO.Concurrent` module [#5](https://github.com/fpco/unliftio/pull/5). 164 | 165 | ## 0.1.0.0 166 | 167 | * Initial release. 168 | -------------------------------------------------------------------------------- /unliftio/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 FP Complete 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /unliftio/README.md: -------------------------------------------------------------------------------- 1 | # unliftio 2 | 3 | ![Tests](https://github.com/fpco/unliftio/workflows/Tests/badge.svg) 4 | 5 | 6 | Provides the core `MonadUnliftIO` typeclass, a number of common 7 | instances, and a collection of common functions working with it. Not 8 | sure what the `MonadUnliftIO` typeclass is all about? Read on! 9 | 10 | __NOTE__ The `UnliftIO.Exception` module in this library changes the semantics of asynchronous exceptions to be in the style of the `safe-exceptions` package, which is orthogonal to the "unlifting" concept. While this change is an improvment in most cases, it means that `UnliftIO.Exception` is not always a drop-in replacement for `Control.Exception` in advanced exception handling code. See [Async exception safety](#async-exception-safety) for details. 11 | 12 | ## Quickstart 13 | 14 | * Replace imports like `Control.Exception` with 15 | `UnliftIO.Exception`. Yay, your `catch` and `finally` are more 16 | powerful and safer (see [Async exception safety](#async-exception-safety))! 17 | * Similar with `Control.Concurrent.Async` with `UnliftIO.Async` 18 | * Or go all in and import `UnliftIO` 19 | * Naming conflicts: let `unliftio` win 20 | * Drop the deps on `monad-control`, `lifted-base`, and `exceptions` 21 | * Compilation failures? You may have just avoided subtle runtime bugs 22 | 23 | Sounds like magic? It's not. Keep reading! 24 | 25 | ## Unlifting in 2 minutes 26 | 27 | Let's say I have a function: 28 | 29 | ```haskell 30 | readFile :: FilePath -> IO ByteString 31 | ``` 32 | 33 | But I'm writing code inside a function that uses `ReaderT Env IO`, not 34 | just plain `IO`. How can I call my `readFile` function in that 35 | context? One way is to manually unwrap the `ReaderT` data constructor: 36 | 37 | ```haskell 38 | myReadFile :: FilePath -> ReaderT Env IO ByteString 39 | myReadFile fp = ReaderT $ \_env -> readFile fp 40 | ``` 41 | 42 | But having to do this regularly is tedious, and ties our code to a 43 | specific monad transformer stack. Instead, many of us would use 44 | `MonadIO`: 45 | 46 | ```haskell 47 | myReadFile :: MonadIO m => FilePath -> m ByteString 48 | myReadFile = liftIO . readFile 49 | ``` 50 | 51 | But now let's play with a different function: 52 | 53 | ```haskell 54 | withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a 55 | ``` 56 | 57 | We want a function with signature: 58 | 59 | ```haskell 60 | myWithBinaryFile 61 | :: FilePath 62 | -> IOMode 63 | -> (Handle -> ReaderT Env IO a) 64 | -> ReaderT Env IO a 65 | ``` 66 | 67 | If I squint hard enough, I can accomplish this directly with the 68 | `ReaderT` constructor via: 69 | 70 | ```haskell 71 | myWithBinaryFile fp mode inner = 72 | ReaderT $ \env -> withBinaryFile 73 | fp 74 | mode 75 | (\h -> runReaderT (inner h) env) 76 | ``` 77 | 78 | I dare you to try and accomplish this with `MonadIO` and 79 | `liftIO`. It simply can't be done. (If you're looking for the 80 | technical reason, it's because `IO` appears in 81 | [negative/argument position](https://www.fpcomplete.com/blog/2016/11/covariance-contravariance) 82 | in `withBinaryFile`.) 83 | 84 | However, with `MonadUnliftIO`, this is possible: 85 | 86 | ```haskell 87 | import Control.Monad.IO.Unlift 88 | 89 | myWithBinaryFile 90 | :: MonadUnliftIO m 91 | => FilePath 92 | -> IOMode 93 | -> (Handle -> m a) 94 | -> m a 95 | myWithBinaryFile fp mode inner = 96 | withRunInIO $ \runInIO -> 97 | withBinaryFile 98 | fp 99 | mode 100 | (\h -> runInIO (inner h)) 101 | ``` 102 | 103 | That's it, you now know the entire basis of this library. 104 | 105 | ## How common is this problem? 106 | 107 | This pops up in a number of places. Some examples: 108 | 109 | * Proper exception handling, with functions like `bracket`, `catch`, 110 | and `finally` 111 | * Working with `MVar`s via `modifyMVar` and similar 112 | * Using the `timeout` function 113 | * Installing callback handlers (e.g., do you want to do 114 | [logging](https://www.stackage.org/package/monad-logger) in a signal 115 | handler?). 116 | 117 | This also pops up when working with libraries which are monomorphic on 118 | `IO`, even if they could be written more extensibly. 119 | 120 | ## Examples 121 | 122 | Reading through the codebase here is likely the best example to see 123 | how to use `MonadUnliftIO` in practice. And for many cases, you can 124 | simply add the `MonadUnliftIO` constraint and then use the 125 | pre-unlifted versions of functions (like 126 | `UnliftIO.Exception.catch`). But ultimately, you'll probably want to 127 | use the typeclass directly. The type class has only one method -- 128 | `withRunInIO`: 129 | 130 | ```haskell 131 | class MonadIO m => MonadUnliftIO m where 132 | withRunInIO :: ((forall a. m a -> IO a) -> IO b) -> m b 133 | ``` 134 | 135 | `withRunInIO` provides a function to run arbitrary computations in `m` 136 | in `IO`. Thus the "unlift": it's like `liftIO`, but the other way around. 137 | 138 | Here are some sample typeclass instances: 139 | 140 | ```haskell 141 | instance MonadUnliftIO IO where 142 | withRunInIO inner = inner id 143 | 144 | instance MonadUnliftIO m => MonadUnliftIO (ReaderT r m) where 145 | withRunInIO inner = 146 | ReaderT $ \r -> 147 | withRunInIO $ \run -> 148 | inner (run . flip runReaderT r) 149 | 150 | instance MonadUnliftIO m => MonadUnliftIO (IdentityT m) where 151 | withRunInIO inner = 152 | IdentityT $ 153 | withRunInIO $ \run -> 154 | inner (run . runIdentityT) 155 | ``` 156 | 157 | Note that: 158 | 159 | * The `IO` instance does not actually do any lifting or unlifting, and 160 | therefore it can use `id` 161 | * `IdentityT` is essentially just wrapping/unwrapping its data 162 | constructor, and then recursively calling `withRunInIO` on the 163 | underlying monad. 164 | * `ReaderT` is just like `IdentityT`, but it captures the reader 165 | environment when starting. 166 | 167 | We can use `withRunInIO` to unlift a function: 168 | 169 | ```haskell 170 | timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a) 171 | timeout x y = withRunInIO $ \run -> System.Timeout.timeout x $ run y 172 | ``` 173 | 174 | This is a common pattern: use `withRunInIO` to capture a run function, 175 | and then call the original function with the user-supplied arguments, 176 | applying `run` as necessary. `withRunInIO` takes care of invoking 177 | `unliftIO` for us. 178 | 179 | We can also use the run function with different types due to 180 | `withRunInIO` being higher-rank polymorphic: 181 | 182 | ```haskell 183 | race :: MonadUnliftIO m => m a -> m b -> m (Either a b) 184 | race a b = withRunInIO $ \run -> A.race (run a) (run b) 185 | ``` 186 | 187 | And finally, a more complex usage, when unlifting the `mask` 188 | function. This function needs to unlift values to be passed into the 189 | `restore` function, and then `liftIO` the result of the `restore` 190 | function. 191 | 192 | ```haskell 193 | mask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b 194 | mask f = withRunInIO $ \run -> Control.Exception.mask $ \restore -> 195 | run $ f $ liftIO . restore . run 196 | ``` 197 | 198 | ## Limitations 199 | 200 | Not all monads which can be an instance of `MonadIO` can be instances 201 | of `MonadUnliftIO`, due to the `MonadUnliftIO` laws (described in the 202 | Haddocks for the typeclass). This prevents instances for a number of 203 | classes of transformers: 204 | 205 | * Transformers using continuations (e.g., `ContT`, `ConduitM`, `Pipe`) 206 | * Transformers with some monadic state (e.g., `StateT`, `WriterT`) 207 | * Transformers with multiple exit points (e.g., `ExceptT` and its ilk) 208 | 209 | In fact, there are two specific classes of transformers that this 210 | approach does work for: 211 | 212 | * Transformers with no context at all (e.g., `IdentityT`, `NoLoggingT`) 213 | * Transformers with a context but no state (e.g., `ReaderT`, `LoggingT`) 214 | 215 | This may sound restrictive, but this restriction is fully 216 | intentional. Trying to unlift actions in stateful monads leads to 217 | unpredictable behavior. For a long and exhaustive example of this, see 218 | [A Tale of Two Brackets](https://www.fpcomplete.com/blog/2017/06/tale-of-two-brackets), 219 | which was a large motivation for writing this library. 220 | 221 | ## Comparison to other approaches 222 | 223 | You may be thinking "Haven't I seen a way to do `catch` in `StateT`?" 224 | You almost certainly have. Let's compare this approach with 225 | alternatives. (For an older but more thorough rundown of the options, 226 | see 227 | [Exceptions and monad transformers](http://www.yesodweb.com/blog/2014/06/exceptions-transformers).) 228 | 229 | There are really two approaches to this problem: 230 | 231 | * Use a set of typeclasses for the specific functionality we care 232 | about. This is the approach taken by the `exceptions` package with 233 | `MonadThrow`, `MonadCatch`, and `MonadMask`. (Earlier approaches 234 | include `MonadCatchIO-mtl` and `MonadCatchIO-transformers`.) 235 | * Define a generic typeclass that allows any control structure to be 236 | unlifted. This is the approach taken by the `monad-control` 237 | package. (Earlier approaches include `monad-peel` and `neither`.) 238 | 239 | The first style gives extra functionality in allowing instances that 240 | have nothing to do with runtime exceptions (e.g., a `MonadCatch` 241 | instance for `Either`). This is arguably a good thing. The second 242 | style gives extra functionality in allowing more operations to be 243 | unlifted (like threading primitives, not supported by the `exceptions` 244 | package). 245 | 246 | Another distinction within the generic typeclass family is whether we 247 | unlift to just `IO`, or to arbitrary base monads. For those familiar, 248 | this is the distinction between the `MonadIO` and `MonadBase` 249 | typeclasses. 250 | 251 | This package's main objection to all of the above approaches is that 252 | they work for too many monads, and provide difficult-to-predict 253 | behavior for a number of them (arguably: plain wrong behavior). For 254 | example, in `lifted-base` (built on top of `monad-control`), the 255 | `finally` operation will discard mutated state coming from the cleanup 256 | action, which is usually not what people expect. `exceptions` has 257 | _different_ behavior here, which is arguably better. But we're arguing 258 | here that we should disallow all such ambiguity at the type level. 259 | 260 | So comparing to other approaches: 261 | 262 | ### monad-unlift 263 | 264 | Throwing this one out there now: the `monad-unlift` library is built 265 | on top of `monad-control`, and uses fairly sophisticated type level 266 | features to restrict it to only the safe subset of monads. The same 267 | approach is taken by `Control.Concurrent.Async.Lifted.Safe` in the 268 | `lifted-async` package. Two problems with this: 269 | 270 | * The complicated type level functionality can confuse GHC in some 271 | cases, making it difficult to get code to compile. 272 | * We don't have an ecosystem of functions like `lifted-base` built on 273 | top of it, making it likely people will revert to the less safe 274 | cousin functions. 275 | 276 | ### monad-control 277 | 278 | The main contention until now is that unlifting in a transformer like 279 | `StateT` is unsafe. This is not universally true: if only one action 280 | is being unlifted, no ambiguity exists. So, for example, `try :: IO a 281 | -> IO (Either e a)` can safely be unlifted in `StateT`, while `finally 282 | :: IO a -> IO b -> IO a` cannot. 283 | 284 | `monad-control` allows us to unlift both styles. In theory, we could 285 | write a variant of `lifted-base` that never does state discards, and 286 | let `try` be more general than `finally`. In other words, this is an 287 | advantage of `monad-control` over `MonadUnliftIO`. We've avoided 288 | providing any such extra typeclass in this package though, for two 289 | reasons: 290 | 291 | * `MonadUnliftIO` is a simple typeclass, easy to explain. We don't 292 | want to complicated matters (`MonadBaseControl` is a notoriously 293 | difficult to understand typeclass). This simplicity 294 | is captured by the laws for `MonadUnliftIO`, which make the 295 | behavior of the run functions close to that of the already familiar 296 | `lift` and `liftIO`. 297 | * Having this kind of split would be confusing in user code, when 298 | suddenly `finally` is not available to us. We would rather encourage 299 | [good practices](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern) 300 | from the beginning. 301 | 302 | Another distinction is that `monad-control` uses the `MonadBase` 303 | style, allowing unlifting to arbitrary base monads. In this package, 304 | we've elected to go with `MonadIO` style. This limits what we can do 305 | (e.g., no unlifting to `STM`), but we went this way because: 306 | 307 | * In practice, we've found that the vast majority of cases are dealing 308 | with `IO` 309 | * The split in the ecosystem between constraints like `MonadBase IO` 310 | and `MonadIO` leads to significant confusion, and `MonadIO` is by 311 | far the more common constraints (with the typeclass existing in 312 | `base`) 313 | 314 | ### exceptions 315 | 316 | One thing we lose by leaving the `exceptions` approach is the ability 317 | to model both pure and side-effecting (via `IO`) monads with a single 318 | paradigm. For example, it can be pretty convenient to have 319 | `MonadThrow` constraints for parsing functions, which will either 320 | return an `Either` value or throw a runtime exception. That said, 321 | there are detractors of that approach: 322 | 323 | * You lose type information about which exception was thrown 324 | * There is ambiguity about _how_ the exception was returned in a 325 | constraint like `(MonadIO m, MonadThrow m`) 326 | 327 | The latter could be addressed by defining a law such as `throwM = 328 | liftIO . throwIO`. However, we've decided in this library to go the 329 | route of encouraging `Either` return values for pure functions, and 330 | using runtime exceptions in `IO` otherwise. (You're of course free to 331 | also return `IO (Either e a)`.) 332 | 333 | By losing `MonadCatch`, we lose the ability to define a generic way to 334 | catch exceptions in continuation based monads (such as 335 | `ConduitM`). Our argument here is that those monads can freely provide 336 | their own catching functions. And in practice, long before the 337 | `MonadCatch` typeclass existed, `conduit` provided a `catchC` 338 | function. 339 | 340 | In exchange for the `MonadThrow` typeclass, we provide helper 341 | functions to convert `Either` values to runtime exceptions in this 342 | package. And the `MonadMask` typeclass is now replaced fully by 343 | `MonadUnliftIO`, which like the `monad-control` case limits which 344 | monads we can be working with. 345 | 346 | ## Async exception safety 347 | 348 | The [`safe-exceptions`](https://hackage.haskell.org/package/safe-exceptions) 349 | package builds on top of the `exceptions` 350 | package and provides intelligent behavior for dealing with 351 | asynchronous exceptions, a common pitfall. This library provides a set 352 | of exception handling functions with the same async exception behavior 353 | as that library. You can consider this library a drop-in replacement 354 | for `safe-exceptions`. In the future, we may reimplement 355 | `safe-exceptions` to use `MonadUnliftIO` instead of `MonadCatch` and 356 | `MonadMask`. 357 | 358 | ## Package split 359 | 360 | The `unliftio-core` package provides just the typeclass with minimal 361 | dependencies (just `base` and `transformers`). If you're writing a 362 | library, we recommend depending on that package to provide your 363 | instances. The `unliftio` package is a "batteries included" library 364 | providing a plethora of pre-unlifted helper functions. It's a good 365 | choice for importing, or even for use in a custom prelude. 366 | 367 | ## Orphans 368 | 369 | The `unliftio` package currently provides orphan instances for types 370 | from the `resourcet` and `monad-logger` packages. This is not intended 371 | as a long-term solution; once `unliftio` is deemed more stable, the 372 | plan is to move those instances into the respective libraries and 373 | remove the dependency on them here. 374 | 375 | If there are other temporary orphans that should be added, please 376 | bring them up in the issue tracker or send a PR, but we'll need to be 377 | selective about adding dependencies. 378 | 379 | ## Future questions 380 | 381 | * Should we extend the set of functions exposed in `UnliftIO.IO` to include 382 | things like `hSeek`? 383 | * Are there other libraries that deserve to be unlifted here? 384 | -------------------------------------------------------------------------------- /unliftio/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /unliftio/bench/ConcBench.hs: -------------------------------------------------------------------------------- 1 | import Gauge 2 | import Gauge.Main 3 | import Control.Concurrent (threadDelay) 4 | import UnliftIO 5 | import qualified Control.Concurrent.Async as A 6 | import Data.List (foldl') 7 | import Control.Applicative (liftA2, (<|>), empty) 8 | 9 | sizes :: (Int -> [Benchmark]) -> [Benchmark] 10 | sizes f = map 11 | (\size -> bgroup (show size) (f size)) 12 | [1, 2, 10, 100, 1000, 10000, 100000] 13 | 14 | sum' :: [Int] -> Int 15 | sum' = foldl' (+) 0 16 | {-# INLINE sum' #-} 17 | 18 | replicateA_ :: Applicative f => Int -> f () -> f () 19 | replicateA_ cnt0 f = 20 | let go 1 = f 21 | go i = f *> go (i - 1) 22 | in go cnt0 23 | {-# INLINE replicateA_ #-} 24 | 25 | main :: IO () 26 | main = defaultMain 27 | [ bgroup "concurrently, minimal work" $ sizes $ \size -> 28 | [ bench "A.replicateConcurrently_" $ whnfIO $ do 29 | ref <- newIORef (0 :: Int) 30 | A.replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ()) 31 | , bench "replicateConcurrently_" $ whnfIO $ do 32 | ref <- newIORef (0 :: Int) 33 | replicateConcurrently_ size $ atomicModifyIORef' ref $ \i -> (i + 1, ()) 34 | , bench "Conc" $ whnfIO $ do 35 | ref <- newIORef (0 :: Int) 36 | runConc $ replicateA_ size $ conc $ atomicModifyIORef' ref $ \i -> (i + 1, ()) 37 | ] 38 | , bgroup "concurrently, no results" $ sizes $ \size -> 39 | [ bench "A.replicateConcurrently_" $ whnfIO $ A.replicateConcurrently_ size (pure ()) 40 | , bench "replicateConcurrently_" $ whnfIO $ replicateConcurrently_ size (pure ()) 41 | , bench "Conc" $ whnfIO $ runConc $ replicateA_ size $ conc $ pure () 42 | , bench "Conc, cheating" $ whnfIO $ runConc $ replicateA_ size $ pure () 43 | ] 44 | , bgroup "concurrently, with results" $ sizes $ \size -> 45 | [ bench "A.mapConcurrently" $ whnfIO $ fmap sum' $ A.mapConcurrently pure [1..size] 46 | , bench "mapConcurrently" $ whnfIO $ fmap sum' $ mapConcurrently pure [1..size] 47 | , bench "Conc" $ whnfIO $ runConc $ 48 | let go i 49 | | i == size = conc (pure i) 50 | | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1)) 51 | in go 1 52 | -- This is cheating, since it's using our Pure data constructor 53 | , bench "Conc, cheating" $ whnfIO $ runConc $ 54 | let go i 55 | | i == size = pure i 56 | | otherwise = liftA2 (+) (pure i) (go (i + 1)) 57 | in go 1 58 | ] 59 | , bgroup "race" $ sizes $ \size -> 60 | [ bench "A.Concurrently" $ whnfIO $ 61 | A.runConcurrently $ 62 | foldr (<|>) empty (replicate size (pure ())) 63 | , bench "Concurrently" $ whnfIO $ 64 | runConcurrently $ 65 | foldr (<|>) empty (replicate size (pure ())) 66 | , bench "Conc" $ whnfIO $ 67 | runConc $ 68 | foldr (<|>) empty (replicate size (conc (pure ()))) 69 | -- This is cheating, since it's using our Pure data constructor 70 | , bench "Conc, cheating" $ whnfIO $ 71 | runConc $ 72 | foldr (<|>) empty (replicate size (pure ())) 73 | ] 74 | , bgroup "race (with result)" $ 75 | sizes $ \size -> 76 | [ bench "Concurrently" $ 77 | whnfIO $ 78 | runConcurrently $ 79 | let go i 80 | | i == size = Concurrently (pure i) 81 | | otherwise = liftA2 (+) (Concurrently (pure i)) (go (i + 1)) 82 | in (Concurrently $ threadDelay maxBound >> return 0) <|> (go 1) <|> 83 | (Concurrently $ threadDelay maxBound >> return 0) 84 | , bench "Conc" $ 85 | whnfIO $ 86 | runConc $ 87 | let go i 88 | | i == size = conc (pure i) 89 | | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1)) 90 | in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|> 91 | (conc $ threadDelay maxBound >> return 0) 92 | , bench "Conc, cheating" $ 93 | whnfIO $ 94 | runConc $ 95 | let go i 96 | | i == size = conc (pure i) 97 | | otherwise = liftA2 (+) (pure i) (go (i + 1)) 98 | in (conc $ threadDelay maxBound >> return 0) <|> (go 1) <|> 99 | (conc $ threadDelay maxBound >> return 0) 100 | ] 101 | , let size = 10 102 | in bgroup 103 | "race (nested)" 104 | [ bench "Concurrently" $ 105 | whnfIO $ 106 | runConcurrently $ 107 | let go i 108 | | i == size = Concurrently (pure i) 109 | | i `mod` 2 == 0 = 110 | (liftA2 (+) (Concurrently (pure i)) (go (i + 1))) <|> 111 | (liftA2 (+) (Concurrently (pure i)) (go (i + 2))) 112 | | otherwise = 113 | liftA2 (+) (Concurrently (pure i)) (go (i + 1)) 114 | in go 1 115 | , bench "Conc" $ 116 | whnfIO $ 117 | runConc $ 118 | let go i 119 | | i == size = conc (pure i) 120 | | i `mod` 2 == 0 = 121 | (liftA2 (+) (conc (pure i)) (go (i + 1))) <|> 122 | (liftA2 (+) (conc (pure i)) (go (i + 2))) 123 | | otherwise = liftA2 (+) (conc (pure i)) (go (i + 1)) 124 | in go 1 125 | , bench "Conc, cheating" $ 126 | whnfIO $ 127 | runConc $ 128 | let go i 129 | | i == size = conc (pure i) 130 | | i `mod` 2 == 0 = 131 | (liftA2 (+) (pure i) (go (i + 1))) <|> 132 | (liftA2 (+) (pure i) (go (i + 2))) 133 | | otherwise = liftA2 (+) (pure i) (go (i + 1)) 134 | in go 1 135 | ] 136 | ] 137 | -------------------------------------------------------------------------------- /unliftio/cbits/file-posix.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | 5 | int unliftio_o_tmpfile( void ) 6 | { 7 | #ifdef __O_TMPFILE 8 | return __O_TMPFILE; 9 | #else 10 | return 0; 11 | #endif 12 | } 13 | 14 | int unliftio_at_fdcwd( void ) 15 | { 16 | return AT_FDCWD; 17 | } 18 | 19 | int unliftio_at_symlink_follow( void ) 20 | { 21 | return AT_SYMLINK_FOLLOW; 22 | } 23 | 24 | 25 | int unliftio_s_irusr( void ) 26 | { 27 | return S_IRUSR; 28 | } 29 | 30 | int unliftio_s_iwusr( void ) 31 | { 32 | return S_IWUSR; 33 | } 34 | 35 | -------------------------------------------------------------------------------- /unliftio/cbits/time-osx.c: -------------------------------------------------------------------------------- 1 | /* From https://github.com/bos/criterion */ 2 | 3 | #include 4 | #include 5 | 6 | void unliftio_inittime(void) 7 | { 8 | } 9 | 10 | double unliftio_gettime(void) 11 | { 12 | return clock_gettime_nsec_np(CLOCK_UPTIME_RAW); 13 | } 14 | -------------------------------------------------------------------------------- /unliftio/cbits/time-posix.c: -------------------------------------------------------------------------------- 1 | /* From https://github.com/bos/criterion */ 2 | 3 | #include 4 | 5 | void unliftio_inittime(void) 6 | { 7 | } 8 | 9 | double unliftio_gettime(void) 10 | { 11 | struct timespec ts; 12 | 13 | clock_gettime(CLOCK_MONOTONIC, &ts); 14 | 15 | return ts.tv_sec + ts.tv_nsec * 1e-9; 16 | } 17 | -------------------------------------------------------------------------------- /unliftio/cbits/time-windows.c: -------------------------------------------------------------------------------- 1 | /* From https://github.com/bos/criterion */ 2 | 3 | /* 4 | * Windows has the most amazingly cretinous time measurement APIs you 5 | * can possibly imagine. 6 | * 7 | * Our first possibility is GetSystemTimeAsFileTime, which updates at 8 | * roughly 60Hz, and is hence worthless - we'd have to run a 9 | * computation for tens or hundreds of seconds to get a trustworthy 10 | * number. 11 | * 12 | * Alternatively, we can use QueryPerformanceCounter, which has 13 | * undefined behaviour under almost all interesting circumstances 14 | * (e.g. multicore systems, CPU frequency changes). But at least it 15 | * increments reasonably often. 16 | */ 17 | 18 | #include 19 | 20 | static double freq_recip; 21 | static LARGE_INTEGER firstClock; 22 | 23 | void unliftio_inittime(void) 24 | { 25 | LARGE_INTEGER freq; 26 | 27 | if (freq_recip == 0) { 28 | QueryPerformanceFrequency(&freq); 29 | QueryPerformanceCounter(&firstClock); 30 | freq_recip = 1.0 / freq.QuadPart; 31 | } 32 | } 33 | 34 | double unliftio_gettime(void) 35 | { 36 | LARGE_INTEGER li; 37 | 38 | QueryPerformanceCounter(&li); 39 | 40 | return ((double) (li.QuadPart - firstClock.QuadPart)) * freq_recip; 41 | } 42 | -------------------------------------------------------------------------------- /unliftio/package.yaml: -------------------------------------------------------------------------------- 1 | name: unliftio 2 | version: 0.2.25.1 3 | synopsis: The MonadUnliftIO typeclass for unlifting monads to IO (batteries included) 4 | description: Please see the documentation and README at 5 | homepage: https://github.com/fpco/unliftio/tree/master/unliftio#readme 6 | license: MIT 7 | author: Michael Snoyman, Francesco Mazzoli 8 | maintainer: michael@snoyman.com 9 | copyright: 2017 FP Complete 10 | category: Control 11 | extra-source-files: 12 | - README.md 13 | - ChangeLog.md 14 | 15 | dependencies: 16 | - base >= 4.9 && < 5 17 | - async > 2.1.1 18 | - bytestring 19 | - deepseq 20 | - directory 21 | - filepath 22 | - process >= 1.2.0.0 23 | - safe-exceptions 24 | - stm >= 2.5 25 | - time 26 | - transformers 27 | - unliftio-core >= 0.1.1.0 28 | 29 | when: 30 | - condition: os(windows) 31 | then: 32 | cpp-options: -DWINDOWS 33 | else: 34 | dependencies: 35 | - unix 36 | 37 | library: 38 | source-dirs: 39 | - src 40 | 41 | ghc-options: 42 | - -fwarn-incomplete-uni-patterns 43 | 44 | when: 45 | - condition: impl(ghc <= 7.10) 46 | dependencies: 47 | - nats 48 | - condition: os(darwin) 49 | then: 50 | c-sources: 51 | - cbits/time-osx.c 52 | - cbits/file-posix.c 53 | other-modules: 54 | - UnliftIO.IO.File.Posix 55 | else: 56 | when: 57 | - condition: os(windows) 58 | then: 59 | c-sources: cbits/time-windows.c 60 | else: 61 | c-sources: 62 | - cbits/file-posix.c 63 | - cbits/time-posix.c 64 | other-modules: 65 | - UnliftIO.IO.File.Posix 66 | 67 | tests: 68 | unliftio-spec: 69 | source-dirs: 70 | - test 71 | main: Spec.hs 72 | dependencies: 73 | - hspec 74 | - unliftio 75 | - QuickCheck 76 | - containers 77 | 78 | benchmarks: 79 | conc-bench: 80 | source-dirs: 81 | - bench 82 | main: ConcBench.hs 83 | dependencies: 84 | - unliftio 85 | - gauge 86 | ghc-options: 87 | - -O2 88 | - -threaded 89 | - -rtsopts 90 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO.hs: -------------------------------------------------------------------------------- 1 | -- | Please see the README.md file for information on using this 2 | -- package at . 3 | module UnliftIO 4 | ( module Control.Monad.IO.Unlift 5 | , module UnliftIO.Async 6 | , module UnliftIO.Chan 7 | , module UnliftIO.Exception 8 | , module UnliftIO.IO 9 | , module UnliftIO.IORef 10 | , module UnliftIO.Memoize 11 | , module UnliftIO.MVar 12 | , module UnliftIO.QSem 13 | , module UnliftIO.QSemN 14 | , module UnliftIO.STM 15 | , module UnliftIO.Temporary 16 | , module UnliftIO.Timeout 17 | ) where 18 | 19 | import Control.Monad.IO.Unlift 20 | import UnliftIO.Async 21 | import UnliftIO.Chan 22 | import UnliftIO.Exception 23 | import UnliftIO.IO 24 | import UnliftIO.IORef 25 | import UnliftIO.Memoize 26 | import UnliftIO.MVar 27 | import UnliftIO.QSem 28 | import UnliftIO.QSemN 29 | import UnliftIO.STM 30 | import UnliftIO.Temporary 31 | import UnliftIO.Timeout 32 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Async.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | -- | Unlifted "Control.Concurrent.Async". 11 | -- 12 | -- @since 0.1.0.0 13 | module UnliftIO.Async 14 | ( 15 | -- * Asynchronous actions 16 | Async, 17 | -- ** Spawning 18 | async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, 19 | 20 | -- ** Spawning with automatic 'cancel'ation 21 | withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, 22 | withAsyncOnWithUnmask, 23 | 24 | -- ** Querying 'Async's 25 | wait, poll, waitCatch, cancel, uninterruptibleCancel, cancelWith, 26 | A.asyncThreadId, 27 | 28 | -- ** STM operations 29 | A.waitSTM, A.pollSTM, A.waitCatchSTM, 30 | 31 | -- ** Waiting for multiple 'Async's 32 | waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel, 33 | waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel, 34 | waitEither_, 35 | waitBoth, 36 | 37 | -- ** Waiting for multiple 'Async's in STM 38 | A.waitAnySTM, A.waitAnyCatchSTM, 39 | A.waitEitherSTM, A.waitEitherCatchSTM, 40 | A.waitEitherSTM_, 41 | A.waitBothSTM, 42 | 43 | -- ** Linking 44 | link, link2, 45 | 46 | -- ** Pooled concurrency 47 | pooledMapConcurrentlyN, 48 | pooledMapConcurrently, 49 | pooledMapConcurrentlyN_, 50 | pooledMapConcurrently_, 51 | pooledForConcurrentlyN, 52 | pooledForConcurrently, 53 | pooledForConcurrentlyN_, 54 | pooledForConcurrently_, 55 | pooledReplicateConcurrentlyN, 56 | pooledReplicateConcurrently, 57 | pooledReplicateConcurrentlyN_, 58 | pooledReplicateConcurrently_, 59 | 60 | -- * Convenient utilities 61 | race, race_, 62 | concurrently, concurrently_, 63 | mapConcurrently, forConcurrently, 64 | mapConcurrently_, forConcurrently_, 65 | replicateConcurrently, replicateConcurrently_, 66 | Concurrently (..), 67 | 68 | #if MIN_VERSION_base(4,8,0) 69 | Conc, conc, runConc, 70 | ConcException (..), 71 | #endif 72 | 73 | -- * Re-exports 74 | #if MIN_VERSION_async(2,2,0) 75 | A.AsyncCancelled (..), 76 | #endif 77 | ) where 78 | 79 | import Control.Concurrent.Async (Async) 80 | import qualified Control.Concurrent.Async as A 81 | import UnliftIO.Internals.Async 82 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Chan.hs: -------------------------------------------------------------------------------- 1 | -- | Lifted "Control.Concurrent.Chan". 2 | -- 3 | -- @since 0.1.0.0 4 | module UnliftIO.Chan 5 | ( Chan 6 | , newChan 7 | , writeChan 8 | , readChan 9 | , dupChan 10 | , getChanContents 11 | , writeList2Chan 12 | ) where 13 | 14 | import Control.Monad.IO.Unlift 15 | import Control.Concurrent.Chan (Chan) 16 | import qualified Control.Concurrent.Chan as C 17 | 18 | -- | Lifted 'C.newChan'. 19 | -- 20 | -- @since 0.1.0.0 21 | newChan :: MonadIO m => m (Chan a) 22 | newChan = liftIO C.newChan 23 | 24 | -- | Lifted 'C.writeChan'. 25 | -- 26 | -- @since 0.1.0.0 27 | writeChan :: MonadIO m => Chan a -> a -> m () 28 | writeChan c = liftIO . C.writeChan c 29 | 30 | -- | Lifted 'C.readChan'. 31 | -- 32 | -- @since 0.1.0.0 33 | readChan :: MonadIO m => Chan a -> m a 34 | readChan = liftIO . C.readChan 35 | 36 | -- | Lifted 'C.dupChan'. 37 | -- 38 | -- @since 0.1.0.0 39 | dupChan :: MonadIO m => Chan a -> m (Chan a) 40 | dupChan = liftIO . C.dupChan 41 | 42 | -- | Lifted 'C.getChanContents'. 43 | -- 44 | -- @since 0.1.0.0 45 | getChanContents :: MonadIO m => Chan a -> m [a] 46 | getChanContents = liftIO . C.getChanContents 47 | 48 | -- | Lifted 'C.writeList2Chan'. 49 | -- 50 | -- @since 0.1.0.0 51 | writeList2Chan :: MonadIO m => Chan a -> [a] -> m () 52 | writeList2Chan c = liftIO . C.writeList2Chan c 53 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Concurrent.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | -- | Unlifted "Control.Concurrent". 3 | -- 4 | -- This module is not reexported by "UnliftIO", 5 | -- use it only if "UnliftIO.Async" is not enough. 6 | -- 7 | -- @since 0.1.1.0 8 | module UnliftIO.Concurrent 9 | ( 10 | -- * Concurrent Haskell 11 | ThreadId, 12 | 13 | -- * Basic concurrency operations 14 | myThreadId, forkIO, forkWithUnmask, forkIOWithUnmask, forkFinally, killThread, throwTo, 15 | 16 | -- ** Threads with affinity 17 | forkOn, forkOnWithUnmask, getNumCapabilities, setNumCapabilities, 18 | threadCapability, 19 | 20 | -- * Scheduling 21 | yield, 22 | 23 | -- ** Waiting 24 | threadDelay, threadWaitRead, threadWaitWrite, 25 | 26 | -- * Communication abstractions 27 | module UnliftIO.MVar, module UnliftIO.Chan, 28 | 29 | -- * Bound Threads 30 | C.rtsSupportsBoundThreads, forkOS, isCurrentThreadBound, runInBoundThread, 31 | runInUnboundThread, 32 | 33 | -- * Weak references to ThreadIds 34 | mkWeakThreadId 35 | ) where 36 | 37 | import Control.Monad.IO.Class (MonadIO, liftIO) 38 | import System.Posix.Types (Fd) 39 | import System.Mem.Weak (Weak) 40 | import Control.Concurrent (ThreadId) 41 | import qualified Control.Concurrent as C 42 | import Control.Monad.IO.Unlift 43 | import UnliftIO.MVar 44 | import UnliftIO.Chan 45 | import UnliftIO.Exception (throwTo, SomeException) 46 | 47 | -- | Lifted version of 'C.myThreadId'. 48 | -- 49 | -- @since 0.1.1.0 50 | myThreadId :: MonadIO m => m ThreadId 51 | myThreadId = liftIO C.myThreadId 52 | {-# INLINABLE myThreadId #-} 53 | 54 | -- | Unlifted version of 'C.forkIO'. 55 | -- 56 | -- @since 0.1.1.0 57 | forkIO :: MonadUnliftIO m => m () -> m ThreadId 58 | forkIO m = withRunInIO $ \run -> C.forkIO $ run m 59 | {-# INLINABLE forkIO #-} 60 | 61 | -- | Unlifted version of 'C.forkIOWithUnmask'. 62 | -- 63 | -- @since 0.2.11 64 | forkIOWithUnmask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId 65 | forkIOWithUnmask m = 66 | withRunInIO $ \run -> C.forkIOWithUnmask $ \unmask -> run $ m $ liftIO . unmask . run 67 | {-# INLINABLE forkIOWithUnmask #-} 68 | 69 | -- | Please use 'forkIOWithUnmask' instead. This function has been deprecated 70 | -- in release 0.2.11 and will be removed in the next major release. 71 | -- 72 | -- @since 0.1.1.0 73 | forkWithUnmask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m ()) -> m ThreadId 74 | forkWithUnmask = forkIOWithUnmask 75 | {-# INLINABLE forkWithUnmask #-} 76 | {-# DEPRECATED forkWithUnmask "forkWithUnmask has been renamed to forkIOWithUnmask" #-} 77 | 78 | -- | Unlifted version of 'C.forkFinally'. 79 | -- 80 | -- @since 0.1.1.0 81 | forkFinally :: MonadUnliftIO m => m a -> (Either SomeException a -> m ()) -> m ThreadId 82 | forkFinally m1 m2 = withRunInIO $ \run -> C.forkFinally (run m1) $ run . m2 83 | {-# INLINABLE forkFinally #-} 84 | 85 | -- | Lifted version of 'C.killThread'. 86 | -- 87 | -- @since 0.1.1.0 88 | killThread :: MonadIO m => ThreadId -> m () 89 | killThread = liftIO . C.killThread 90 | {-# INLINABLE killThread #-} 91 | 92 | -- | Unlifted version of 'C.forkOn'. 93 | -- 94 | -- @since 0.1.1.0 95 | forkOn :: MonadUnliftIO m => Int -> m () -> m ThreadId 96 | forkOn i m = withRunInIO $ \run -> C.forkOn i $ run m 97 | {-# INLINABLE forkOn #-} 98 | 99 | -- | Unlifted version of 'C.forkOnWithUnmask'. 100 | -- 101 | -- @since 0.1.1.0 102 | forkOnWithUnmask :: MonadUnliftIO m => Int -> ((forall a. m a -> m a) -> m ()) -> m ThreadId 103 | forkOnWithUnmask i m = 104 | withRunInIO $ \run -> C.forkOnWithUnmask i $ \unmask -> run $ m $ liftIO . unmask . run 105 | {-# INLINABLE forkOnWithUnmask #-} 106 | 107 | -- | Lifted version of 'C.getNumCapabilities'. 108 | -- 109 | -- @since 0.1.1.0 110 | getNumCapabilities :: MonadIO m => m Int 111 | getNumCapabilities = liftIO C.getNumCapabilities 112 | {-# INLINABLE getNumCapabilities #-} 113 | 114 | -- | Lifted version of 'C.setNumCapabilities'. 115 | -- 116 | -- @since 0.1.1.0 117 | setNumCapabilities :: MonadIO m => Int -> m () 118 | setNumCapabilities = liftIO . C.setNumCapabilities 119 | {-# INLINABLE setNumCapabilities #-} 120 | 121 | -- | Lifted version of 'C.threadCapability'. 122 | -- 123 | -- @since 0.1.1.0 124 | threadCapability :: MonadIO m => ThreadId -> m (Int, Bool) 125 | threadCapability = liftIO . C.threadCapability 126 | {-# INLINABLE threadCapability #-} 127 | 128 | -- | Lifted version of 'C.yield'. 129 | -- 130 | -- @since 0.1.1.0 131 | yield :: MonadIO m => m () 132 | yield = liftIO C.yield 133 | {-# INLINABLE yield #-} 134 | 135 | -- | Lifted version of 'C.threadDelay'. 136 | -- 137 | -- @since 0.1.1.0 138 | threadDelay :: MonadIO m => Int -> m () 139 | threadDelay = liftIO . C.threadDelay 140 | {-# INLINABLE threadDelay #-} 141 | 142 | -- | Lifted version of 'C.threadWaitRead'. 143 | -- 144 | -- @since 0.1.1.0 145 | threadWaitRead :: MonadIO m => Fd -> m () 146 | threadWaitRead = liftIO . C.threadWaitRead 147 | {-# INLINABLE threadWaitRead #-} 148 | 149 | -- | Lifted version of 'C.threadWaitWrite'. 150 | -- 151 | -- @since 0.1.1.0 152 | threadWaitWrite :: MonadIO m => Fd -> m () 153 | threadWaitWrite = liftIO . C.threadWaitWrite 154 | {-# INLINABLE threadWaitWrite #-} 155 | 156 | -- | Unflifted version of 'C.forkOS'. 157 | -- 158 | -- @since 0.1.1.0 159 | forkOS :: MonadUnliftIO m => m () -> m ThreadId 160 | forkOS m = withRunInIO $ \run -> C.forkOS $ run m 161 | {-# INLINABLE forkOS #-} 162 | 163 | -- | Lifted version of 'C.isCurrentThreadBound'. 164 | -- 165 | -- @since 0.1.1.0 166 | isCurrentThreadBound :: MonadIO m => m Bool 167 | isCurrentThreadBound = liftIO C.isCurrentThreadBound 168 | {-# INLINABLE isCurrentThreadBound #-} 169 | 170 | -- | Unlifted version of 'C.runInBoundThread'. 171 | -- 172 | -- @since 0.1.1.0 173 | runInBoundThread :: MonadUnliftIO m => m a -> m a 174 | runInBoundThread m = withRunInIO $ \run -> C.runInBoundThread $ run m 175 | {-# INLINABLE runInBoundThread #-} 176 | 177 | -- | Unlifted version of 'C.runInUnboundThread'. 178 | -- 179 | -- @since 0.1.1.0 180 | runInUnboundThread :: MonadUnliftIO m => m a -> m a 181 | runInUnboundThread m = withRunInIO $ \run -> C.runInUnboundThread $ run m 182 | {-# INLINABLE runInUnboundThread #-} 183 | 184 | -- | Lifted version of 'C.mkWeakThreadId'. 185 | -- 186 | -- @since 0.1.1.0 187 | mkWeakThreadId :: MonadIO m => ThreadId -> m (Weak ThreadId) 188 | mkWeakThreadId = liftIO . C.mkWeakThreadId 189 | {-# INLINABLE mkWeakThreadId #-} 190 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Directory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Unlifted "System.Directory". 3 | -- 4 | -- @since 0.2.6.0 5 | 6 | module UnliftIO.Directory ( 7 | -- * Actions on directories 8 | createDirectory 9 | , createDirectoryIfMissing 10 | #if MIN_VERSION_directory(1,3,1) 11 | , createFileLink 12 | , createDirectoryLink 13 | , removeDirectoryLink 14 | , getSymbolicLinkTarget 15 | #endif 16 | , removeDirectory 17 | , removeDirectoryRecursive 18 | #if MIN_VERSION_directory(1,2,7) 19 | , removePathForcibly 20 | #endif 21 | , renameDirectory 22 | #if MIN_VERSION_directory(1,2,5) 23 | , listDirectory 24 | #endif 25 | , getDirectoryContents 26 | 27 | -- ** Current working directory 28 | , getCurrentDirectory 29 | , setCurrentDirectory 30 | #if MIN_VERSION_directory(1,2,3) 31 | , withCurrentDirectory 32 | #endif 33 | 34 | -- * Pre-defined directories 35 | , getHomeDirectory 36 | #if MIN_VERSION_directory(1,2,3) 37 | , XdgDirectory(..) 38 | , getXdgDirectory 39 | #endif 40 | #if MIN_VERSION_directory(1,3,2) 41 | , XdgDirectoryList(..) 42 | , getXdgDirectoryList 43 | #endif 44 | , getAppUserDataDirectory 45 | , getUserDocumentsDirectory 46 | , getTemporaryDirectory 47 | 48 | -- * Actions on files 49 | , removeFile 50 | , renameFile 51 | #if MIN_VERSION_directory(1,2,7) 52 | , renamePath 53 | #endif 54 | , copyFile 55 | #if MIN_VERSION_directory(1,2,6) 56 | , copyFileWithMetadata 57 | #endif 58 | , canonicalizePath 59 | #if MIN_VERSION_directory(1,2,2) 60 | , makeAbsolute 61 | #endif 62 | , makeRelativeToCurrentDirectory 63 | , findExecutable 64 | #if MIN_VERSION_directory(1,2,2) 65 | , findExecutables 66 | #endif 67 | #if MIN_VERSION_directory(1,2,4) 68 | , findExecutablesInDirectories 69 | #endif 70 | , findFile 71 | #if MIN_VERSION_directory(1,2,1) 72 | , findFiles 73 | #endif 74 | #if MIN_VERSION_directory(1,2,6) 75 | , findFileWith 76 | #endif 77 | #if MIN_VERSION_directory(1,2,1) 78 | , findFilesWith 79 | #endif 80 | #if MIN_VERSION_directory(1,2,4) 81 | , exeExtension 82 | #endif 83 | #if MIN_VERSION_directory(1,2,7) 84 | , getFileSize 85 | #endif 86 | 87 | -- * Existence tests 88 | #if MIN_VERSION_directory(1,2,7) 89 | , doesPathExist 90 | #endif 91 | , doesFileExist 92 | , doesDirectoryExist 93 | 94 | #if MIN_VERSION_directory(1,3,0) 95 | -- * Symbolic links 96 | , pathIsSymbolicLink 97 | #endif 98 | 99 | -- * Permissions 100 | , Permissions 101 | , emptyPermissions 102 | , readable 103 | , writable 104 | , executable 105 | , searchable 106 | , setOwnerReadable 107 | , setOwnerWritable 108 | , setOwnerExecutable 109 | , setOwnerSearchable 110 | , getPermissions 111 | , setPermissions 112 | , copyPermissions 113 | 114 | -- * Timestamps 115 | #if MIN_VERSION_directory(1,2,3) 116 | , getAccessTime 117 | #endif 118 | , getModificationTime 119 | #if MIN_VERSION_directory(1,2,3) 120 | , setAccessTime 121 | , setModificationTime 122 | #endif 123 | ) where 124 | 125 | import Control.Monad.IO.Unlift 126 | import Data.Time.Clock 127 | import qualified System.Directory as D 128 | import System.Directory 129 | ( Permissions 130 | #if MIN_VERSION_directory(1,2,3) 131 | , XdgDirectory(..) 132 | #endif 133 | #if MIN_VERSION_directory(1,3,2) 134 | , XdgDirectoryList(..) 135 | #endif 136 | , emptyPermissions 137 | #if MIN_VERSION_directory(1,2,4) 138 | , exeExtension 139 | #endif 140 | , executable 141 | , readable 142 | , searchable 143 | , setOwnerExecutable 144 | , setOwnerReadable 145 | , setOwnerSearchable 146 | , setOwnerWritable 147 | , writable 148 | ) 149 | 150 | -- | Lifted 'D.createDirectory'. 151 | -- 152 | -- @since 0.2.6.0 153 | {-# INLINE createDirectory #-} 154 | createDirectory :: MonadIO m => FilePath -> m () 155 | createDirectory = liftIO . D.createDirectory 156 | 157 | -- | Lifted 'D.createDirectoryIfMissing'. 158 | -- 159 | -- @since 0.2.6.0 160 | {-# INLINE createDirectoryIfMissing #-} 161 | createDirectoryIfMissing :: MonadIO m => Bool -> FilePath -> m () 162 | createDirectoryIfMissing create_parents path0 = 163 | liftIO (D.createDirectoryIfMissing create_parents path0) 164 | 165 | #if MIN_VERSION_directory(1,3,1) 166 | -- | Lifted 'D.createFileLink'. 167 | -- directory package version should be >= 1.3.1. 168 | -- @since 0.2.16.0 169 | {-# INLINE createFileLink #-} 170 | createFileLink 171 | :: MonadIO m 172 | => FilePath -- ^ path to the target file 173 | -> FilePath -- ^ path of the link to be created 174 | -> m () 175 | createFileLink targetPath linkPath = 176 | liftIO (D.createFileLink targetPath linkPath) 177 | 178 | -- | Lifted 'D.createDirectoryLink'. 179 | -- 180 | -- @since 0.2.21.0 181 | createDirectoryLink :: MonadIO m => FilePath -> FilePath -> m () 182 | createDirectoryLink targetPath linkPath = 183 | liftIO (D.createDirectoryLink targetPath linkPath) 184 | 185 | -- | Lifted 'D.removeDirectoryLink'. 186 | -- 187 | -- @since 0.2.21.0 188 | removeDirectoryLink :: MonadIO m => FilePath -> m () 189 | removeDirectoryLink linkPath = 190 | liftIO (D.removeDirectoryLink linkPath) 191 | 192 | -- | Lifted 'D.getSymbolicLinkTarget'. 193 | -- 194 | -- @since 0.2.21.0 195 | getSymbolicLinkTarget :: MonadIO m => FilePath -> m FilePath 196 | getSymbolicLinkTarget linkPath = 197 | liftIO (D.getSymbolicLinkTarget linkPath) 198 | #endif 199 | 200 | -- | Lifted 'D.removeDirectory'. 201 | -- 202 | -- @since 0.2.6.0 203 | {-# INLINE removeDirectory #-} 204 | removeDirectory :: MonadIO m => FilePath -> m () 205 | removeDirectory = liftIO . D.removeDirectory 206 | 207 | -- | Lifted 'D.removeDirectoryRecursive'. 208 | -- 209 | -- @since 0.2.6.0 210 | {-# INLINE removeDirectoryRecursive #-} 211 | removeDirectoryRecursive :: MonadIO m => FilePath -> m () 212 | removeDirectoryRecursive = liftIO . D.removeDirectoryRecursive 213 | 214 | #if MIN_VERSION_directory(1,2,7) 215 | -- | Lifted 'D.removePathForcibly'. 216 | -- 217 | -- @since 0.2.6.0 218 | {-# INLINE removePathForcibly #-} 219 | removePathForcibly :: MonadIO m => FilePath -> m () 220 | removePathForcibly = liftIO . D.removePathForcibly 221 | #endif 222 | 223 | -- | Lifted 'D.renameDirectory'. 224 | -- 225 | -- @since 0.2.6.0 226 | {-# INLINE renameDirectory #-} 227 | renameDirectory :: MonadIO m => FilePath -> FilePath -> m () 228 | renameDirectory opath npath = liftIO (D.renameDirectory opath npath) 229 | 230 | #if MIN_VERSION_directory(1,2,5) 231 | -- | Lifted 'D.listDirectory'. 232 | -- 233 | -- @since 0.2.6.0 234 | {-# INLINE listDirectory #-} 235 | listDirectory :: MonadIO m => FilePath -> m [FilePath] 236 | listDirectory = liftIO . D.listDirectory 237 | #endif 238 | 239 | -- | Lifted 'D.getDirectoryContents'. 240 | -- 241 | -- @since 0.2.6.0 242 | {-# INLINE getDirectoryContents #-} 243 | getDirectoryContents :: MonadIO m => FilePath -> m [FilePath] 244 | getDirectoryContents = liftIO . D.getDirectoryContents 245 | 246 | -- | Lifted 'D.getCurrentDirectory'. 247 | -- 248 | -- @since 0.2.6.0 249 | {-# INLINE getCurrentDirectory #-} 250 | getCurrentDirectory :: MonadIO m => m FilePath 251 | getCurrentDirectory = liftIO D.getCurrentDirectory 252 | 253 | -- | Lifted 'D.setCurrentDirectory'. 254 | -- 255 | -- @since 0.2.6.0 256 | {-# INLINE setCurrentDirectory #-} 257 | setCurrentDirectory :: MonadIO m => FilePath -> m () 258 | setCurrentDirectory = liftIO . D.setCurrentDirectory 259 | 260 | #if MIN_VERSION_directory(1,2,3) 261 | -- | Unlifted 'D.withCurrentDirectory'. 262 | -- 263 | -- @since 0.2.6.0 264 | {-# INLINE withCurrentDirectory #-} 265 | withCurrentDirectory :: MonadUnliftIO m => FilePath -> m a -> m a 266 | withCurrentDirectory dir action = 267 | withRunInIO (\u -> D.withCurrentDirectory dir (u action)) 268 | #endif 269 | 270 | -- | Lifted 'D.getHomeDirectory'. 271 | -- 272 | -- @since 0.2.6.0 273 | {-# INLINE getHomeDirectory #-} 274 | getHomeDirectory :: MonadIO m => m FilePath 275 | getHomeDirectory = liftIO D.getHomeDirectory 276 | 277 | #if MIN_VERSION_directory(1,2,3) 278 | -- | Lifted 'D.getXdgDirectory'. 279 | -- 280 | -- @since 0.2.6.0 281 | {-# INLINE getXdgDirectory #-} 282 | getXdgDirectory :: MonadIO m => XdgDirectory -> FilePath -> m FilePath 283 | getXdgDirectory xdgDir suffix = liftIO (D.getXdgDirectory xdgDir suffix) 284 | #endif 285 | 286 | #if MIN_VERSION_directory(1,3,2) 287 | -- | Lifted 'D.getXdgDirectoryList'. 288 | -- 289 | -- @since 0.2.21.0 290 | getXdgDirectoryList :: MonadIO m => XdgDirectoryList -> m [FilePath] 291 | getXdgDirectoryList xdgDirectoryList = 292 | liftIO (D.getXdgDirectoryList xdgDirectoryList) 293 | #endif 294 | 295 | -- | Lifted 'D.getAppUserDataDirectory'. 296 | -- 297 | -- @since 0.2.6.0 298 | {-# INLINE getAppUserDataDirectory #-} 299 | getAppUserDataDirectory :: MonadIO m => FilePath -> m FilePath 300 | getAppUserDataDirectory = liftIO . D.getAppUserDataDirectory 301 | 302 | -- | Lifted 'D.getUserDocumentsDirectory'. 303 | -- 304 | -- @since 0.2.6.0 305 | {-# INLINE getUserDocumentsDirectory #-} 306 | getUserDocumentsDirectory :: MonadIO m => m FilePath 307 | getUserDocumentsDirectory = liftIO D.getUserDocumentsDirectory 308 | 309 | -- | Lifted 'D.getTemporaryDirectory'. 310 | -- 311 | -- @since 0.2.6.0 312 | {-# INLINE getTemporaryDirectory #-} 313 | getTemporaryDirectory :: MonadIO m => m FilePath 314 | getTemporaryDirectory = liftIO D.getTemporaryDirectory 315 | 316 | -- | Lifted 'D.removeFile'. 317 | -- 318 | -- @since 0.2.6.0 319 | {-# INLINE removeFile #-} 320 | removeFile :: MonadIO m => FilePath -> m () 321 | removeFile = liftIO . D.removeFile 322 | 323 | -- | Lifted 'D.renameFile'. 324 | -- 325 | -- @since 0.2.6.0 326 | {-# INLINE renameFile #-} 327 | renameFile :: MonadIO m => FilePath -> FilePath -> m () 328 | renameFile opath npath = liftIO (D.renameFile opath npath) 329 | 330 | #if MIN_VERSION_directory(1,2,7) 331 | -- | Lifted 'D.renamePath'. 332 | -- 333 | -- @since 0.2.6.0 334 | {-# INLINE renamePath #-} 335 | renamePath :: MonadIO m => FilePath -> FilePath -> m () 336 | renamePath opath npath = liftIO (D.renamePath opath npath) 337 | #endif 338 | 339 | -- | Lifted 'D.copyFile'. 340 | -- 341 | -- @since 0.2.6.0 342 | {-# INLINE copyFile #-} 343 | copyFile :: MonadIO m => FilePath -> FilePath -> m () 344 | copyFile fromFPath toFPath = liftIO (D.copyFile fromFPath toFPath) 345 | 346 | #if MIN_VERSION_directory(1,2,6) 347 | -- | Lifted 'D.copyFileWithMetadata'. 348 | -- 349 | -- @since 0.2.6.0 350 | {-# INLINE copyFileWithMetadata #-} 351 | copyFileWithMetadata :: MonadIO m => FilePath -> FilePath -> m () 352 | copyFileWithMetadata src dst = liftIO (D.copyFileWithMetadata src dst) 353 | #endif 354 | 355 | -- | Lifted 'D.canonicalizePath'. 356 | -- 357 | -- @since 0.2.6.0 358 | {-# INLINE canonicalizePath #-} 359 | canonicalizePath :: MonadIO m => FilePath -> m FilePath 360 | canonicalizePath = liftIO . D.canonicalizePath 361 | 362 | #if MIN_VERSION_directory(1,2,2) 363 | -- | Lifted 'D.makeAbsolute'. 364 | -- 365 | -- @since 0.2.6.0 366 | {-# INLINE makeAbsolute #-} 367 | makeAbsolute :: MonadIO m => FilePath -> m FilePath 368 | makeAbsolute = liftIO . D.makeAbsolute 369 | #endif 370 | 371 | -- | Lifted 'D.makeRelativeToCurrentDirectory'. 372 | -- 373 | -- @since 0.2.6.0 374 | {-# INLINE makeRelativeToCurrentDirectory #-} 375 | makeRelativeToCurrentDirectory :: MonadIO m => FilePath -> m FilePath 376 | makeRelativeToCurrentDirectory = liftIO . D.makeRelativeToCurrentDirectory 377 | 378 | -- | Lifted 'D.findExecutable'. 379 | -- 380 | -- @since 0.2.6.0 381 | {-# INLINE findExecutable #-} 382 | findExecutable :: MonadIO m => String -> m (Maybe FilePath) 383 | findExecutable = liftIO . D.findExecutable 384 | 385 | #if MIN_VERSION_directory(1,2,2) 386 | -- | Lifted 'D.findExecutables'. 387 | -- 388 | -- @since 0.2.6.0 389 | {-# INLINE findExecutables #-} 390 | findExecutables :: MonadIO m => String -> m [FilePath] 391 | findExecutables = liftIO . D.findExecutables 392 | #endif 393 | 394 | #if MIN_VERSION_directory(1,2,4) 395 | -- | Lifted 'D.findExecutablesInDirectories'. 396 | -- 397 | -- @since 0.2.6.0 398 | {-# INLINE findExecutablesInDirectories #-} 399 | findExecutablesInDirectories :: 400 | MonadIO m => [FilePath] -> String -> m [FilePath] 401 | findExecutablesInDirectories path binary = 402 | liftIO (D.findExecutablesInDirectories path binary) 403 | #endif 404 | 405 | -- | Lifted 'D.findFile'. 406 | -- 407 | -- @since 0.2.6.0 408 | {-# INLINE findFile #-} 409 | findFile :: MonadIO m => [FilePath] -> String -> m (Maybe FilePath) 410 | findFile ds name = liftIO (D.findFile ds name) 411 | 412 | #if MIN_VERSION_directory(1,2,1) 413 | -- | Lifted 'D.findFiles'. 414 | -- 415 | -- @since 0.2.6.0 416 | {-# INLINE findFiles #-} 417 | findFiles :: MonadIO m => [FilePath] -> String -> m [FilePath] 418 | findFiles ds name = liftIO (D.findFiles ds name) 419 | #endif 420 | 421 | #if MIN_VERSION_directory(1,2,6) 422 | -- | Unlifted 'D.findFileWith'. 423 | -- 424 | -- @since 0.2.6.0 425 | {-# INLINE findFileWith #-} 426 | findFileWith :: 427 | MonadUnliftIO m 428 | => (FilePath -> m Bool) 429 | -> [FilePath] 430 | -> String 431 | -> m (Maybe FilePath) 432 | findFileWith f ds name = withRunInIO (\u -> D.findFileWith (u . f) ds name) 433 | #endif 434 | 435 | #if MIN_VERSION_directory(1,2,1) 436 | -- | Unlifted 'D.findFilesWith'. 437 | -- 438 | -- @since 0.2.6.0 439 | {-# INLINE findFilesWith #-} 440 | findFilesWith :: 441 | MonadUnliftIO m 442 | => (FilePath -> m Bool) 443 | -> [FilePath] 444 | -> String 445 | -> m [FilePath] 446 | findFilesWith f ds name = withRunInIO (\u -> D.findFilesWith (u . f) ds name) 447 | #endif 448 | 449 | #if MIN_VERSION_directory(1,2,7) 450 | -- | Lifted 'D.getFileSize'. 451 | -- 452 | -- @since 0.2.6.0 453 | {-# INLINE getFileSize #-} 454 | getFileSize :: MonadIO m => FilePath -> m Integer 455 | getFileSize = liftIO . D.getFileSize 456 | #endif 457 | 458 | #if MIN_VERSION_directory(1,2,7) 459 | -- | Lifted 'D.doesPathExist'. 460 | -- 461 | -- @since 0.2.6.0 462 | {-# INLINE doesPathExist #-} 463 | doesPathExist :: MonadIO m => FilePath -> m Bool 464 | doesPathExist = liftIO . D.doesPathExist 465 | #endif 466 | 467 | -- | Lifted 'D.doesFileExist'. 468 | -- 469 | -- @since 0.2.6.0 470 | {-# INLINE doesFileExist #-} 471 | doesFileExist :: MonadIO m => FilePath -> m Bool 472 | doesFileExist = liftIO . D.doesFileExist 473 | 474 | -- | Lifted 'D.doesDirectoryExist'. 475 | -- 476 | -- @since 0.2.6.0 477 | {-# INLINE doesDirectoryExist #-} 478 | doesDirectoryExist :: MonadIO m => FilePath -> m Bool 479 | doesDirectoryExist = liftIO . D.doesDirectoryExist 480 | 481 | #if MIN_VERSION_directory(1,3,0) 482 | -- | Lifted 'D.pathIsSymbolicLink'. 483 | -- 484 | -- @since 0.2.6.0 485 | {-# INLINE pathIsSymbolicLink #-} 486 | pathIsSymbolicLink :: MonadIO m => FilePath -> m Bool 487 | pathIsSymbolicLink = liftIO . D.pathIsSymbolicLink 488 | #endif 489 | 490 | -- | Lifted 'D.getPermissions'. 491 | -- 492 | -- @since 0.2.6.0 493 | {-# INLINE getPermissions #-} 494 | getPermissions :: MonadIO m => FilePath -> m Permissions 495 | getPermissions = liftIO . D.getPermissions 496 | 497 | -- | Lifted 'D.setPermissions'. 498 | -- 499 | -- @since 0.2.6.0 500 | {-# INLINE setPermissions #-} 501 | setPermissions :: MonadIO m => FilePath -> Permissions -> m () 502 | setPermissions name p = liftIO (D.setPermissions name p) 503 | 504 | -- | Lifted 'D.copyPermissions'. 505 | -- 506 | -- @since 0.2.6.0 507 | {-# INLINE copyPermissions #-} 508 | copyPermissions :: MonadIO m => FilePath -> FilePath -> m () 509 | copyPermissions source dest = liftIO (D.copyPermissions source dest) 510 | 511 | #if MIN_VERSION_directory(1,2,3) 512 | -- | Lifted 'D.getAccessTime'. 513 | -- 514 | -- @since 0.2.6.0 515 | {-# INLINE getAccessTime #-} 516 | getAccessTime :: MonadIO m => FilePath -> m UTCTime 517 | getAccessTime = liftIO . D.getAccessTime 518 | #endif 519 | 520 | -- | Lifted 'D.getModificationTime'. 521 | -- 522 | -- @since 0.2.6.0 523 | {-# INLINE getModificationTime #-} 524 | getModificationTime :: MonadIO m => FilePath -> m UTCTime 525 | getModificationTime = liftIO . D.getModificationTime 526 | 527 | #if MIN_VERSION_directory(1,2,3) 528 | -- | Lifted 'D.setAccessTime'. 529 | -- 530 | -- @since 0.2.6.0 531 | {-# INLINE setAccessTime #-} 532 | setAccessTime :: MonadIO m => FilePath -> UTCTime -> m () 533 | setAccessTime path atime = liftIO (D.setAccessTime path atime) 534 | 535 | -- | Lifted 'D.setModificationTime'. 536 | -- 537 | -- @since 0.2.6.0 538 | setModificationTime :: MonadIO m => FilePath -> UTCTime -> m () 539 | setModificationTime path mtime = liftIO (D.setModificationTime path mtime) 540 | #endif 541 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Environment.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "System.Environment". 2 | -- 3 | -- @since 0.2.5.0 4 | module UnliftIO.Environment 5 | ( getArgs 6 | , getProgName 7 | , getExecutablePath 8 | , getEnv 9 | , lookupEnv 10 | , setEnv 11 | , unsetEnv 12 | , withArgs 13 | , withProgName 14 | , getEnvironment 15 | ) where 16 | 17 | import Control.Monad.IO.Unlift 18 | import qualified System.Environment as E 19 | 20 | -- | Lifted 'E.getArgs'. 21 | -- 22 | -- @since 0.2.5.0 23 | {-# INLINE getArgs #-} 24 | getArgs :: MonadIO m => m [String] 25 | getArgs = liftIO E.getArgs 26 | 27 | -- | Lifted 'E.getProgName'. 28 | -- 29 | -- @since 0.2.5.0 30 | {-# INLINE getProgName #-} 31 | getProgName :: MonadIO m => m String 32 | getProgName = liftIO E.getProgName 33 | 34 | -- | Lifted 'E.getExecutablePath'. 35 | -- 36 | -- @since 0.2.5.0 37 | {-# INLINE getExecutablePath #-} 38 | getExecutablePath :: MonadIO m => m FilePath 39 | getExecutablePath = liftIO E.getExecutablePath 40 | 41 | -- | Lifted 'E.getEnv'. 42 | -- 43 | -- @since 0.2.5.0 44 | {-# INLINE getEnv #-} 45 | getEnv :: MonadIO m => String -> m String 46 | getEnv = liftIO . E.getEnv 47 | 48 | -- | Lifted 'E.lookupEnv'. 49 | -- 50 | -- @since 0.2.5.0 51 | {-# INLINE lookupEnv #-} 52 | lookupEnv :: MonadIO m => String -> m (Maybe String) 53 | lookupEnv = liftIO . E.lookupEnv 54 | 55 | -- | Lifted 'E.setEnv'. 56 | -- 57 | -- @since 0.2.5.0 58 | {-# INLINE setEnv #-} 59 | setEnv :: MonadIO m => String -> String -> m () 60 | setEnv key_ value_ = liftIO (E.setEnv key_ value_) 61 | 62 | -- | Lifted 'E.unsetEnv'. 63 | -- 64 | -- @since 0.2.5.0 65 | {-# INLINE unsetEnv #-} 66 | unsetEnv :: MonadIO m => String -> m () 67 | unsetEnv = liftIO . E.unsetEnv 68 | 69 | -- | Unlifted 'E.withArgs'. 70 | -- 71 | -- @since 0.2.5.0 72 | {-# INLINE withArgs #-} 73 | withArgs :: MonadUnliftIO m => [String] -> m a -> m a 74 | withArgs xs act = withRunInIO (\u -> E.withArgs xs (u act)) 75 | 76 | -- | Unlifted 'E.withProgName'. 77 | -- 78 | -- @since 0.2.5.0 79 | {-# INLINE withProgName #-} 80 | withProgName :: MonadUnliftIO m => String -> m a -> m a 81 | withProgName nm act = withRunInIO (\u -> E.withProgName nm (u act)) 82 | 83 | -- | Lifted 'E.getEnvironment'. 84 | -- 85 | -- @since 0.2.5.0 86 | {-# INLINE getEnvironment #-} 87 | getEnvironment :: MonadIO m => m [(String, String)] 88 | getEnvironment = liftIO E.getEnvironment 89 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE ImplicitParams #-} 7 | -- | Unlifted "Control.Exception", with extra async exception safety 8 | -- and more helper functions. 9 | -- 10 | -- This module works best when your cleanup functions adhere to certain 11 | -- expectations around exception safety and interruptible actions. 12 | -- For more details, see [this exception safety tutorial](https://www.fpcomplete.com/haskell/tutorial/exceptions/). 13 | module UnliftIO.Exception 14 | ( -- * Throwing 15 | throwIO 16 | , throwString 17 | , StringException (..) 18 | , stringException 19 | , throwTo 20 | , impureThrow 21 | , fromEither 22 | , fromEitherIO 23 | , fromEitherM 24 | , mapExceptionM 25 | 26 | -- * Catching (with recovery) 27 | , catch 28 | , catchIO 29 | , catchAny 30 | , catchDeep 31 | , catchAnyDeep 32 | , catchJust 33 | 34 | , handle 35 | , handleIO 36 | , handleAny 37 | , handleDeep 38 | , handleAnyDeep 39 | , handleJust 40 | 41 | , try 42 | , tryIO 43 | , tryAny 44 | , tryDeep 45 | , tryAnyDeep 46 | , tryJust 47 | , pureTry 48 | , pureTryDeep 49 | 50 | , ESafe.Handler (..) 51 | , catches 52 | , catchesDeep 53 | 54 | -- * Catching async exceptions (with recovery) 55 | , catchSyncOrAsync 56 | , handleSyncOrAsync 57 | , trySyncOrAsync 58 | 59 | -- * Cleanup (no recovery) 60 | , onException 61 | , bracket 62 | , bracket_ 63 | , finally 64 | , withException 65 | , bracketOnError 66 | , bracketOnError_ 67 | 68 | -- * Coercion to sync and async 69 | -- | In version /0.2.23.0/, these were changed with aliases to the values 70 | -- from "Control.Exception.Safe" in the @safe-exceptions@ package. 71 | , ESafe.SyncExceptionWrapper(..) 72 | , toSyncException 73 | , ESafe.AsyncExceptionWrapper(..) 74 | , toAsyncException 75 | , fromExceptionUnwrap 76 | 77 | -- * Check exception type 78 | , isSyncException 79 | , isAsyncException 80 | -- * Masking 81 | , mask 82 | , uninterruptibleMask 83 | , mask_ 84 | , uninterruptibleMask_ 85 | -- * Evaluation 86 | , evaluate 87 | , evaluateDeep 88 | -- * Reexports 89 | , Exception (..) 90 | , Typeable 91 | , SomeException (..) 92 | , SomeAsyncException (..) 93 | , IOException 94 | , EUnsafe.assert 95 | , EUnsafe.asyncExceptionToException 96 | , EUnsafe.asyncExceptionFromException 97 | #if !MIN_VERSION_base(4,8,0) 98 | , displayException 99 | #endif 100 | ) where 101 | 102 | import Control.Concurrent (ThreadId) 103 | import Control.Monad (liftM) 104 | import Control.Monad.IO.Unlift 105 | import Control.Exception (Exception (..), SomeException (..), IOException, SomeAsyncException (..)) 106 | import qualified Control.Exception as EUnsafe 107 | import Control.DeepSeq (NFData (..), ($!!)) 108 | import Data.Typeable (Typeable, cast) 109 | import System.IO.Unsafe (unsafePerformIO) 110 | import qualified Control.Exception.Safe as ESafe 111 | import Control.Exception.Safe (Handler(..)) 112 | 113 | #if MIN_VERSION_base(4,9,0) 114 | import GHC.Stack (prettySrcLoc) 115 | import GHC.Stack.Types (HasCallStack, CallStack, getCallStack) 116 | #endif 117 | 118 | -- | Catch a synchronous (but not asynchronous) exception and recover from it. 119 | -- 120 | -- This is parameterized on the exception type. To catch all synchronous exceptions, 121 | -- use 'catchAny'. 122 | -- 123 | -- @since 0.1.0.0 124 | catch 125 | :: (MonadUnliftIO m, Exception e) 126 | => m a -- ^ action 127 | -> (e -> m a) -- ^ handler 128 | -> m a 129 | catch f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> 130 | if isSyncException e 131 | then run (g e) 132 | -- intentionally rethrowing an async exception synchronously, 133 | -- since we want to preserve async behavior 134 | else EUnsafe.throwIO e 135 | 136 | -- | 'catch' specialized to only catching 'IOException's. 137 | -- 138 | -- @since 0.1.0.0 139 | catchIO :: MonadUnliftIO m => m a -> (IOException -> m a) -> m a 140 | catchIO = catch 141 | 142 | -- | 'catch' specialized to catch all synchronous exceptions. 143 | -- 144 | -- @since 0.1.0.0 145 | catchAny :: MonadUnliftIO m => m a -> (SomeException -> m a) -> m a 146 | catchAny = catch 147 | 148 | -- | Same as 'catch', but fully force evaluation of the result value 149 | -- to find all impure exceptions. 150 | -- 151 | -- @since 0.1.0.0 152 | catchDeep :: (MonadUnliftIO m, Exception e, NFData a) 153 | => m a -> (e -> m a) -> m a 154 | catchDeep m = catch (m >>= evaluateDeep) 155 | 156 | -- | 'catchDeep' specialized to catch all synchronous exception. 157 | -- 158 | -- @since 0.1.0.0 159 | catchAnyDeep :: (NFData a, MonadUnliftIO m) => m a -> (SomeException -> m a) -> m a 160 | catchAnyDeep = catchDeep 161 | 162 | -- | 'catchJust' is like 'catch' but it takes an extra argument which 163 | -- is an exception predicate, a function which selects which type of 164 | -- exceptions we're interested in. 165 | -- 166 | -- @since 0.1.0.0 167 | catchJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> m a -> (b -> m a) -> m a 168 | catchJust f a b = a `catch` \e -> maybe (liftIO (throwIO e)) b $ f e 169 | 170 | -- | A variant of 'catch' that catches both synchronous and asynchronous exceptions. 171 | -- 172 | -- WARNING: This function (and other @*SyncOrAsync@ functions) is for advanced users. Most of the 173 | -- time, you probably want to use the non-@SyncOrAsync@ versions. 174 | -- 175 | -- Before attempting to use this function, be familiar with the "Rules for async safe handling" 176 | -- section in 177 | -- [this blog post](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/). 178 | -- 179 | -- @since 0.2.17 180 | catchSyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> (e -> m a) -> m a 181 | catchSyncOrAsync f g = withRunInIO $ \run -> run f `EUnsafe.catch` \e -> run (g e) 182 | 183 | -- | Flipped version of 'catch'. 184 | -- 185 | -- @since 0.1.0.0 186 | handle :: (MonadUnliftIO m, Exception e) => (e -> m a) -> m a -> m a 187 | handle = flip catch 188 | 189 | -- | 'handle' specialized to only catching 'IOException's. 190 | -- 191 | -- @since 0.1.0.0 192 | handleIO :: MonadUnliftIO m => (IOException -> m a) -> m a -> m a 193 | handleIO = handle 194 | 195 | -- | Flipped version of 'catchAny'. 196 | -- 197 | -- @since 0.1.0.0 198 | handleAny :: MonadUnliftIO m => (SomeException -> m a) -> m a -> m a 199 | handleAny = handle 200 | 201 | -- | Flipped version of 'catchDeep'. 202 | -- 203 | -- @since 0.1.0.0 204 | handleDeep :: (MonadUnliftIO m, Exception e, NFData a) => (e -> m a) -> m a -> m a 205 | handleDeep = flip catchDeep 206 | 207 | -- | Flipped version of 'catchAnyDeep'. 208 | -- 209 | -- @since 0.1.0.0 210 | handleAnyDeep :: (MonadUnliftIO m, NFData a) => (SomeException -> m a) -> m a -> m a 211 | handleAnyDeep = flip catchAnyDeep 212 | 213 | -- | Flipped 'catchJust'. 214 | -- 215 | -- @since 0.1.0.0 216 | handleJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> (b -> m a) -> m a -> m a 217 | handleJust f = flip (catchJust f) 218 | 219 | -- | A variant of 'handle' that catches both synchronous and asynchronous exceptions. 220 | -- 221 | -- See 'catchSyncOrAsync'. 222 | -- 223 | -- @since 0.2.17 224 | handleSyncOrAsync :: (MonadUnliftIO m, Exception e) => (e -> m a) -> m a -> m a 225 | handleSyncOrAsync = flip catchSyncOrAsync 226 | 227 | -- | Run the given action and catch any synchronous exceptions as a 'Left' value. 228 | -- 229 | -- This is parameterized on the exception type. To catch all synchronous exceptions, 230 | -- use 'tryAny'. 231 | -- 232 | -- @since 0.1.0.0 233 | try :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) 234 | try f = catch (liftM Right f) (return . Left) 235 | 236 | -- | 'try' specialized to only catching 'IOException's. 237 | -- 238 | -- @since 0.1.0.0 239 | tryIO :: MonadUnliftIO m => m a -> m (Either IOException a) 240 | tryIO = try 241 | 242 | -- | 'try' specialized to catch all synchronous exceptions. 243 | -- 244 | -- @since 0.1.0.0 245 | tryAny :: MonadUnliftIO m => m a -> m (Either SomeException a) 246 | tryAny = try 247 | 248 | -- | Same as 'try', but fully force evaluation of the result value 249 | -- to find all impure exceptions. 250 | -- 251 | -- @since 0.1.0.0 252 | tryDeep :: (MonadUnliftIO m, Exception e, NFData a) => m a -> m (Either e a) 253 | tryDeep f = catch (liftM Right (f >>= evaluateDeep)) (return . Left) 254 | 255 | -- | 'tryDeep' specialized to catch all synchronous exceptions. 256 | -- 257 | -- @since 0.1.0.0 258 | tryAnyDeep :: (MonadUnliftIO m, NFData a) => m a -> m (Either SomeException a) 259 | tryAnyDeep = tryDeep 260 | 261 | -- | A variant of 'try' that takes an exception predicate to select 262 | -- which exceptions are caught. 263 | -- 264 | -- @since 0.1.0.0 265 | tryJust :: (MonadUnliftIO m, Exception e) => (e -> Maybe b) -> m a -> m (Either b a) 266 | tryJust f a = catch (Right `liftM` a) (\e -> maybe (throwIO e) (return . Left) (f e)) 267 | 268 | -- | A variant of 'try' that catches both synchronous and asynchronous exceptions. 269 | -- 270 | -- See 'catchSyncOrAsync'. 271 | -- 272 | -- @since 0.2.17 273 | trySyncOrAsync :: (MonadUnliftIO m, Exception e) => m a -> m (Either e a) 274 | trySyncOrAsync f = catchSyncOrAsync (liftM Right f) (return . Left) 275 | 276 | -- | Evaluate the value to WHNF and catch any synchronous exceptions. 277 | -- 278 | -- The expression may still have bottom values within it; you may 279 | -- instead want to use 'pureTryDeep'. 280 | -- 281 | -- @since 0.2.2.0 282 | pureTry :: a -> Either SomeException a 283 | pureTry a = unsafePerformIO $ (return $! Right $! a) `catchAny` (return . Left) 284 | 285 | -- | Evaluate the value to NF and catch any synchronous exceptions. 286 | -- 287 | -- @since 0.2.2.0 288 | pureTryDeep :: NFData a => a -> Either SomeException a 289 | pureTryDeep = unsafePerformIO . tryAnyDeep . return 290 | 291 | -- | Internal. 292 | catchesHandler :: MonadIO m => [Handler m a] -> SomeException -> m a 293 | catchesHandler handlers e = foldr tryHandler (liftIO (EUnsafe.throwIO e)) handlers 294 | where tryHandler (ESafe.Handler handler) res 295 | = case fromException e of 296 | Just e' -> handler e' 297 | Nothing -> res 298 | 299 | -- | Similar to 'catch', but provides multiple different handler functions. 300 | -- 301 | -- For more information on motivation, see @base@'s 'EUnsafe.catches'. Note that, 302 | -- unlike that function, this function will not catch asynchronous exceptions. 303 | -- 304 | -- @since 0.1.0.0 305 | catches :: MonadUnliftIO m => m a -> [Handler m a] -> m a 306 | catches io handlers = io `catch` catchesHandler handlers 307 | 308 | -- | Same as 'catches', but fully force evaluation of the result value 309 | -- to find all impure exceptions. 310 | -- 311 | -- @since 0.1.0.0 312 | catchesDeep :: (MonadUnliftIO m, NFData a) => m a -> [Handler m a] -> m a 313 | catchesDeep io handlers = (io >>= evaluateDeep) `catch` catchesHandler handlers 314 | 315 | -- | Lifted version of 'EUnsafe.evaluate'. 316 | -- 317 | -- @since 0.1.0.0 318 | evaluate :: MonadIO m => a -> m a 319 | evaluate = liftIO . EUnsafe.evaluate 320 | 321 | -- | Deeply evaluate a value using 'evaluate' and 'NFData'. 322 | -- 323 | -- @since 0.1.0.0 324 | evaluateDeep :: (MonadIO m, NFData a) => a -> m a 325 | evaluateDeep = (evaluate $!!) 326 | 327 | -- | Allocate and clean up a resource safely. 328 | -- 329 | -- For more information on motivation and usage of this function, see @base@'s 330 | -- 'EUnsafe.bracket'. This function has two differences from the one in @base@. 331 | -- The first, and more obvious, is that it works on any @MonadUnliftIO@ 332 | -- instance, not just @IO@. 333 | -- 334 | -- The more subtle difference is that this function will use uninterruptible 335 | -- masking for its cleanup handler. This is a subtle distinction, but at a 336 | -- high level, means that resource cleanup has more guarantees to complete. 337 | -- This comes at the cost that an incorrectly written cleanup function 338 | -- cannot be interrupted. 339 | -- 340 | -- For more information, please see . 341 | -- 342 | -- @since 0.1.0.0 343 | bracket :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c 344 | bracket before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do 345 | x <- run before 346 | res1 <- EUnsafe.try $ restore $ run $ thing x 347 | case res1 of 348 | Left (e1 :: SomeException) -> do 349 | -- explicitly ignore exceptions from after. We know that 350 | -- no async exceptions were thrown there, so therefore 351 | -- the stronger exception must come from thing 352 | -- 353 | -- https://github.com/fpco/safe-exceptions/issues/2 354 | _ :: Either SomeException b <- 355 | EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after x 356 | EUnsafe.throwIO e1 357 | Right y -> do 358 | _ <- EUnsafe.uninterruptibleMask_ $ run $ after x 359 | return y 360 | 361 | -- | Same as 'bracket', but does not pass the acquired resource to cleanup and use functions. 362 | -- 363 | -- For more information, see @base@'s 'EUnsafe.bracket_'. 364 | -- 365 | -- @since 0.1.0.0 366 | bracket_ :: MonadUnliftIO m => m a -> m b -> m c -> m c 367 | bracket_ before after thing = bracket before (const after) (const thing) 368 | 369 | -- | Same as 'bracket', but only perform the cleanup if an exception is thrown. 370 | -- 371 | -- @since 0.1.0.0 372 | bracketOnError :: MonadUnliftIO m => m a -> (a -> m b) -> (a -> m c) -> m c 373 | bracketOnError before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do 374 | x <- run before 375 | res1 <- EUnsafe.try $ restore $ run $ thing x 376 | case res1 of 377 | Left (e1 :: SomeException) -> do 378 | -- ignore the exception, see bracket for explanation 379 | _ :: Either SomeException b <- 380 | EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after x 381 | EUnsafe.throwIO e1 382 | Right y -> return y 383 | 384 | -- | A variant of 'bracketOnError' where the return value from the first 385 | -- computation is not required. 386 | -- 387 | -- @since 0.1.0.0 388 | bracketOnError_ :: MonadUnliftIO m => m a -> m b -> m c -> m c 389 | bracketOnError_ before after thing = bracketOnError before (const after) (const thing) 390 | 391 | -- | Perform @thing@, guaranteeing that @after@ will run after, even if an exception occurs. 392 | -- 393 | -- Same interruptible vs uninterrupible points apply as with 'bracket'. See @base@'s 394 | -- 'EUnsafe.finally' for more information. 395 | -- 396 | -- @since 0.1.0.0 397 | finally 398 | :: MonadUnliftIO m 399 | => m a -- ^ thing 400 | -> m b -- ^ after 401 | -> m a 402 | finally thing after = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \restore -> do 403 | res1 <- EUnsafe.try $ restore $ run thing 404 | case res1 of 405 | Left (e1 :: SomeException) -> do 406 | -- see bracket for explanation 407 | _ :: Either SomeException b <- EUnsafe.try $ run after 408 | EUnsafe.throwIO e1 409 | Right x -> do 410 | _ <- run after 411 | return x 412 | 413 | -- | Like 'onException', but provides the handler the thrown 414 | -- exception. 415 | -- 416 | -- @since 0.1.0.0 417 | withException :: (MonadUnliftIO m, Exception e) 418 | => m a -> (e -> m b) -> m a 419 | withException thing after = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \restore -> do 420 | res1 <- EUnsafe.try $ restore $ run thing 421 | case res1 of 422 | Left e1 -> do 423 | -- see explanation in bracket 424 | _ :: Either SomeException b <- EUnsafe.try $ run $ after e1 425 | EUnsafe.throwIO e1 426 | Right x -> return x 427 | 428 | -- | Like 'finally', but only call @after@ if an exception occurs. 429 | -- 430 | -- @since 0.1.0.0 431 | onException :: MonadUnliftIO m => m a -> m b -> m a 432 | onException thing after = withException thing (\(_ :: SomeException) -> after) 433 | 434 | -- | Synchronously throw the given exception. 435 | -- 436 | -- Note that, if you provide an exception value which is of an asynchronous 437 | -- type, it will be wrapped up in 'SyncExceptionWrapper'. See 'toSyncException'. 438 | -- 439 | -- @since 0.1.0.0 440 | throwIO :: (MonadIO m, Exception e) => e -> m a 441 | throwIO = liftIO . EUnsafe.throwIO . toSyncException 442 | 443 | -- | Convert an exception into a synchronous exception. 444 | -- 445 | -- For synchronous exceptions, this is the same as 'toException'. 446 | -- For asynchronous exceptions, this will wrap up the exception with 447 | -- 'SyncExceptionWrapper'. 448 | -- 449 | -- @since 0.1.0.0 450 | toSyncException :: Exception e => e -> SomeException 451 | toSyncException = 452 | ESafe.toSyncException 453 | 454 | -- | Convert an exception into an asynchronous exception. 455 | -- 456 | -- For asynchronous exceptions, this is the same as 'toException'. 457 | -- For synchronous exceptions, this will wrap up the exception with 458 | -- 'AsyncExceptionWrapper'. 459 | -- 460 | -- @since 0.1.0.0 461 | toAsyncException :: Exception e => e -> SomeException 462 | toAsyncException = 463 | ESafe.toAsyncException 464 | 465 | -- | Convert from a possibly wrapped exception. 466 | -- 467 | -- The inverse of 'toAsyncException' and 'toSyncException'. When using those 468 | -- functions (or functions that use them, like 'throwTo' or 'throwIO'), 469 | -- 'fromException' might not be sufficient because the exception might be 470 | -- wrapped within 'SyncExceptionWrapper' or 'AsyncExceptionWrapper'. 471 | -- 472 | -- @since 0.2.17 473 | fromExceptionUnwrap :: Exception e => SomeException -> Maybe e 474 | fromExceptionUnwrap se 475 | | Just (ESafe.AsyncExceptionWrapper e) <- fromException se = cast e 476 | | Just (ESafe.SyncExceptionWrapper e) <- fromException se = cast e 477 | | otherwise = fromException se 478 | 479 | -- | Check if the given exception is synchronous. 480 | -- 481 | -- @since 0.1.0.0 482 | isSyncException :: Exception e => e -> Bool 483 | isSyncException = 484 | ESafe.isSyncException 485 | 486 | -- | Check if the given exception is asynchronous. 487 | -- 488 | -- @since 0.1.0.0 489 | isAsyncException :: Exception e => e -> Bool 490 | isAsyncException = not . isSyncException 491 | {-# INLINE isAsyncException #-} 492 | 493 | #if !MIN_VERSION_base(4,8,0) 494 | -- | A synonym for 'show', specialized to 'Exception' instances. 495 | -- 496 | -- Starting with base 4.8, the 'Exception' typeclass has a method 497 | -- @displayException@, used for user-friendly display of exceptions. 498 | -- This function provides backwards compatibility for users on base 4.7 and earlier, 499 | -- so that anyone importing this module can simply use @displayException@. 500 | -- 501 | -- @since 0.1.0.0 502 | displayException :: Exception e => e -> String 503 | displayException = show 504 | #endif 505 | 506 | -- | Unlifted version of 'EUnsafe.mask'. 507 | -- 508 | -- @since 0.1.0.0 509 | mask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b 510 | mask f = withRunInIO $ \run -> EUnsafe.mask $ \unmask -> 511 | run $ f $ liftIO . unmask . run 512 | 513 | -- | Unlifted version of 'EUnsafe.uninterruptibleMask'. 514 | -- 515 | -- @since 0.1.0.0 516 | uninterruptibleMask :: MonadUnliftIO m => ((forall a. m a -> m a) -> m b) -> m b 517 | uninterruptibleMask f = withRunInIO $ \run -> EUnsafe.uninterruptibleMask $ \unmask -> 518 | run $ f $ liftIO . unmask . run 519 | 520 | -- | Unlifted version of 'EUnsafe.mask_'. 521 | -- 522 | -- @since 0.1.0.0 523 | mask_ :: MonadUnliftIO m => m a -> m a 524 | mask_ f = withRunInIO $ \run -> EUnsafe.mask_ (run f) 525 | 526 | -- | Unlifted version of 'EUnsafe.uninterruptibleMask_'. 527 | -- 528 | -- @since 0.1.0.0 529 | uninterruptibleMask_ :: MonadUnliftIO m => m a -> m a 530 | uninterruptibleMask_ f = withRunInIO $ \run -> EUnsafe.uninterruptibleMask_ (run f) 531 | 532 | -- | A convenience function for throwing a user error. This is useful 533 | -- for cases where it would be too high a burden to define your own 534 | -- exception type. 535 | -- 536 | -- This throws an exception of type 'StringException'. When GHC 537 | -- supports it (base 4.9 and GHC 8.0 and onward), it includes a call 538 | -- stack. 539 | -- 540 | -- @since 0.1.0.0 541 | #if MIN_VERSION_base(4,9,0) 542 | throwString :: (MonadIO m, HasCallStack) => String -> m a 543 | throwString s = throwIO (StringException s ?callStack) 544 | #else 545 | throwString :: MonadIO m => String -> m a 546 | throwString s = throwIO (StringException s ()) 547 | #endif 548 | 549 | -- | Smart constructor for a 'StringException' that deals with the 550 | -- call stack. 551 | -- 552 | -- @since 0.1.0.0 553 | #if MIN_VERSION_base(4,9,0) 554 | stringException :: HasCallStack => String -> StringException 555 | stringException s = StringException s ?callStack 556 | #else 557 | stringException :: String -> StringException 558 | stringException s = StringException s () 559 | #endif 560 | 561 | -- | Exception type thrown by 'throwString'. 562 | -- 563 | -- Note that the second field of the data constructor depends on 564 | -- GHC/base version. For base 4.9 and GHC 8.0 and later, the second 565 | -- field is a call stack. Previous versions of GHC and base do not 566 | -- support call stacks, and the field is simply unit (provided to make 567 | -- pattern matching across GHC versions easier). 568 | -- 569 | -- @since 0.1.0.0 570 | #if MIN_VERSION_base(4,9,0) 571 | data StringException = StringException String CallStack 572 | deriving Typeable 573 | 574 | -- | @since 0.1.0.0 575 | instance Show StringException where 576 | show (StringException s cs) = concat 577 | $ "UnliftIO.Exception.throwString called with:\n\n" 578 | : s 579 | : "\nCalled from:\n" 580 | : map go (getCallStack cs) 581 | where 582 | go (x, y) = concat 583 | [ " " 584 | , x 585 | , " (" 586 | , prettySrcLoc y 587 | , ")\n" 588 | ] 589 | #else 590 | data StringException = StringException String () 591 | deriving Typeable 592 | 593 | -- | @since 0.1.0.0 594 | instance Show StringException where 595 | show (StringException s _) = "UnliftIO.Exception.throwString called with:\n\n" ++ s 596 | #endif 597 | 598 | -- | @since 0.2.19 599 | instance Eq StringException where 600 | StringException msg1 _ == StringException msg2 _ = msg1 == msg2 601 | 602 | -- | @since 0.1.0.0 603 | instance Exception StringException 604 | 605 | -- | Throw an asynchronous exception to another thread. 606 | -- 607 | -- Synchronously typed exceptions will be wrapped into an 608 | -- `AsyncExceptionWrapper`, see 609 | -- . 610 | -- 611 | -- It's usually a better idea to use the "UnliftIO.Async" module, see 612 | -- . 613 | -- 614 | -- @since 0.1.0.0 615 | throwTo :: (Exception e, MonadIO m) => ThreadId -> e -> m () 616 | throwTo tid = liftIO . EUnsafe.throwTo tid . toAsyncException 617 | 618 | -- | Generate a pure value which, when forced, will synchronously 619 | -- throw the given exception. 620 | -- 621 | -- Generally it's better to avoid using this function and instead use 'throwIO', 622 | -- see . 623 | -- 624 | -- @since 0.1.0.0 625 | impureThrow :: Exception e => e -> a 626 | impureThrow = EUnsafe.throw . toSyncException 627 | 628 | -- | Unwrap an 'Either' value, throwing its 'Left' value as a runtime 629 | -- exception via 'throwIO' if present. 630 | -- 631 | -- @since 0.1.0.0 632 | fromEither :: (Exception e, MonadIO m) => Either e a -> m a 633 | fromEither = either throwIO return 634 | 635 | -- | Same as 'fromEither', but works on an 'IO'-wrapped 'Either'. 636 | -- 637 | -- @since 0.1.0.0 638 | fromEitherIO :: (Exception e, MonadIO m) => IO (Either e a) -> m a 639 | fromEitherIO = fromEitherM . liftIO 640 | 641 | -- | Same as 'fromEither', but works on an 'm'-wrapped 'Either'. 642 | -- 643 | -- @since 0.1.0.0 644 | fromEitherM :: (Exception e, MonadIO m) => m (Either e a) -> m a 645 | fromEitherM = (>>= fromEither) 646 | 647 | -- | Same as 'Control.Exception.mapException', except works in 648 | -- a monadic context. 649 | -- 650 | -- @since 0.2.15 651 | mapExceptionM :: (Exception e1, Exception e2, MonadUnliftIO m) => (e1 -> e2) -> m a -> m a 652 | mapExceptionM f = handle (throwIO . f) 653 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Exception/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | -- | Functions from "Control.Exception.Lens", but using 'MonadUnliftIO', not 6 | -- 'MonadCatch' 7 | module UnliftIO.Exception.Lens 8 | ( catching 9 | , catching_ 10 | , handling 11 | , handling_ 12 | , trying 13 | , trying_ 14 | ) where 15 | 16 | import Prelude 17 | 18 | import Control.Monad.IO.Unlift (MonadUnliftIO) 19 | import Control.Monad (liftM) 20 | import Data.Monoid (First) 21 | import UnliftIO.Exception (SomeException, catchJust, tryJust) 22 | import Control.Applicative (Const(..)) 23 | import Data.Monoid (First(..)) 24 | 25 | #if __GLASGOW_HASKELL__ >= 708 26 | import Data.Coerce 27 | #else 28 | import Unsafe.Coerce 29 | #endif 30 | 31 | -- | 'Control.Exception.Lens.catching' using 'MonadUnliftIO' 32 | -- 33 | -- @since 0.2.25.0 34 | catching :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> (a -> m r) -> m r 35 | catching l = catchJust (preview l) 36 | {-# INLINE catching #-} 37 | 38 | -- | 'Control.Exception.Lens.catching_' using 'MonadUnliftIO' 39 | -- 40 | -- @since 0.2.25.0 41 | catching_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r 42 | catching_ l a b = catchJust (preview l) a (const b) 43 | {-# INLINE catching_ #-} 44 | 45 | -- | 'Control.Exception.Lens.handling' using 'MonadUnliftIO' 46 | -- 47 | -- @since 0.2.25.0 48 | handling :: MonadUnliftIO m => Getting (First a) SomeException a -> (a -> m r) -> m r -> m r 49 | handling l = flip (catching l) 50 | {-# INLINE handling #-} 51 | 52 | -- | 'Control.Exception.Lens.handling_' using 'MonadUnliftIO' 53 | -- 54 | -- @since 0.2.25.0 55 | handling_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m r -> m r 56 | handling_ l = flip (catching_ l) 57 | {-# INLINE handling_ #-} 58 | 59 | -- | 'Control.Exception.Lens.trying' using 'MonadUnliftIO' 60 | -- 61 | -- @since 0.2.25.0 62 | trying :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Either a r) 63 | trying l = tryJust (preview l) 64 | {-# INLINE trying #-} 65 | 66 | -- | 'Control.Exception.Lens.trying_' using 'MonadUnliftIO' 67 | -- 68 | -- @since 0.2.25.0 69 | trying_ :: MonadUnliftIO m => Getting (First a) SomeException a -> m r -> m (Maybe r) 70 | trying_ l m = preview _Right `liftM` trying l m 71 | {-# INLINE trying_ #-} 72 | 73 | -------------------------------------------------------------------------------- 74 | -- Enough of (micro)lens to accomplish this mondule without any dependencies 75 | -- 76 | -- TODO: code review note: should we just bring in microlens? 77 | -------------------------------------------------------------------------------- 78 | type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t 79 | 80 | _Right :: Traversal (Either a b) (Either a b') b b' 81 | _Right f (Right b) = Right <$> f b 82 | _Right _ (Left a) = pure (Left a) 83 | {-# INLINE _Right #-} 84 | 85 | type Getting r s a = (a -> Const r a) -> s -> Const r s 86 | 87 | preview :: Getting (First a) s a -> s -> Maybe a 88 | preview l = getFirst #. foldMapOf l (First #. Just) 89 | {-# INLINE preview #-} 90 | 91 | foldMapOf :: Getting r s a -> (a -> r) -> s -> r 92 | foldMapOf l f = getConst #. l (Const #. f) 93 | {-# INLINE foldMapOf #-} 94 | 95 | #if __GLASGOW_HASKELL__ >= 708 96 | ( #. ) :: Coercible c b => (b -> c) -> (a -> b) -> (a -> c) 97 | ( #. ) _ = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b 98 | #else 99 | ( #. ) :: (b -> c) -> (a -> b) -> (a -> c) 100 | ( #. ) _ = unsafeCoerce 101 | #endif 102 | 103 | {-# INLINE ( #. ) #-} 104 | 105 | infixr 9 #. 106 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/IO.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "System.IO". 2 | -- 3 | -- @since 0.1.0.0 4 | module UnliftIO.IO 5 | ( IOMode (..) 6 | , Handle 7 | , IO.stdin 8 | , IO.stdout 9 | , IO.stderr 10 | , withFile 11 | , withBinaryFile 12 | , openFile 13 | , hClose 14 | , hFlush 15 | , hFileSize 16 | , hSetFileSize 17 | , hIsEOF 18 | , IO.BufferMode (..) 19 | , hSetBuffering 20 | , hGetBuffering 21 | , hSeek 22 | , IO.SeekMode (..) 23 | , hTell 24 | , hIsOpen 25 | , hIsClosed 26 | , hIsReadable 27 | , hIsWritable 28 | , hIsSeekable 29 | , hIsTerminalDevice 30 | , hSetEcho 31 | , hGetEcho 32 | , hWaitForInput 33 | , hReady 34 | , getMonotonicTime 35 | ) where 36 | 37 | import qualified System.IO as IO 38 | import System.IO (Handle, IOMode (..)) 39 | import Control.Monad.IO.Unlift 40 | 41 | import System.IO.Unsafe (unsafePerformIO) 42 | 43 | -- | Unlifted version of 'IO.withFile'. 44 | -- 45 | -- @since 0.1.0.0 46 | withFile :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m a) -> m a 47 | withFile fp mode inner = withRunInIO $ \run -> IO.withFile fp mode $ run . inner 48 | 49 | -- | Unlifted version of 'IO.withBinaryFile'. 50 | -- 51 | -- @since 0.1.0.0 52 | withBinaryFile :: MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m a) -> m a 53 | withBinaryFile fp mode inner = withRunInIO $ \run -> IO.withBinaryFile fp mode $ run . inner 54 | 55 | -- | Lifted version of 'IO.openFile' 56 | -- 57 | -- @since 0.2.20 58 | openFile :: MonadIO m => FilePath -> IOMode -> m Handle 59 | openFile fp = liftIO . IO.openFile fp 60 | 61 | -- | Lifted version of 'IO.hClose' 62 | -- 63 | -- @since 0.2.1.0 64 | hClose :: MonadIO m => Handle -> m () 65 | hClose = liftIO . IO.hClose 66 | 67 | -- | Lifted version of 'IO.hFlush' 68 | -- 69 | -- @since 0.2.1.0 70 | hFlush :: MonadIO m => Handle -> m () 71 | hFlush = liftIO . IO.hFlush 72 | 73 | -- | Lifted version of 'IO.hFileSize' 74 | -- 75 | -- @since 0.2.1.0 76 | hFileSize :: MonadIO m => Handle -> m Integer 77 | hFileSize = liftIO . IO.hFileSize 78 | 79 | -- | Lifted version of 'IO.hSetFileSize' 80 | -- 81 | -- @since 0.2.1.0 82 | hSetFileSize :: MonadIO m => Handle -> Integer -> m () 83 | hSetFileSize h = liftIO . IO.hSetFileSize h 84 | 85 | -- | Lifted version of 'IO.hIsEOF' 86 | -- 87 | -- @since 0.2.1.0 88 | hIsEOF :: MonadIO m => Handle -> m Bool 89 | hIsEOF = liftIO . IO.hIsEOF 90 | 91 | -- | Lifted version of 'IO.hSetBuffering' 92 | -- 93 | -- @since 0.2.1.0 94 | hSetBuffering :: MonadIO m => Handle -> IO.BufferMode -> m () 95 | hSetBuffering h = liftIO . IO.hSetBuffering h 96 | 97 | -- | Lifted version of 'IO.hGetBuffering' 98 | -- 99 | -- @since 0.2.1.0 100 | hGetBuffering :: MonadIO m => Handle -> m IO.BufferMode 101 | hGetBuffering = liftIO . IO.hGetBuffering 102 | 103 | -- | Lifted version of 'IO.hSeek' 104 | -- 105 | -- @since 0.2.1.0 106 | hSeek :: MonadIO m => Handle -> IO.SeekMode -> Integer -> m () 107 | hSeek h s = liftIO . IO.hSeek h s 108 | 109 | -- | Lifted version of 'IO.hTell' 110 | -- 111 | -- @since 0.2.1.0 112 | hTell :: MonadIO m => Handle -> m Integer 113 | hTell = liftIO . IO.hTell 114 | 115 | -- | Lifted version of 'IO.hIsOpen' 116 | -- 117 | -- @since 0.2.1.0 118 | hIsOpen :: MonadIO m => Handle -> m Bool 119 | hIsOpen = liftIO . IO.hIsOpen 120 | 121 | -- | Lifted version of 'IO.hIsClosed' 122 | -- 123 | -- @since 0.2.1.0 124 | hIsClosed :: MonadIO m => Handle -> m Bool 125 | hIsClosed = liftIO . IO.hIsClosed 126 | 127 | -- | Lifted version of 'IO.hIsReadable' 128 | -- 129 | -- @since 0.2.1.0 130 | hIsReadable :: MonadIO m => Handle -> m Bool 131 | hIsReadable = liftIO . IO.hIsReadable 132 | 133 | -- | Lifted version of 'IO.hIsWritable' 134 | -- 135 | -- @since 0.2.1.0 136 | hIsWritable :: MonadIO m => Handle -> m Bool 137 | hIsWritable = liftIO . IO.hIsWritable 138 | 139 | -- | Lifted version of 'IO.hIsSeekable' 140 | -- 141 | -- @since 0.2.1.0 142 | hIsSeekable :: MonadIO m => Handle -> m Bool 143 | hIsSeekable = liftIO . IO.hIsSeekable 144 | 145 | -- | Lifted version of 'IO.hIsTerminalDevice' 146 | -- 147 | -- @since 0.2.1.0 148 | hIsTerminalDevice :: MonadIO m => Handle -> m Bool 149 | hIsTerminalDevice = liftIO . IO.hIsTerminalDevice 150 | 151 | -- | Lifted version of 'IO.hSetEcho' 152 | -- 153 | -- @since 0.2.1.0 154 | hSetEcho :: MonadIO m => Handle -> Bool -> m () 155 | hSetEcho h = liftIO . IO.hSetEcho h 156 | 157 | -- | Lifted version of 'IO.hGetEcho' 158 | -- 159 | -- @since 0.2.1.0 160 | hGetEcho :: MonadIO m => Handle -> m Bool 161 | hGetEcho = liftIO . IO.hGetEcho 162 | 163 | -- | Lifted version of 'IO.hWaitForInput' 164 | -- 165 | -- @since 0.2.1.0 166 | hWaitForInput :: MonadIO m => Handle -> Int -> m Bool 167 | hWaitForInput h = liftIO . IO.hWaitForInput h 168 | 169 | -- | Lifted version of 'IO.hReady' 170 | -- 171 | -- @since 0.2.1.0 172 | hReady :: MonadIO m => Handle -> m Bool 173 | hReady = liftIO . IO.hReady 174 | 175 | -- | Get the number of seconds which have passed since an arbitrary starting 176 | -- time, useful for calculating runtime in a program. 177 | -- 178 | -- @since 0.2.3.0 179 | getMonotonicTime :: MonadIO m => m Double 180 | getMonotonicTime = liftIO $ initted `seq` getMonotonicTime' 181 | 182 | -- | Set up time measurement. 183 | foreign import ccall unsafe "unliftio_inittime" initializeTime :: IO () 184 | 185 | initted :: () 186 | initted = unsafePerformIO initializeTime 187 | {-# NOINLINE initted #-} 188 | 189 | foreign import ccall unsafe "unliftio_gettime" getMonotonicTime' :: IO Double 190 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/IO/File.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-| 3 | 4 | == Rationale 5 | 6 | This module offers functions to handle files that offer better durability and/or 7 | atomicity. 8 | 9 | == When to use functions in this module? 10 | 11 | Given the usage of this functions comes at a cost in performance, it is important to 12 | consider what are the use cases that are ideal for each of the functions. 13 | 14 | === Not Durable and not Atomic 15 | 16 | For this use case, you want to use the regular functions: 17 | 18 | * 'withBinaryFile' 19 | * 'writeBinaryFile' 20 | 21 | The regular use case for this scenario happens when your program is dealing with outputs 22 | that are never going to be consumed again by your program. For example, imagine you have a 23 | program that generates sales reports for the last month, this is a report that can be 24 | generated quickly; you don't really care if the output file gets corrupted or lost at one 25 | particular execution of your program given that is cheap to execute the data export 26 | program a second time. In other words, your program doesn't /rely/ on the data contained 27 | in this file in order to work. 28 | 29 | === Atomic but not Durable 30 | 31 | Imagine a scenario where your program builds a temporary file that serves as an 32 | intermediate step to a bigger task, like Object files (@.o@) in a compilation process. The 33 | program will use an existing @.o@ file if it is present, or it will build one from scratch 34 | if it is not. The file is not really required, but if it is present, it *must* be valid 35 | and consistent. In this situation, you care about atomicity, but not durability. You can 36 | use the functions for such scenario: 37 | 38 | * 'withBinaryFileAtomic' 39 | * 'writeBinaryFileAtomic' 40 | 41 | __Note__ - there is a peculiar difference between regular file writing functionality and 42 | the one that is done atomically. Even if the orignal file is removed while it is being 43 | modified, because of atomicity, it will be restored with all modifications, if any. The 44 | reason for this is because a copy of the file was made prior to modifications and at the 45 | end the existing is atomically replaced. An important consequence of this fact is that 46 | whenever the folder containing the file which is being modified is removed, all bets are 47 | off and all atomic functions will result in an exception. 48 | 49 | === Durable but not Atomic 50 | 51 | For this use case, you want to use the functions: 52 | 53 | * 'withBinaryFileDurable' 54 | * 'writeBinaryFileDurable' 55 | 56 | The regular use case for this scenario happens when your program deals with file 57 | modifications that must be guaranteed to be durable, but you don't care that changes are 58 | consistent. If you use this function, more than likely your program is ensuring 59 | consistency guarantees through other means, for example, SQLite uses the Write Ahead Log 60 | (WAL) algorithm to ensure changes are atomic at an application level. 61 | 62 | === Durable and Atomic 63 | 64 | For this use case, you can use the functions: 65 | 66 | * 'withBinaryFileDurableAtomic' 67 | * 'writeBinaryFileDurableAtomic' 68 | 69 | The regular use case for this scenario happens when you want to ensure that after a 70 | program is executed, the modifications done to a file are guaranteed to be saved, and also 71 | that changes are rolled-back in case there is a failure (e.g. hard reboot, shutdown, 72 | etc). 73 | 74 | -} 75 | module UnliftIO.IO.File 76 | ( writeBinaryFile 77 | , writeBinaryFileAtomic 78 | , writeBinaryFileDurable 79 | , writeBinaryFileDurableAtomic 80 | , withBinaryFile 81 | , withBinaryFileAtomic 82 | , withBinaryFileDurable 83 | , withBinaryFileDurableAtomic 84 | , ensureFileDurable 85 | ) 86 | where 87 | 88 | import Data.ByteString as B (ByteString, writeFile) 89 | import Control.Monad.IO.Unlift 90 | import UnliftIO.IO (Handle, IOMode(..), withBinaryFile) 91 | 92 | #if WINDOWS 93 | 94 | 95 | ensureFileDurable = (`seq` pure ()) 96 | 97 | writeBinaryFileDurable = writeBinaryFile 98 | writeBinaryFileDurableAtomic = writeBinaryFile 99 | writeBinaryFileAtomic = writeBinaryFile 100 | 101 | withBinaryFileDurable = withBinaryFile 102 | withBinaryFileDurableAtomic = withBinaryFile 103 | withBinaryFileAtomic = withBinaryFile 104 | 105 | #else 106 | 107 | import qualified Data.ByteString as B (hPut) 108 | import qualified UnliftIO.IO.File.Posix as Posix 109 | 110 | ensureFileDurable = Posix.ensureFileDurable 111 | 112 | writeBinaryFileDurable fp bytes = 113 | liftIO $ withBinaryFileDurable fp WriteMode (`B.hPut` bytes) 114 | writeBinaryFileDurableAtomic fp bytes = 115 | liftIO $ withBinaryFileDurableAtomic fp WriteMode (`B.hPut` bytes) 116 | writeBinaryFileAtomic fp bytes = 117 | liftIO $ withBinaryFileAtomic fp WriteMode (`B.hPut` bytes) 118 | 119 | withBinaryFileDurable = Posix.withBinaryFileDurable 120 | withBinaryFileDurableAtomic = Posix.withBinaryFileDurableAtomic 121 | withBinaryFileAtomic = Posix.withBinaryFileAtomic 122 | #endif 123 | 124 | -- | After a file is closed, this function opens it again and executes @fsync()@ 125 | -- internally on both the file and the directory that contains it. Note that this function 126 | -- is intended to work around the non-durability of existing file APIs, as opposed to 127 | -- being necessary for the API functions provided in this module. 128 | -- 129 | -- [The effectiveness of calling this function is 130 | -- debatable](https://stackoverflow.com/questions/37288453/calling-fsync2-after-close2/50158433#50158433), 131 | -- as it relies on internal implementation details at the Kernel level that might 132 | -- change. We argue that, despite this fact, calling this function may bring benefits in 133 | -- terms of durability. 134 | -- 135 | -- This function does not provide the same guarantee as if you would open and modify a 136 | -- file using `withBinaryFileDurable` or `writeBinaryFileDurable`, since they ensure that 137 | -- the @fsync()@ is called before the file is closed, so if possible use those instead. 138 | -- 139 | -- === Cross-Platform support 140 | -- 141 | -- This function is a noop on Windows platforms. 142 | -- 143 | -- @since 0.2.12 144 | ensureFileDurable :: MonadIO m => FilePath -> m () 145 | -- Implementation is at the top of the module 146 | 147 | 148 | -- | Similar to 'writeBinaryFile', but it also ensures that changes executed to the file 149 | -- are guaranteed to be durable. It internally uses @fsync()@ and makes sure it 150 | -- synchronizes the file on disk. 151 | -- 152 | -- === Cross-Platform support 153 | -- 154 | -- This function behaves the same as 'RIO.writeBinaryFile' on Windows platforms. 155 | -- 156 | -- @since 0.2.12 157 | writeBinaryFileDurable :: MonadIO m => FilePath -> ByteString -> m () 158 | -- Implementation is at the top of the module 159 | 160 | -- | Similar to 'writeBinaryFile', but it also guarantes that changes executed to the file 161 | -- are durable, also, in case of failure, the modified file is never going to get 162 | -- corrupted. It internally uses @fsync()@ and makes sure it synchronizes the file on 163 | -- disk. 164 | -- 165 | -- === Cross-Platform support 166 | -- 167 | -- This function behaves the same as 'writeBinaryFile' on Windows platforms. 168 | -- 169 | -- @since 0.2.12 170 | writeBinaryFileDurableAtomic :: MonadIO m => FilePath -> ByteString -> m () 171 | -- Implementation is at the top of the module 172 | 173 | -- | Same as 'writeBinaryFileDurableAtomic', except it does not guarantee durability. 174 | -- 175 | -- === Cross-Platform support 176 | -- 177 | -- This function behaves the same as 'writeBinaryFile' on Windows platforms. 178 | -- 179 | -- @since 0.2.12 180 | writeBinaryFileAtomic :: MonadIO m => FilePath -> ByteString -> m () 181 | -- Implementation is at the top of the module 182 | 183 | -- | Opens a file with the following guarantees: 184 | -- 185 | -- * It successfully closes the file in case of an asynchronous exception 186 | -- 187 | -- * It reliably saves the file in the correct directory; including edge case situations 188 | -- like a different device being mounted to the current directory, or the current 189 | -- directory being renamed to some other name while the file is being used. 190 | -- 191 | -- * It ensures durability by executing an @fsync()@ call before closing the file handle 192 | -- 193 | -- === Cross-Platform support 194 | -- 195 | -- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms. 196 | -- 197 | -- @since 0.2.12 198 | withBinaryFileDurable :: 199 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 200 | -- Implementation is at the top of the module 201 | 202 | -- | Opens a file with the following guarantees: 203 | -- 204 | -- * It successfully closes the file in case of an asynchronous exception 205 | -- 206 | -- * It reliably saves the file in the correct directory; including edge case situations 207 | -- like a different device being mounted to the current directory, or the current 208 | -- directory being renamed to some other name while the file is being used. 209 | -- 210 | -- * It ensures durability by executing an @fsync()@ call before closing the file handle 211 | -- 212 | -- * It keeps all changes in a temporary file, and after it is closed it atomically moves 213 | -- the temporary file to the original filepath, in case of catastrophic failure, the 214 | -- original file stays unaffected. 215 | -- 216 | -- If you do not need durability but only atomicity, use `withBinaryFileAtomic` instead, 217 | -- which is faster as it does not perform @fsync()@. 218 | -- 219 | -- __Important__ - Make sure not to close the `Handle`, it will be closed for you, 220 | -- otherwise it will result in @invalid argument (Bad file descriptor)@ exception. 221 | -- 222 | -- === Performance Considerations 223 | -- 224 | -- When using a writable but non-truncating 'IOMode' (i.e. 'ReadWriteMode' and 225 | -- 'AppendMode'), this function performs a copy operation of the specified input file to 226 | -- guarantee the original file is intact in case of a catastrophic failure (no partial 227 | -- writes). This approach may be prohibitive in scenarios where the input file is expected 228 | -- to be large in size. 229 | -- 230 | -- === Cross-Platform support 231 | -- 232 | -- This function behaves the same as 'System.IO.withBinaryFile' on Windows platforms. 233 | -- 234 | -- @since 0.2.12 235 | withBinaryFileDurableAtomic :: 236 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 237 | -- Implementation is at the top of the module 238 | 239 | 240 | -- | Perform an action on a new or existing file at the destination file path. If 241 | -- previously the file existed at the supplied file path then: 242 | -- 243 | -- * in case of `WriteMode` it will be overwritten 244 | -- 245 | -- * upon `ReadWriteMode` or `AppendMode` files contents will be copied over into a 246 | -- temporary file, thus making sure no corruption can happen to an existing file upon any 247 | -- failures, even catastrophic one, yet its contents are availble for modification. 248 | -- 249 | -- * There is nothing atomic about `ReadMode`, so no special treatment there. 250 | -- 251 | -- It is similar to `withBinaryFileDurableAtomic`, but without the durability part. It 252 | -- means that all modification can still disappear after it has been succesfully written 253 | -- due to some extreme event like an abrupt power loss, but the contents will not be 254 | -- corrupted in case when the file write did not end successfully. 255 | -- 256 | -- The same performance caveats apply as for `withBinaryFileDurableAtomic` due to making a 257 | -- copy of the content of existing files during non-truncating writes. 258 | -- 259 | -- __Important__ - Do not close the handle, otherwise it will result in @invalid argument 260 | -- (Bad file descriptor)@ exception 261 | -- 262 | -- __Note__ - on Linux operating system and only with supported file systems an anonymous 263 | -- temporary file will be used while working on the file (see @O_TMPFILE@ in @man 264 | -- openat@). In case when such feature is not available or not supported a temporary file 265 | -- ".target-file-nameXXX.ext.tmp", where XXX is some random number, will be created 266 | -- alongside the target file in the same directory 267 | -- 268 | -- @since 0.2.12 269 | withBinaryFileAtomic :: 270 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 271 | -- Implementation is at the top of the module 272 | 273 | 274 | -- | Lifted version of `B.writeFile` 275 | -- 276 | -- @since 0.2.12 277 | writeBinaryFile :: MonadIO m => FilePath -> ByteString -> m () 278 | writeBinaryFile fp = liftIO . B.writeFile fp 279 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/IO/File/Posix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | module UnliftIO.IO.File.Posix 8 | ( withBinaryFileDurable 9 | , withBinaryFileDurableAtomic 10 | , withBinaryFileAtomic 11 | , ensureFileDurable 12 | ) 13 | where 14 | 15 | #if __GLASGOW_HASKELL__ < 710 16 | import Control.Applicative 17 | #endif 18 | import Control.Monad (forM_, guard, unless, void, when) 19 | import Control.Monad.IO.Unlift 20 | import Data.Bits (Bits, (.|.)) 21 | import Data.ByteString (ByteString) 22 | import Data.Maybe (fromMaybe) 23 | import Data.Typeable (cast) 24 | import Foreign (allocaBytes) 25 | import Foreign.C (CInt(..), throwErrnoIfMinus1, throwErrnoIfMinus1Retry, 26 | throwErrnoIfMinus1Retry_) 27 | import GHC.IO.Device (IODeviceType(RegularFile)) 28 | import qualified GHC.IO.Device as Device 29 | import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) 30 | import qualified GHC.IO.FD as FD 31 | import qualified GHC.IO.Handle.FD as HandleFD 32 | import qualified GHC.IO.Handle.Types as HandleFD (Handle(..), Handle__(..)) 33 | import System.Directory (removeFile) 34 | import System.FilePath (takeDirectory, takeFileName) 35 | import System.IO (Handle, IOMode(..), SeekMode(..), hGetBuf, hPutBuf, 36 | openBinaryTempFile) 37 | import System.IO.Error (ioeGetErrorType, isAlreadyExistsError, 38 | isDoesNotExistError) 39 | import qualified System.Posix.Files as Posix 40 | import System.Posix.Internals (CFilePath, c_close, c_safe_open, withFilePath) 41 | import System.Posix.Types (CMode(..), Fd(..), FileMode) 42 | import UnliftIO.Exception 43 | import UnliftIO.IO 44 | import UnliftIO.MVar 45 | 46 | -- NOTE: System.Posix.Internal doesn't re-export this constants so we have to 47 | -- recreate-them here 48 | 49 | newtype CFlag = 50 | CFlag CInt 51 | deriving (Eq, Show, Bits) 52 | 53 | foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CFlag 54 | foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CFlag 55 | foreign import ccall unsafe "HsBase.h __hscore_o_rdwr" o_RDWR :: CFlag 56 | foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CFlag 57 | foreign import ccall unsafe "HsBase.h __hscore_o_creat" o_CREAT :: CFlag 58 | foreign import ccall unsafe "HsBase.h __hscore_o_noctty" o_NOCTTY :: CFlag 59 | 60 | -- After here, we have our own imports 61 | 62 | -- On non-Linux operating systems that do not support `O_TMPFILE` the value of 63 | -- `o_TMPFILE` will be 0, which is then used to fallback onto a different 64 | -- implementation of temporary files. 65 | foreign import ccall unsafe "file-posix.c unliftio_o_tmpfile" o_TMPFILE :: CFlag 66 | 67 | 68 | -- | Whenever Operating System does not support @O_TMPFILE@ flag and anonymous 69 | -- temporary files then `o_TMPFILE` flag will be set to @0@ 70 | o_TMPFILE_not_supported :: CFlag 71 | o_TMPFILE_not_supported = CFlag 0 72 | 73 | newtype CAt = CAt 74 | { unCAt :: CInt 75 | } deriving (Eq, Show, Bits) 76 | 77 | foreign import ccall unsafe "file-posix.c unliftio_at_fdcwd" at_FDCWD :: CAt 78 | foreign import ccall unsafe "file-posix.c unliftio_at_symlink_follow" at_SYMLINK_FOLLOW :: CAt 79 | foreign import ccall unsafe "file-posix.c unliftio_s_irusr" s_IRUSR :: CMode 80 | foreign import ccall unsafe "file-posix.c unliftio_s_iwusr" s_IWUSR :: CMode 81 | 82 | c_open :: CFilePath -> CFlag -> CMode -> IO CInt 83 | c_open fp (CFlag flags) = c_safe_open fp flags 84 | 85 | foreign import ccall safe "fcntl.h openat" 86 | c_safe_openat :: CInt -> CFilePath -> CInt -> CMode -> IO CInt 87 | 88 | c_openat :: DirFd -> CFilePath -> CFlag -> CMode -> IO CInt 89 | c_openat (DirFd (Fd fd)) fp (CFlag flags) = c_safe_openat fd fp flags 90 | 91 | foreign import ccall safe "fcntl.h renameat" 92 | c_safe_renameat :: CInt -> CFilePath -> CInt -> CFilePath -> IO CInt 93 | 94 | c_renameat :: DirFd -> CFilePath -> DirFd -> CFilePath -> IO CInt 95 | c_renameat (DirFd (Fd fdFrom)) cFpFrom (DirFd (Fd fdTo)) cFpTo = 96 | c_safe_renameat fdFrom cFpFrom fdTo cFpTo 97 | 98 | foreign import ccall safe "unistd.h fsync" 99 | c_safe_fsync :: CInt -> IO CInt 100 | 101 | c_fsync :: Fd -> IO CInt 102 | c_fsync (Fd fd) = c_safe_fsync fd 103 | 104 | foreign import ccall safe "unistd.h linkat" 105 | c_safe_linkat :: CInt -> CFilePath -> CInt -> CFilePath -> CInt -> IO CInt 106 | 107 | c_linkat :: CAt -> CFilePath -> Either DirFd CAt -> CFilePath -> CAt -> IO CInt 108 | c_linkat cat oldPath eNewDir newPath (CAt flags) = 109 | c_safe_linkat (unCAt cat) oldPath newDir newPath flags 110 | where 111 | unFd (Fd fd) = fd 112 | newDir = either (unFd . unDirFd) unCAt eNewDir 113 | 114 | std_flags, output_flags, read_flags, write_flags, rw_flags, 115 | append_flags :: CFlag 116 | std_flags = o_NOCTTY 117 | output_flags = std_flags .|. o_CREAT 118 | read_flags = std_flags .|. o_RDONLY 119 | write_flags = output_flags .|. o_WRONLY 120 | rw_flags = output_flags .|. o_RDWR 121 | append_flags = write_flags .|. o_APPEND 122 | 123 | ioModeToFlags :: IOMode -> CFlag 124 | ioModeToFlags iomode = 125 | case iomode of 126 | ReadMode -> read_flags 127 | WriteMode -> write_flags 128 | ReadWriteMode -> rw_flags 129 | AppendMode -> append_flags 130 | 131 | newtype DirFd = DirFd 132 | { unDirFd :: Fd 133 | } 134 | 135 | -- | Returns a low-level file descriptor for a directory path. This function 136 | -- exists given the fact that 'openFile' does not work with directories. 137 | -- 138 | -- If you use this function, make sure you are working on a masked state, 139 | -- otherwise async exceptions may leave file descriptors open. 140 | openDir :: MonadIO m => FilePath -> m Fd 141 | openDir fp 142 | -- TODO: Investigate what is the situation with Windows FS in regards to non_blocking 143 | -- NOTE: File operations _do not support_ non_blocking on various kernels, more 144 | -- info can be found here: https://ghc.haskell.org/trac/ghc/ticket/15153 145 | = 146 | liftIO $ 147 | withFilePath fp $ \cFp -> 148 | Fd <$> 149 | throwErrnoIfMinus1Retry 150 | "openDir" 151 | (c_open cFp (ioModeToFlags ReadMode) 0o660) 152 | 153 | -- | Closes a 'Fd' that points to a Directory. 154 | closeDirectory :: MonadIO m => DirFd -> m () 155 | closeDirectory (DirFd (Fd dirFd)) = 156 | liftIO $ 157 | throwErrnoIfMinus1Retry_ "closeDirectory" $ c_close dirFd 158 | 159 | -- | Executes the low-level C function fsync on a C file descriptor 160 | fsyncFileDescriptor 161 | :: MonadIO m 162 | => String -- ^ Meta-description for error messages 163 | -> Fd -- ^ C File Descriptor 164 | -> m () 165 | fsyncFileDescriptor name fd = 166 | liftIO $ void $ throwErrnoIfMinus1 ("fsync - " ++ name) $ c_fsync fd 167 | 168 | -- | Call @fsync@ on the file handle. Accepts an arbitary string for error reporting. 169 | fsyncFileHandle :: String -> Handle -> IO () 170 | fsyncFileHandle fname hdl = withHandleFd hdl (fsyncFileDescriptor (fname ++ "/File")) 171 | 172 | 173 | -- | Call @fsync@ on the opened directory file descriptor. Accepts an arbitary 174 | -- string for error reporting. 175 | fsyncDirectoryFd :: String -> DirFd -> IO () 176 | fsyncDirectoryFd fname = fsyncFileDescriptor (fname ++ "/Directory") . unDirFd 177 | 178 | 179 | -- | Opens a file from a directory, using this function in favour of a regular 180 | -- 'openFile' guarantees that any file modifications are kept in the same 181 | -- directory where the file was opened. An edge case scenario is a mount 182 | -- happening in the directory where the file was opened while your program is 183 | -- running. 184 | -- 185 | -- If you use this function, make sure you are working on an masked state, 186 | -- otherwise async exceptions may leave file descriptors open. 187 | -- 188 | openFileFromDir :: MonadIO m => DirFd -> FilePath -> IOMode -> m Handle 189 | openFileFromDir dirFd filePath@(takeFileName -> fileName) iomode = 190 | liftIO $ 191 | withFilePath fileName $ \cFileName -> 192 | bracketOnError 193 | (do fileFd <- 194 | throwErrnoIfMinus1Retry "openFileFromDir" $ 195 | c_openat dirFd cFileName (ioModeToFlags iomode) 0o666 196 | {- Can open directory with read only -} 197 | FD.mkFD 198 | fileFd 199 | iomode 200 | Nothing {- no stat -} 201 | False {- not a socket -} 202 | False {- non_blocking -} 203 | `onException` 204 | c_close fileFd) 205 | (liftIO . Device.close . fst) 206 | (\(fD, fd_type) 207 | -- we want to truncate() if this is an open in WriteMode, but only if the 208 | -- target is a RegularFile. ftruncate() fails on special files like 209 | -- /dev/null. 210 | -> do 211 | when (iomode == WriteMode && fd_type == RegularFile) $ 212 | Device.setSize fD 0 213 | HandleFD.mkHandleFromFD fD fd_type filePath iomode False Nothing) 214 | 215 | 216 | -- | Similar to `openFileFromDir`, but will open an anonymous (nameless) 217 | -- temporary file in the supplied directory 218 | openAnonymousTempFileFromDir :: 219 | MonadIO m => 220 | Maybe DirFd 221 | -- ^ If a file descriptor is given for the directory where the target file is/will be 222 | -- located in, then it will be used for opening an anonymous file. Otherwise 223 | -- anonymous will be opened unattached to any file path. 224 | -> FilePath 225 | -- ^ File path of the target file that we are working on. 226 | -> IOMode 227 | -> m Handle 228 | openAnonymousTempFileFromDir mDirFd filePath iomode = 229 | liftIO $ 230 | case mDirFd of 231 | Just dirFd -> withFilePath "." (openAnonymousWith . c_openat dirFd) 232 | Nothing -> 233 | withFilePath (takeDirectory filePath) (openAnonymousWith . c_open) 234 | where 235 | fdName = "openAnonymousTempFileFromDir - " ++ filePath 236 | ioModeToTmpFlags :: IOMode -> CFlag 237 | ioModeToTmpFlags = 238 | \case 239 | ReadMode -> o_RDWR -- It is an error to create a O_TMPFILE with O_RDONLY 240 | ReadWriteMode -> o_RDWR 241 | _ -> o_WRONLY 242 | openAnonymousWith fopen = 243 | bracketOnError 244 | (do fileFd <- 245 | throwErrnoIfMinus1Retry "openAnonymousTempFileFromDir" $ 246 | fopen (o_TMPFILE .|. ioModeToTmpFlags iomode) (s_IRUSR .|. s_IWUSR) 247 | FD.mkFD 248 | fileFd 249 | iomode 250 | Nothing {- no stat -} 251 | False {- not a socket -} 252 | False {- non_blocking -} 253 | `onException` 254 | c_close fileFd) 255 | (liftIO . Device.close . fst) 256 | (\(fD, fd_type) -> 257 | HandleFD.mkHandleFromFD fD fd_type fdName iomode False Nothing) 258 | 259 | 260 | atomicDurableTempFileRename :: 261 | DirFd -> Maybe FileMode -> Handle -> Maybe FilePath -> FilePath -> IO () 262 | atomicDurableTempFileRename dirFd mFileMode tmpFileHandle mTmpFilePath filePath = do 263 | fsyncFileHandle "atomicDurableTempFileCreate" tmpFileHandle 264 | -- at this point we know that the content has been persisted to the storage it 265 | -- is safe to do the atomic move/replace 266 | let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath 267 | atomicTempFileRename (Just dirFd) mFileMode eTmpFile filePath 268 | -- Important to close the handle, so the we can fsync the directory 269 | hClose tmpFileHandle 270 | -- file path is updated, now we can fsync the directory 271 | fsyncDirectoryFd "atomicDurableTempFileCreate" dirFd 272 | 273 | 274 | -- | There will be an attempt to atomically convert an invisible temporary file 275 | -- into a target file at the supplied file path. In case when there is already a 276 | -- file at that file path, a new visible temporary file will be created in the 277 | -- same folder and then atomically renamed into the target file path, replacing 278 | -- any existing file. This is necessary since `c_safe_linkat` cannot replace 279 | -- files atomically and we have to fall back onto `c_safe_renameat`. This should 280 | -- not be a problem in practice, since lifetime of such visible file is 281 | -- extremely short and it will be cleaned up regardless of the outcome of the 282 | -- rename. 283 | -- 284 | -- It is important to note, that whenever a file descriptor for the containing 285 | -- directory is supplied, renaming and linking will be done in its context, 286 | -- thus allowing to do proper fsyncing if durability is necessary. 287 | -- 288 | -- __NOTE__: this function will work only on Linux. 289 | -- 290 | atomicTempFileCreate :: 291 | Maybe DirFd 292 | -- ^ Possible handle for the directory where the target file is located. Which 293 | -- means that the file is already in that directory, just without a name. In other 294 | -- words it was opened before with `openAnonymousTempFileFromDir` 295 | -> Maybe FileMode 296 | -- ^ If file permissions are supplied they will be set on the new file prior 297 | -- to atomic rename. 298 | -> Handle 299 | -- ^ Handle to the anonymous temporary file created with `c_openat` and 300 | -- `o_TMPFILE` 301 | -> FilePath 302 | -- ^ File path for the target file. 303 | -> IO () 304 | atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath = 305 | withHandleFd tmpFileHandle $ \fd@(Fd cFd) -> 306 | withFilePath ("/proc/self/fd/" ++ show cFd) $ \cFromFilePath -> 307 | withFilePath filePathName $ \cToFilePath -> do 308 | let fileMode = fromMaybe Posix.stdFileMode mFileMode 309 | -- work around for the glibc bug: https://sourceware.org/bugzilla/show_bug.cgi?id=17523 310 | Posix.setFdMode fd fileMode 311 | let safeLink which to = 312 | throwErrnoIfMinus1Retry_ 313 | ("atomicFileCreate - c_safe_linkat - " ++ which) $ 314 | -- see `man linkat` and `man openat` for more info 315 | c_linkat at_FDCWD cFromFilePath cDirFd to at_SYMLINK_FOLLOW 316 | eExc <- 317 | tryJust (guard . isAlreadyExistsError) $ 318 | safeLink "anonymous" cToFilePath 319 | case eExc of 320 | Right () -> pure () 321 | Left () -> 322 | withBinaryTempFileFor filePath $ \visTmpFileName visTmpFileHandle -> do 323 | hClose visTmpFileHandle 324 | removeFile visTmpFileName 325 | case mDirFd of 326 | Nothing -> do 327 | withFilePath visTmpFileName (safeLink "visible") 328 | Posix.rename visTmpFileName filePath 329 | Just dirFd -> 330 | withFilePath (takeFileName visTmpFileName) $ \cVisTmpFile -> do 331 | safeLink "visible" cVisTmpFile 332 | throwErrnoIfMinus1Retry_ 333 | "atomicFileCreate - c_safe_renameat" $ 334 | c_renameat dirFd cVisTmpFile dirFd cToFilePath 335 | where 336 | (cDirFd, filePathName) = 337 | case mDirFd of 338 | Nothing -> (Right at_FDCWD, filePath) 339 | Just dirFd -> (Left dirFd, takeFileName filePath) 340 | 341 | atomicTempFileRename :: 342 | Maybe DirFd 343 | -- ^ Possible handle for the directory where the target file is located. 344 | -> Maybe FileMode 345 | -- ^ If file permissions are supplied they will be set on the new file prior 346 | -- to atomic rename. 347 | -> Either Handle FilePath 348 | -- ^ Temporary file. If a handle is supplied, it means it was opened with 349 | -- @O_TMPFILE@ flag and thus we are on the Linux OS and can safely call 350 | -- `atomicTempFileCreate` 351 | -> FilePath 352 | -- ^ File path for the target file. Whenever `DirFd` is supplied, it must be 353 | -- the containgin directory fo this file, but that invariant is not enforced 354 | -- within this function. 355 | -> IO () 356 | atomicTempFileRename mDirFd mFileMode eTmpFile filePath = 357 | case eTmpFile of 358 | Left tmpFileHandle -> 359 | atomicTempFileCreate mDirFd mFileMode tmpFileHandle filePath 360 | Right tmpFilePath -> do 361 | forM_ mFileMode $ \fileMode -> Posix.setFileMode tmpFilePath fileMode 362 | case mDirFd of 363 | Nothing -> Posix.rename tmpFilePath filePath 364 | Just dirFd -> 365 | withFilePath (takeFileName filePath) $ \cToFilePath -> 366 | withFilePath (takeFileName tmpFilePath) $ \cTmpFilePath -> 367 | throwErrnoIfMinus1Retry_ "atomicFileCreate - c_safe_renameat" $ 368 | c_renameat dirFd cTmpFilePath dirFd cToFilePath 369 | 370 | 371 | withDirectory :: MonadUnliftIO m => FilePath -> (DirFd -> m a) -> m a 372 | withDirectory dirPath = bracket (DirFd <$> openDir dirPath) closeDirectory 373 | 374 | withFileInDirectory :: 375 | MonadUnliftIO m => DirFd -> FilePath -> IOMode -> (Handle -> m a) -> m a 376 | withFileInDirectory dirFd filePath iomode = 377 | bracket (openFileFromDir dirFd filePath iomode) hClose 378 | 379 | 380 | -- | Create a temporary file for a matching possibly exiting target file that 381 | -- will be replaced in the future. Temporary file is meant to be renamed 382 | -- afterwards, thus it is only deleted upon error. 383 | -- 384 | -- __Important__: Temporary file is not removed and file handle is not closed if 385 | -- there was no exception thrown by the supplied action. 386 | withBinaryTempFileFor :: 387 | MonadUnliftIO m 388 | => FilePath 389 | -- ^ "For" file. It may exist or may not. 390 | -> (FilePath -> Handle -> m a) 391 | -> m a 392 | withBinaryTempFileFor filePath action = 393 | bracketOnError 394 | (liftIO (openBinaryTempFile dirPath tmpFileName)) 395 | (\(tmpFilePath, tmpFileHandle) -> 396 | hClose tmpFileHandle >> liftIO (tryIO (removeFile tmpFilePath))) 397 | (uncurry action) 398 | where 399 | dirPath = takeDirectory filePath 400 | fileName = takeFileName filePath 401 | tmpFileName = "." ++ fileName ++ ".tmp" 402 | 403 | -- | Returns `Nothing` if anonymous temporary file is not supported by the OS or 404 | -- the underlying file system can't handle that feature. 405 | withAnonymousBinaryTempFileFor :: 406 | MonadUnliftIO m 407 | => Maybe DirFd 408 | -- ^ It is possible to open the temporary file in the context of a directory, 409 | -- in such case supply its file descriptor. i.e. @openat@ will be used instead 410 | -- of @open@ 411 | -> FilePath 412 | -- ^ "For" file. The file may exist or may not. 413 | -> IOMode 414 | -> (Handle -> m a) 415 | -> m (Maybe a) 416 | withAnonymousBinaryTempFileFor mDirFd filePath iomode action 417 | | o_TMPFILE == o_TMPFILE_not_supported = pure Nothing 418 | | otherwise = 419 | trySupported $ 420 | bracket (openAnonymousTempFileFromDir mDirFd filePath iomode) hClose action 421 | where 422 | trySupported m = 423 | tryIO m >>= \case 424 | Right res -> pure $ Just res 425 | Left exc 426 | | ioeGetErrorType exc == UnsupportedOperation -> pure Nothing 427 | Left exc -> throwIO exc 428 | 429 | withNonAnonymousBinaryTempFileFor :: 430 | MonadUnliftIO m 431 | => Maybe DirFd 432 | -- ^ It is possible to open the temporary file in the context of a directory, 433 | -- in such case supply its file descriptor. i.e. @openat@ will be used instead 434 | -- of @open@ 435 | -> FilePath 436 | -- ^ "For" file. The file may exist or may not. 437 | -> IOMode 438 | -> (FilePath -> Handle -> m a) 439 | -> m a 440 | withNonAnonymousBinaryTempFileFor mDirFd filePath iomode action = 441 | withBinaryTempFileFor filePath $ \tmpFilePath tmpFileHandle -> do 442 | hClose tmpFileHandle 443 | case mDirFd of 444 | Nothing -> withBinaryFile tmpFilePath iomode (action tmpFilePath) 445 | Just dirFd -> withFileInDirectory dirFd tmpFilePath iomode (action tmpFilePath) 446 | 447 | -- | Copy the contents of the file into the handle, but only if that file exists 448 | -- and either `ReadWriteMode` or `AppendMode` is specified. Returned are the 449 | -- file permissions of the original file so it can be set later when original 450 | -- gets overwritten atomically. 451 | copyFileHandle :: 452 | MonadUnliftIO f => IOMode -> FilePath -> Handle -> f (Maybe FileMode) 453 | copyFileHandle iomode fromFilePath toHandle = 454 | either (const Nothing) Just <$> 455 | tryJust 456 | (guard . isDoesNotExistError) 457 | (do fileStatus <- liftIO $ Posix.getFileStatus fromFilePath 458 | -- Whenever we are not overwriting an existing file, we also need a 459 | -- copy of the file's contents 460 | unless (iomode == WriteMode) $ do 461 | withBinaryFile fromFilePath ReadMode (`copyHandleData` toHandle) 462 | unless (iomode == AppendMode) $ hSeek toHandle AbsoluteSeek 0 463 | -- Get the copy of source file permissions, but only whenever it exists 464 | pure $ Posix.fileMode fileStatus) 465 | 466 | 467 | -- This is a copy of the internal function from `directory-1.3.3.2`. It became 468 | -- available only in directory-1.3.3.0 and is still internal, hence the 469 | -- duplication. 470 | copyHandleData :: MonadIO m => Handle -> Handle -> m () 471 | copyHandleData hFrom hTo = liftIO $ allocaBytes bufferSize go 472 | where 473 | bufferSize = 131072 -- 128 KiB, as coreutils `cp` uses as of May 2014 (see ioblksize.h) 474 | go buffer = do 475 | count <- hGetBuf hFrom buffer bufferSize 476 | when (count > 0) $ do 477 | hPutBuf hTo buffer count 478 | go buffer 479 | 480 | -- | Thread safe access to the file descriptor in the file handle 481 | withHandleFd :: Handle -> (Fd -> IO a) -> IO a 482 | withHandleFd h cb = 483 | case h of 484 | HandleFD.FileHandle _ mv -> 485 | withMVar mv $ \HandleFD.Handle__{HandleFD.haDevice = dev} -> 486 | case cast dev of 487 | Just fd -> cb $ Fd $ FD.fdFD fd 488 | Nothing -> error "withHandleFd: not a file handle" 489 | HandleFD.DuplexHandle {} -> error "withHandleFd: not a file handle" 490 | 491 | -- | See `ensureFileDurable` 492 | ensureFileDurable :: MonadIO m => FilePath -> m () 493 | ensureFileDurable filePath = 494 | liftIO $ 495 | withDirectory (takeDirectory filePath) $ \dirFd -> 496 | withFileInDirectory dirFd filePath ReadMode $ \fileHandle -> 497 | liftIO $ do 498 | fsyncFileHandle "ensureFileDurablePosix" fileHandle 499 | -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync 500 | fsyncDirectoryFd "ensureFileDurablePosix" dirFd 501 | 502 | 503 | 504 | -- | See `withBinaryFileDurable` 505 | withBinaryFileDurable :: 506 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 507 | withBinaryFileDurable filePath iomode action = 508 | case iomode of 509 | ReadMode 510 | -- We do not need to consider durable operations when we are in a 511 | -- 'ReadMode', so we can use a regular `withBinaryFile` 512 | -> withBinaryFile filePath iomode action 513 | _ {- WriteMode, ReadWriteMode, AppendMode -} 514 | -> 515 | withDirectory (takeDirectory filePath) $ \dirFd -> 516 | withFileInDirectory dirFd filePath iomode $ \tmpFileHandle -> do 517 | res <- action tmpFileHandle 518 | liftIO $ do 519 | fsyncFileHandle "withBinaryFileDurablePosix" tmpFileHandle 520 | -- NOTE: Here we are purposefully not fsyncing the directory if the file fails to fsync 521 | fsyncDirectoryFd "withBinaryFileDurablePosix" dirFd 522 | pure res 523 | 524 | -- | See `withBinaryFileDurableAtomic` 525 | withBinaryFileDurableAtomic :: 526 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 527 | withBinaryFileDurableAtomic filePath iomode action = 528 | case iomode of 529 | ReadMode 530 | -- We do not need to consider an atomic operation when we are in a 531 | -- 'ReadMode', so we can use a regular `withBinaryFile` 532 | -> withBinaryFile filePath iomode action 533 | _ {- WriteMode, ReadWriteMode, AppendMode -} 534 | -> 535 | withDirectory (takeDirectory filePath) $ \dirFd -> do 536 | mRes <- withAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ 537 | durableAtomicAction dirFd Nothing 538 | case mRes of 539 | Just res -> pure res 540 | Nothing -> 541 | withNonAnonymousBinaryTempFileFor (Just dirFd) filePath iomode $ \tmpFilePath -> 542 | durableAtomicAction dirFd (Just tmpFilePath) 543 | where 544 | durableAtomicAction dirFd mTmpFilePath tmpFileHandle = do 545 | mFileMode <- copyFileHandle iomode filePath tmpFileHandle 546 | res <- action tmpFileHandle 547 | liftIO $ 548 | atomicDurableTempFileRename 549 | dirFd 550 | mFileMode 551 | tmpFileHandle 552 | mTmpFilePath 553 | filePath 554 | pure res 555 | 556 | -- | See `withBinaryFileAtomic` 557 | withBinaryFileAtomic :: 558 | MonadUnliftIO m => FilePath -> IOMode -> (Handle -> m r) -> m r 559 | withBinaryFileAtomic filePath iomode action = 560 | case iomode of 561 | ReadMode 562 | -- We do not need to consider an atomic operation when we are in a 563 | -- 'ReadMode', so we can use a regular `withBinaryFile` 564 | -> withBinaryFile filePath iomode action 565 | _ {- WriteMode, ReadWriteMode, AppendMode -} 566 | -> do 567 | mRes <- 568 | withAnonymousBinaryTempFileFor Nothing filePath iomode $ 569 | atomicAction Nothing 570 | case mRes of 571 | Just res -> pure res 572 | Nothing -> 573 | withNonAnonymousBinaryTempFileFor Nothing filePath iomode $ \tmpFilePath -> 574 | atomicAction (Just tmpFilePath) 575 | where 576 | atomicAction mTmpFilePath tmpFileHandle = do 577 | let eTmpFile = maybe (Left tmpFileHandle) Right mTmpFilePath 578 | mFileMode <- copyFileHandle iomode filePath tmpFileHandle 579 | res <- action tmpFileHandle 580 | liftIO $ atomicTempFileRename Nothing mFileMode eTmpFile filePath 581 | pure res 582 | 583 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/IORef.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "Data.IORef". 2 | -- 3 | -- @since 0.1.0.0 4 | module UnliftIO.IORef 5 | ( IORef 6 | , newIORef 7 | , readIORef 8 | , writeIORef 9 | , modifyIORef 10 | , modifyIORef' 11 | , atomicModifyIORef 12 | , atomicModifyIORef' 13 | , atomicWriteIORef 14 | , mkWeakIORef 15 | ) where 16 | 17 | import Data.IORef (IORef) 18 | import qualified Data.IORef as I 19 | import Control.Monad.IO.Unlift 20 | import System.Mem.Weak (Weak) 21 | 22 | -- | Lifted 'I.newIORef'. 23 | -- 24 | -- @since 0.1.0.0 25 | newIORef :: MonadIO m => a -> m (IORef a) 26 | newIORef = liftIO . I.newIORef 27 | 28 | -- | Lifted 'I.readIORef'. 29 | -- 30 | -- @since 0.1.0.0 31 | readIORef :: MonadIO m => IORef a -> m a 32 | readIORef = liftIO . I.readIORef 33 | 34 | -- | Lifted 'I.writeIORef'. 35 | -- 36 | -- @since 0.1.0.0 37 | writeIORef :: MonadIO m => IORef a -> a -> m () 38 | writeIORef ref = liftIO . I.writeIORef ref 39 | 40 | -- | Lifted 'I.modifyIORef'. 41 | -- 42 | -- @since 0.1.0.0 43 | modifyIORef :: MonadIO m => IORef a -> (a -> a) -> m () 44 | modifyIORef ref = liftIO . I.modifyIORef ref 45 | 46 | -- | Lifted 'I.modifyIORef''. 47 | -- 48 | -- @since 0.1.0.0 49 | modifyIORef' :: MonadIO m => IORef a -> (a -> a) -> m () 50 | modifyIORef' ref = liftIO . I.modifyIORef' ref 51 | 52 | -- | Lifted 'I.atomicModifyIORef'. 53 | -- 54 | -- @since 0.1.0.0 55 | atomicModifyIORef :: MonadIO m => IORef a -> (a -> (a, b)) -> m b 56 | atomicModifyIORef ref = liftIO . I.atomicModifyIORef ref 57 | 58 | -- | Lifted 'I.atomicModifyIORef''. 59 | -- 60 | -- @since 0.1.0.0 61 | atomicModifyIORef' :: MonadIO m => IORef a -> (a -> (a, b)) -> m b 62 | atomicModifyIORef' ref = liftIO . I.atomicModifyIORef' ref 63 | 64 | -- | Lifted 'I.atomicWriteIORef'. 65 | -- 66 | -- @since 0.1.0.0 67 | atomicWriteIORef :: MonadIO m => IORef a -> a -> m () 68 | atomicWriteIORef ref = liftIO . I.atomicWriteIORef ref 69 | 70 | -- | Unlifted 'I.mkWeakIORef'. 71 | -- 72 | -- @since 0.1.0.0 73 | mkWeakIORef :: MonadUnliftIO m => IORef a -> m () -> m (Weak (IORef a)) 74 | mkWeakIORef ref final = withRunInIO $ \run -> I.mkWeakIORef ref (run final) 75 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/MVar.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "Control.Concurrent.MVar". 2 | -- 3 | -- @since 0.1.0.0 4 | module UnliftIO.MVar 5 | ( MVar 6 | , newEmptyMVar 7 | , newMVar 8 | , takeMVar 9 | , putMVar 10 | , readMVar 11 | , swapMVar 12 | , tryTakeMVar 13 | , tryPutMVar 14 | , isEmptyMVar 15 | , withMVar 16 | , withMVarMasked 17 | , modifyMVar 18 | , modifyMVar_ 19 | , modifyMVarMasked 20 | , modifyMVarMasked_ 21 | , tryReadMVar 22 | , mkWeakMVar 23 | ) where 24 | 25 | import System.Mem.Weak (Weak) 26 | import Control.Concurrent.MVar (MVar) 27 | import Control.Monad.IO.Unlift 28 | import qualified Control.Concurrent.MVar as M 29 | 30 | -- | Lifted 'M.newEmptyMVar'. 31 | -- 32 | -- @since 0.1.0.0 33 | newEmptyMVar :: MonadIO m => m (MVar a) 34 | newEmptyMVar = liftIO M.newEmptyMVar 35 | 36 | -- | Lifted 'M.newMVar'. 37 | -- 38 | -- @since 0.1.0.0 39 | newMVar :: MonadIO m => a -> m (MVar a) 40 | newMVar = liftIO . M.newMVar 41 | 42 | -- | Lifted 'M.takeMVar'. 43 | -- 44 | -- @since 0.1.0.0 45 | takeMVar :: MonadIO m => MVar a -> m a 46 | takeMVar = liftIO . M.takeMVar 47 | 48 | -- | Lifted 'M.putMVar'. 49 | -- 50 | -- @since 0.1.0.0 51 | putMVar :: MonadIO m => MVar a -> a -> m () 52 | putMVar var = liftIO . M.putMVar var 53 | 54 | -- | Lifted 'M.readMVar'. 55 | -- 56 | -- @since 0.1.0.0 57 | readMVar :: MonadIO m => MVar a -> m a 58 | readMVar = liftIO . M.readMVar 59 | 60 | -- | Lifted 'M.swapMVar'. 61 | -- 62 | -- @since 0.1.0.0 63 | swapMVar :: MonadIO m => MVar a -> a -> m a 64 | swapMVar var = liftIO . M.swapMVar var 65 | 66 | -- | Lifted 'M.tryTakeMVar'. 67 | -- 68 | -- @since 0.1.0.0 69 | tryTakeMVar :: MonadIO m => MVar a -> m (Maybe a) 70 | tryTakeMVar = liftIO . M.tryTakeMVar 71 | 72 | -- | Lifted 'M.tryPutMVar'. 73 | -- 74 | -- @since 0.1.0.0 75 | tryPutMVar :: MonadIO m => MVar a -> a -> m Bool 76 | tryPutMVar var = liftIO . M.tryPutMVar var 77 | 78 | -- | Lifted 'M.isEmptyMVar'. 79 | -- 80 | -- @since 0.1.0.0 81 | isEmptyMVar :: MonadIO m => MVar a -> m Bool 82 | isEmptyMVar = liftIO . M.isEmptyMVar 83 | 84 | -- | Lifted 'M.tryReadMVar'. 85 | -- 86 | -- @since 0.1.0.0 87 | tryReadMVar :: MonadIO m => MVar a -> m (Maybe a) 88 | tryReadMVar = liftIO . M.tryReadMVar 89 | 90 | -- | Unlifted 'M.withMVar'. 91 | -- 92 | -- @since 0.1.0.0 93 | withMVar :: MonadUnliftIO m => MVar a -> (a -> m b) -> m b 94 | withMVar var f = withRunInIO $ \run -> M.withMVar var (run . f) 95 | 96 | -- | Unlifted 'M.withMVarMasked'. 97 | -- 98 | -- @since 0.1.0.0 99 | withMVarMasked :: MonadUnliftIO m => MVar a -> (a -> m b) -> m b 100 | withMVarMasked var f = withRunInIO $ \run -> M.withMVarMasked var (run . f) 101 | 102 | -- | Unlifted 'M.modifyMVar_'. 103 | -- 104 | -- @since 0.1.0.0 105 | modifyMVar_ :: MonadUnliftIO m => MVar a -> (a -> m a) -> m () 106 | modifyMVar_ var f = withRunInIO $ \run -> M.modifyMVar_ var (run . f) 107 | 108 | -- | Unlifted 'M.modifyMVar'. 109 | -- 110 | -- @since 0.1.0.0 111 | modifyMVar :: MonadUnliftIO m => MVar a -> (a -> m (a, b)) -> m b 112 | modifyMVar var f = withRunInIO $ \run -> M.modifyMVar var (run . f) 113 | 114 | -- | Unlifted 'M.modifyMVarMasked_'. 115 | -- 116 | -- @since 0.1.0.0 117 | modifyMVarMasked_ :: MonadUnliftIO m => MVar a -> (a -> m a) -> m () 118 | modifyMVarMasked_ var f = withRunInIO $ \run -> M.modifyMVarMasked_ var (run . f) 119 | 120 | -- | Unlifted 'M.modifyMVarMasked'. 121 | -- 122 | -- @since 0.1.0.0 123 | modifyMVarMasked :: MonadUnliftIO m => MVar a -> (a -> m (a, b)) -> m b 124 | modifyMVarMasked var f = withRunInIO $ \run -> M.modifyMVarMasked var (run . f) 125 | 126 | -- | Unlifted 'M.mkWeakMVar'. 127 | -- 128 | -- @since 0.1.0.0 129 | mkWeakMVar :: MonadUnliftIO m => MVar a -> m () -> m (Weak (MVar a)) 130 | mkWeakMVar var f = withRunInIO $ \run -> M.mkWeakMVar var (run f) 131 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Memoize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | -- | Memoize the results of actions. In other words: actions 3 | -- will be run once, on demand, and their results saved. 4 | -- 5 | -- Exceptions semantics: if a synchronous exception is thrown while performing 6 | -- the computation, that result will be saved and rethrown each time 7 | -- 'runMemoized' is called subsequently.' 8 | -- 9 | -- @since 0.2.8.0 10 | module UnliftIO.Memoize 11 | ( Memoized 12 | , runMemoized 13 | , memoizeRef 14 | , memoizeMVar 15 | ) where 16 | 17 | import Control.Applicative as A 18 | import Control.Monad (join) 19 | import Control.Monad.IO.Unlift 20 | import UnliftIO.Exception 21 | import UnliftIO.IORef 22 | import UnliftIO.MVar 23 | 24 | -- | A \"run once\" value, with results saved. Extract the value with 25 | -- 'runMemoized'. For single-threaded usage, you can use 'memoizeRef' to 26 | -- create a value. If you need guarantees that only one thread will run the 27 | -- action at a time, use 'memoizeMVar'. 28 | -- 29 | -- Note that this type provides a 'Show' instance for convenience, but not 30 | -- useful information can be provided. 31 | -- 32 | -- @since 0.2.8.0 33 | newtype Memoized a = Memoized (IO a) 34 | deriving (Functor, A.Applicative, Monad) 35 | instance Show (Memoized a) where 36 | show _ = "<>" 37 | 38 | -- | Extract a value from a 'Memoized', running an action if no cached value is 39 | -- available. 40 | -- 41 | -- @since 0.2.8.0 42 | runMemoized :: MonadIO m => Memoized a -> m a 43 | runMemoized (Memoized m) = liftIO m 44 | {-# INLINE runMemoized #-} 45 | 46 | -- | Create a new 'Memoized' value using an 'IORef' under the surface. Note that 47 | -- the action may be run in multiple threads simultaneously, so this may not be 48 | -- thread safe (depending on the underlying action). Consider using 49 | -- 'memoizeMVar'. 50 | -- 51 | -- @since 0.2.8.0 52 | memoizeRef :: MonadUnliftIO m => m a -> m (Memoized a) 53 | memoizeRef action = withRunInIO $ \run -> do 54 | ref <- newIORef Nothing 55 | pure $ Memoized $ do 56 | mres <- readIORef ref 57 | res <- 58 | case mres of 59 | Just res -> pure res 60 | Nothing -> do 61 | res <- tryAny $ run action 62 | writeIORef ref $ Just res 63 | pure res 64 | either throwIO pure res 65 | 66 | -- | Same as 'memoizeRef', but uses an 'MVar' to ensure that an action is 67 | -- only run once, even in a multithreaded application. 68 | -- 69 | -- @since 0.2.8.0 70 | memoizeMVar :: MonadUnliftIO m => m a -> m (Memoized a) 71 | memoizeMVar action = withRunInIO $ \run -> do 72 | var <- newMVar Nothing 73 | pure $ Memoized $ join $ modifyMVar var $ \mres -> do 74 | res <- maybe (tryAny $ run action) pure mres 75 | pure (Just res, either throwIO pure res) 76 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Unlifted "System.Process". 3 | -- 4 | -- @since 0.2.5.0 5 | 6 | module UnliftIO.Process ( 7 | -- * Running sub-processes 8 | CreateProcess(..), CmdSpec(..), StdStream(..), ProcessHandle, createProcess 9 | 10 | #if MIN_VERSION_process(1,2,1) 11 | , createProcess_ 12 | #endif 13 | 14 | , P.shell, P.proc 15 | 16 | -- ** Simpler functions for common tasks 17 | , callProcess, callCommand, spawnProcess, spawnCommand 18 | 19 | #if MIN_VERSION_process(1,2,3) 20 | , readCreateProcess 21 | #endif 22 | 23 | , readProcess 24 | 25 | #if MIN_VERSION_process(1,2,3) 26 | , readCreateProcessWithExitCode 27 | #endif 28 | 29 | , readProcessWithExitCode 30 | 31 | #if MIN_VERSION_process(1,4,3) 32 | , withCreateProcess 33 | #endif 34 | 35 | -- ** Related utilities 36 | , P.showCommandForUser 37 | 38 | -- * Process completion 39 | , waitForProcess, getProcessExitCode, terminateProcess, interruptProcessGroupOf 40 | 41 | #if MIN_VERSION_process(1,2,1) 42 | -- * Interprocess communication 43 | , createPipe 44 | #endif 45 | 46 | #if MIN_VERSION_process(1,4,2) 47 | , createPipeFd 48 | #endif 49 | ) where 50 | 51 | import Control.Monad.IO.Unlift 52 | import System.Exit 53 | import System.IO 54 | import System.Posix.Internals 55 | import System.Process 56 | ( CmdSpec(..) 57 | , CreateProcess(..) 58 | , ProcessHandle 59 | , StdStream(..) 60 | ) 61 | import qualified System.Process as P 62 | 63 | -- | Lifted 'P.createProcess'. 64 | -- 65 | -- @since 0.2.5.0 66 | {-# INLINE createProcess #-} 67 | createProcess :: 68 | MonadIO m 69 | => CreateProcess 70 | -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) 71 | createProcess = liftIO . P.createProcess 72 | 73 | #if MIN_VERSION_process(1,2,1) 74 | -- | Lifted 'P.createProcess_'. 75 | -- 76 | -- @since 0.2.5.0 77 | {-# INLINE createProcess_ #-} 78 | createProcess_ :: 79 | MonadIO m 80 | => String 81 | -> CreateProcess 82 | -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) 83 | createProcess_ msg proc_ = liftIO (P.createProcess_ msg proc_) 84 | #endif 85 | 86 | -- | Lifted 'P.callProcess'. 87 | -- 88 | -- @since 0.2.5.0 89 | {-# INLINE callProcess #-} 90 | callProcess :: MonadIO m => FilePath -> [String] -> m () 91 | callProcess cmd args = liftIO (P.callProcess cmd args) 92 | 93 | -- | Lifted 'P.callCommand'. 94 | -- 95 | -- @since 0.2.5.0 96 | {-# INLINE callCommand #-} 97 | callCommand :: MonadIO m => String -> m () 98 | callCommand = liftIO . P.callCommand 99 | 100 | -- | Lifted 'P.spawnProcess'. 101 | -- 102 | -- @since 0.2.5.0 103 | {-# INLINE spawnProcess #-} 104 | spawnProcess :: MonadIO m => FilePath -> [String] -> m ProcessHandle 105 | spawnProcess cmd args = liftIO (P.spawnProcess cmd args) 106 | 107 | -- | Lifted 'P.spawnCommand'. 108 | -- 109 | -- @since 0.2.5.0 110 | {-# INLINE spawnCommand #-} 111 | spawnCommand :: MonadIO m => String -> m ProcessHandle 112 | spawnCommand = liftIO . P.spawnCommand 113 | 114 | #if MIN_VERSION_process(1,2,3) 115 | -- | Lifted 'P.readCreateProcess'. 116 | -- 117 | -- @since 0.2.5.0 118 | {-# INLINE readCreateProcess #-} 119 | readCreateProcess :: MonadIO m => CreateProcess -> String -> m String 120 | readCreateProcess cp input = liftIO (P.readCreateProcess cp input) 121 | #endif 122 | 123 | -- | Lifted 'P.readProcess'. 124 | -- 125 | -- @since 0.2.5.0 126 | {-# INLINE readProcess #-} 127 | readProcess :: MonadIO m => FilePath -> [String] -> String -> m String 128 | readProcess cmd args input = liftIO (P.readProcess cmd args input) 129 | 130 | #if MIN_VERSION_process(1,2,3) 131 | -- | Lifted 'P.readCreateProcessWithExitCode'. 132 | -- 133 | -- @since 0.2.5.0 134 | {-# INLINE readCreateProcessWithExitCode #-} 135 | readCreateProcessWithExitCode :: 136 | MonadIO m => CreateProcess -> String -> m (ExitCode, String, String) 137 | readCreateProcessWithExitCode cp input = 138 | liftIO (P.readCreateProcessWithExitCode cp input) 139 | #endif 140 | 141 | -- | Lifted 'P.readProcessWithExitCode'. 142 | -- 143 | -- @since 0.2.5.0 144 | {-# INLINE readProcessWithExitCode #-} 145 | readProcessWithExitCode :: 146 | MonadIO m => FilePath -> [String] -> String -> m (ExitCode, String, String) 147 | readProcessWithExitCode cmd args input = 148 | liftIO (P.readProcessWithExitCode cmd args input) 149 | 150 | #if MIN_VERSION_process(1,4,3) 151 | -- | Unlifted 'P.withCreateProcess'. 152 | -- 153 | -- @since 0.2.5.0 154 | {-# INLINE withCreateProcess #-} 155 | withCreateProcess :: 156 | MonadUnliftIO m 157 | => CreateProcess 158 | -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> m a) 159 | -> m a 160 | withCreateProcess c action = 161 | withRunInIO 162 | (\u -> 163 | P.withCreateProcess 164 | c 165 | (\stdin_h stdout_h stderr_h proc_h -> 166 | u (action stdin_h stdout_h stderr_h proc_h))) 167 | #endif 168 | 169 | -- | Lifted 'P.waitForProcess'. 170 | -- 171 | -- @since 0.2.5.0 172 | {-# INLINE waitForProcess #-} 173 | waitForProcess :: MonadIO m => ProcessHandle -> m ExitCode 174 | waitForProcess = liftIO . P.waitForProcess 175 | 176 | -- | Lifted 'P.getProcessExitCode'. 177 | -- 178 | -- @since 0.2.5.0 179 | {-# INLINE getProcessExitCode #-} 180 | getProcessExitCode :: MonadIO m => ProcessHandle -> m (Maybe ExitCode) 181 | getProcessExitCode = liftIO . P.getProcessExitCode 182 | 183 | -- | Lifted 'P.terminateProcess'. 184 | -- 185 | -- @since 0.2.5.0 186 | {-# INLINE terminateProcess #-} 187 | terminateProcess :: MonadIO m => ProcessHandle -> m () 188 | terminateProcess = liftIO . P.terminateProcess 189 | 190 | -- | Lifted 'P.interruptProcessGroupOf'. 191 | -- 192 | -- @since 0.2.5.0 193 | {-# INLINE interruptProcessGroupOf #-} 194 | interruptProcessGroupOf :: MonadIO m => ProcessHandle -> m () 195 | interruptProcessGroupOf = liftIO . P.interruptProcessGroupOf 196 | 197 | #if MIN_VERSION_process(1,2,1) 198 | -- | Lifted 'P.createPipe'. 199 | -- 200 | -- @since 0.2.5.0 201 | {-# INLINE createPipe #-} 202 | createPipe :: MonadIO m => m (Handle, Handle) 203 | createPipe = liftIO P.createPipe 204 | #endif 205 | 206 | #if MIN_VERSION_process(1,4,2) 207 | -- | Lifted 'P.createPipeFd'. 208 | -- 209 | -- @since 0.2.5.0 210 | {-# INLINE createPipeFd #-} 211 | createPipeFd :: MonadIO m => m (FD, FD) 212 | createPipeFd = liftIO P.createPipeFd 213 | #endif 214 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/QSem.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "Control.Concurrent.QSem". 2 | -- 3 | -- @since 0.2.14 4 | module UnliftIO.QSem 5 | ( QSem 6 | , newQSem 7 | , waitQSem 8 | , signalQSem 9 | , withQSem 10 | ) where 11 | 12 | import Control.Concurrent.QSem (QSem) 13 | import Control.Monad.IO.Unlift 14 | import UnliftIO.Exception 15 | import qualified Control.Concurrent.QSem as Q 16 | 17 | -- | Lifted 'Q.newQSem'. 18 | -- 19 | -- @since 0.2.14 20 | newQSem :: MonadIO m => Int -> m QSem 21 | newQSem = liftIO . Q.newQSem 22 | 23 | -- | Lifted 'Q.waitQSem'. 24 | -- 25 | -- @since 0.2.14 26 | waitQSem :: MonadIO m => QSem -> m () 27 | waitQSem = liftIO . Q.waitQSem 28 | 29 | -- | Lifted 'Q.signalQSem'. 30 | -- 31 | -- @since 0.2.14 32 | signalQSem :: MonadIO m => QSem -> m () 33 | signalQSem = liftIO . Q.signalQSem 34 | 35 | -- | 'withQSem' is an exception-safe wrapper for performing the 36 | -- provided operation while holding a unit of value from the semaphore. 37 | -- It ensures the semaphore cannot be leaked if there are exceptions. 38 | -- 39 | -- @since 0.2.14 40 | {-# INLINE withQSem #-} 41 | withQSem :: MonadUnliftIO m => QSem -> m a -> m a 42 | withQSem x io = withRunInIO $ \run -> 43 | bracket_ (waitQSem x) (signalQSem x) (run io) 44 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/QSemN.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "Control.Concurrent.QSemN". 2 | -- 3 | -- @since 0.2.14 4 | module UnliftIO.QSemN 5 | ( QSemN 6 | , newQSemN 7 | , waitQSemN 8 | , signalQSemN 9 | , withQSemN 10 | ) where 11 | 12 | import Control.Concurrent.QSemN (QSemN) 13 | import Control.Monad.IO.Unlift 14 | import UnliftIO.Exception 15 | import qualified Control.Concurrent.QSemN as Q 16 | 17 | -- | Lifted 'Q.newQSemN'. 18 | -- 19 | -- @since 0.2.14 20 | newQSemN :: MonadIO m => Int -> m QSemN 21 | newQSemN = liftIO . Q.newQSemN 22 | 23 | -- | Lifted 'Q.waitQSemN'. 24 | -- 25 | -- @since 0.2.14 26 | waitQSemN :: MonadIO m => QSemN -> Int -> m () 27 | waitQSemN x = liftIO . Q.waitQSemN x 28 | 29 | -- | Lifted 'Q.signalQSemN'. 30 | -- 31 | -- @since 0.2.14 32 | signalQSemN :: MonadIO m => QSemN -> Int -> m () 33 | signalQSemN x = liftIO . Q.signalQSemN x 34 | 35 | -- | 'withQSemN' is an exception-safe wrapper for performing the 36 | -- provided operation while holding N unit of value from the semaphore. 37 | -- It ensures the semaphore cannot be leaked if there are exceptions. 38 | -- 39 | -- @since 0.2.14 40 | {-# INLINE withQSemN #-} 41 | withQSemN :: MonadUnliftIO m => QSemN -> Int -> m a -> m a 42 | withQSemN x n io = withRunInIO $ \run -> 43 | bracket_ (waitQSemN x n) (signalQSemN x n) (run io) 44 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/STM.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Lifted version of "Control.Concurrent.STM" 3 | -- 4 | -- @since 0.2.1.0 5 | module UnliftIO.STM 6 | ( -- * Core 7 | STM.STM 8 | , atomically 9 | , retrySTM 10 | , checkSTM 11 | , STM.orElse 12 | 13 | -- * TVar 14 | , STM.TVar 15 | , newTVarIO 16 | , readTVarIO 17 | , STM.newTVar 18 | , STM.readTVar 19 | , STM.writeTVar 20 | , STM.modifyTVar 21 | , STM.modifyTVar' 22 | , STM.stateTVar 23 | , STM.swapTVar 24 | , registerDelay 25 | , mkWeakTVar 26 | 27 | -- * TMVar 28 | , STM.TMVar 29 | , STM.newTMVar 30 | , STM.newEmptyTMVar 31 | , newTMVarIO 32 | , newEmptyTMVarIO 33 | , STM.takeTMVar 34 | , STM.putTMVar 35 | , STM.readTMVar 36 | #if MIN_VERSION_stm(2, 5, 1) 37 | , STM.writeTMVar 38 | #endif 39 | , STM.tryReadTMVar 40 | , STM.swapTMVar 41 | , STM.tryTakeTMVar 42 | , STM.tryPutTMVar 43 | , STM.isEmptyTMVar 44 | , mkWeakTMVar 45 | 46 | -- * TChan 47 | , STM.TChan 48 | , STM.newTChan 49 | , newTChanIO 50 | , STM.newBroadcastTChan 51 | , newBroadcastTChanIO 52 | , STM.dupTChan 53 | , STM.cloneTChan 54 | , STM.readTChan 55 | , STM.tryReadTChan 56 | , STM.peekTChan 57 | , STM.tryPeekTChan 58 | , STM.writeTChan 59 | , STM.unGetTChan 60 | , STM.isEmptyTChan 61 | 62 | -- * TQueue 63 | , STM.TQueue 64 | , STM.newTQueue 65 | , newTQueueIO 66 | , STM.readTQueue 67 | , STM.tryReadTQueue 68 | , STM.peekTQueue 69 | , STM.tryPeekTQueue 70 | , STM.writeTQueue 71 | , STM.unGetTQueue 72 | , STM.isEmptyTQueue 73 | 74 | -- * TBQueue 75 | , STM.TBQueue 76 | , STM.newTBQueue 77 | , newTBQueueIO 78 | , STM.readTBQueue 79 | , STM.tryReadTBQueue 80 | , STM.flushTBQueue 81 | , STM.peekTBQueue 82 | , STM.tryPeekTBQueue 83 | , STM.writeTBQueue 84 | , STM.unGetTBQueue 85 | , STM.lengthTBQueue 86 | , STM.isEmptyTBQueue 87 | , STM.isFullTBQueue 88 | ) where 89 | 90 | import Control.Concurrent.STM (STM, TVar, TMVar, TChan, TQueue, TBQueue) 91 | import qualified Control.Concurrent.STM as STM 92 | import Control.Monad.IO.Unlift 93 | import System.Mem.Weak (Weak) 94 | #if MIN_VERSION_base(4, 8, 0) 95 | import GHC.Natural (Natural) 96 | #else 97 | import Numeric.Natural (Natural) 98 | #endif 99 | 100 | -- | Lifted version of 'STM.atomically' 101 | -- 102 | -- @since 0.2.1.0 103 | atomically :: MonadIO m => STM a -> m a 104 | atomically = liftIO . STM.atomically 105 | 106 | -- | Renamed 'STM.retry' for unqualified export 107 | -- 108 | -- @since 0.2.1.0 109 | retrySTM :: STM a 110 | retrySTM = STM.retry 111 | 112 | -- | Renamed 'STM.check' for unqualified export 113 | -- 114 | -- @since 0.2.1.0 115 | checkSTM :: Bool -> STM () 116 | checkSTM = STM.check 117 | 118 | -- | Lifted version of 'STM.newTVarIO' 119 | -- 120 | -- @since 0.2.1.0 121 | newTVarIO :: MonadIO m => a -> m (TVar a) 122 | newTVarIO = liftIO . STM.newTVarIO 123 | 124 | -- | Lifted version of 'STM.readTVarIO' 125 | -- 126 | -- @since 0.2.1.0 127 | readTVarIO :: MonadIO m => TVar a -> m a 128 | readTVarIO = liftIO . STM.readTVarIO 129 | 130 | -- | Lifted version of 'STM.registerDelay' 131 | -- 132 | -- @since 0.2.1.0 133 | registerDelay :: MonadIO m => Int -> m (TVar Bool) 134 | registerDelay = liftIO . STM.registerDelay 135 | 136 | -- | Lifted version of 'STM.mkWeakTVar' 137 | -- 138 | -- @since 0.2.1.0 139 | mkWeakTVar :: MonadUnliftIO m => TVar a -> m () -> m (Weak (TVar a)) 140 | mkWeakTVar var final = withRunInIO $ \run -> STM.mkWeakTVar var (run final) 141 | 142 | -- | Lifted version of 'STM.newTMVarIO' 143 | -- 144 | -- @since 0.2.1.0 145 | newTMVarIO :: MonadIO m => a -> m (TMVar a) 146 | newTMVarIO = liftIO . STM.newTMVarIO 147 | 148 | -- | Lifted version of 'STM.newEmptyTMVarIO' 149 | -- 150 | -- @since 0.2.1.0 151 | newEmptyTMVarIO :: MonadIO m => m (TMVar a) 152 | newEmptyTMVarIO = liftIO STM.newEmptyTMVarIO 153 | 154 | -- | Lifted version of 'STM.mkWeakTMVar' 155 | -- 156 | -- @since 0.2.1.0 157 | mkWeakTMVar :: MonadUnliftIO m => TMVar a -> m () -> m (Weak (TMVar a)) 158 | mkWeakTMVar var final = withRunInIO $ \run -> STM.mkWeakTMVar var (run final) 159 | 160 | -- | Lifted version of 'STM.newTChanIO' 161 | -- 162 | -- @since 0.2.1.0 163 | newTChanIO :: MonadIO m => m (TChan a) 164 | newTChanIO = liftIO STM.newTChanIO 165 | 166 | -- | Lifted version of 'STM.newBroadcastTChanIO' 167 | -- 168 | -- @since 0.2.1.0 169 | newBroadcastTChanIO :: MonadIO m => m (TChan a) 170 | newBroadcastTChanIO = liftIO STM.newBroadcastTChanIO 171 | 172 | -- | Lifted version of 'STM.newTQueueIO' 173 | -- 174 | -- @since 0.2.1.0 175 | newTQueueIO :: MonadIO m => m (TQueue a) 176 | newTQueueIO = liftIO STM.newTQueueIO 177 | 178 | -- | Lifted version of 'STM.newTBQueueIO' 179 | -- 180 | -- @since 0.2.1.0 181 | #if MIN_VERSION_stm(2, 5, 0) 182 | newTBQueueIO :: MonadIO m => Natural -> m (TBQueue a) 183 | #else 184 | newTBQueueIO :: MonadIO m => Int -> m (TBQueue a) 185 | #endif 186 | newTBQueueIO = liftIO . STM.newTBQueueIO 187 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Temporary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAgE CPP #-} 2 | -- | Temporary file and directory support. 3 | -- 4 | -- Strongly inspired by\/stolen from the package. 5 | -- 6 | -- @since 0.1.0.0 7 | -- 8 | -- === __Copyright notice:__ 9 | -- 10 | -- The following copyright notice is taken from 11 | -- and is reproduced here as part of license terms of that package, of which this module is 12 | -- a derivate work. 13 | -- 14 | -- @ 15 | -- Copyright 16 | -- (c) 2003-2006, Isaac Jones 17 | -- (c) 2005-2009, Duncan Coutts 18 | -- (c) 2008, Maximilian Bolingbroke 19 | -- ... and other contributors 20 | -- 21 | -- All rights reserved. 22 | -- 23 | -- Redistribution and use in source and binary forms, with or without modification, are permitted 24 | -- provided that the following conditions are met: 25 | -- 26 | -- * Redistributions of source code must retain the above copyright notice, this list of 27 | -- conditions and the following disclaimer. 28 | -- * Redistributions in binary form must reproduce the above copyright notice, this list of 29 | -- conditions and the following disclaimer in the documentation and/or other materials 30 | -- provided with the distribution. 31 | -- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to 32 | -- endorse or promote products derived from this software without specific prior written permission. 33 | -- 34 | -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 35 | -- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 36 | -- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 37 | -- CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 38 | -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 39 | -- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 40 | -- IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 41 | -- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 42 | -- @ 43 | module UnliftIO.Temporary 44 | ( withSystemTempFile 45 | , withSystemTempDirectory 46 | , withTempFile 47 | , withTempDirectory 48 | ) where 49 | 50 | import Control.Monad.IO.Unlift 51 | import Control.Monad (liftM) 52 | import UnliftIO.Exception 53 | import System.Directory 54 | import System.IO (Handle, openTempFile, hClose) 55 | import System.IO.Error 56 | import System.Posix.Internals (c_getpid) 57 | import System.FilePath (()) 58 | 59 | #ifdef mingw32_HOST_OS 60 | import System.Directory ( createDirectory ) 61 | #else 62 | import qualified System.Posix 63 | #endif 64 | 65 | -- | Create and use a temporary file in the system standard temporary directory. 66 | -- 67 | -- Behaves exactly the same as 'withTempFile', except that the parent temporary directory 68 | -- will be that returned by 'getCanonicalTemporaryDirectory'. 69 | -- 70 | -- @since 0.1.0.0 71 | withSystemTempFile :: MonadUnliftIO m => 72 | String -- ^ File name template. See 'openTempFile'. 73 | -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file 74 | -> m a 75 | withSystemTempFile template action = liftIO getCanonicalTemporaryDirectory >>= \tmpDir -> withTempFile tmpDir template action 76 | 77 | -- | Create and use a temporary directory in the system standard temporary directory. 78 | -- 79 | -- Behaves exactly the same as 'withTempDirectory', except that the parent temporary directory 80 | -- will be that returned by 'getCanonicalTemporaryDirectory'. 81 | -- 82 | -- @since 0.1.0.0 83 | withSystemTempDirectory :: MonadUnliftIO m => 84 | String -- ^ Directory name template. See 'openTempFile'. 85 | -> (FilePath -> m a) -- ^ Callback that can use the directory. 86 | -> m a 87 | withSystemTempDirectory template action = liftIO getCanonicalTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action 88 | 89 | 90 | -- | Use a temporary filename that doesn't already exist. 91 | -- 92 | -- Creates a new temporary file inside the given directory, making use of the 93 | -- template. The temp file is deleted after use. For example: 94 | -- 95 | -- > withTempFile "src" "sdist." $ \tmpFile hFile -> do ... 96 | -- 97 | -- The @tmpFile@ will be file in the given directory, e.g. 98 | -- @src/sdist.342@. 99 | -- 100 | -- @since 0.1.0.0 101 | withTempFile :: MonadUnliftIO m => 102 | FilePath -- ^ Temp dir to create the file in. 103 | -> String -- ^ File name template. See 'openTempFile'. 104 | -> (FilePath -> Handle -> m a) -- ^ Callback that can use the file. 105 | -> m a 106 | withTempFile tmpDir template action = 107 | bracket 108 | (liftIO (openTempFile tmpDir template)) 109 | (\(name, handle') -> liftIO (hClose handle' >> ignoringIOErrors (removeFile name))) 110 | (uncurry action) 111 | 112 | -- | Create and use a temporary directory. 113 | -- 114 | -- Creates a new temporary directory inside the given directory, making use 115 | -- of the template. The temp directory is deleted after use. For example: 116 | -- 117 | -- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... 118 | -- 119 | -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. 120 | -- @src/sdist.342@. 121 | -- 122 | -- @since 0.1.0.0 123 | withTempDirectory :: MonadUnliftIO m => 124 | FilePath -- ^ Temp directory to create the directory in. 125 | -> String -- ^ Directory name template. See 'openTempFile'. 126 | -> (FilePath -> m a) -- ^ Callback that can use the directory. 127 | -> m a 128 | withTempDirectory targetDir template = 129 | bracket 130 | (liftIO (createTempDirectory targetDir template)) 131 | (liftIO . ignoringIOErrors . removeDirectoryRecursive) 132 | 133 | -- | Return the absolute and canonical path to the system temporary 134 | -- directory. 135 | -- 136 | -- >>> setCurrentDirectory "/home/feuerbach/" 137 | -- >>> setEnv "TMPDIR" "." 138 | -- >>> getTemporaryDirectory 139 | -- "." 140 | -- >>> getCanonicalTemporaryDirectory 141 | -- "/home/feuerbach" 142 | getCanonicalTemporaryDirectory :: IO FilePath 143 | getCanonicalTemporaryDirectory = getTemporaryDirectory >>= canonicalizePath 144 | 145 | -- | Create a temporary directory. See 'withTempDirectory'. 146 | createTempDirectory 147 | :: FilePath -- ^ Temp directory to create the directory in. 148 | -> String -- ^ Directory name template. 149 | -> IO FilePath 150 | createTempDirectory dir template = do 151 | pid <- c_getpid 152 | findTempName pid 153 | where 154 | findTempName x = do 155 | let dirpath = dir template ++ show x 156 | r <- try $ mkPrivateDir dirpath 157 | case r of 158 | Right _ -> return dirpath 159 | Left e | isAlreadyExistsError e -> findTempName (x+1) 160 | | otherwise -> ioError e 161 | 162 | 163 | mkPrivateDir :: String -> IO () 164 | #ifdef mingw32_HOST_OS 165 | mkPrivateDir s = createDirectory s 166 | #else 167 | mkPrivateDir s = System.Posix.createDirectory s 0o700 168 | #endif 169 | 170 | ignoringIOErrors :: MonadUnliftIO m => m () -> m () 171 | ignoringIOErrors = liftM (const ()) . tryIO -- yes, it's just void, but for pre-AMP GHCs 172 | -------------------------------------------------------------------------------- /unliftio/src/UnliftIO/Timeout.hs: -------------------------------------------------------------------------------- 1 | -- | Unlifted "System.Timeout". 2 | -- 3 | -- @since 0.1.0.0 4 | module UnliftIO.Timeout 5 | ( timeout 6 | ) where 7 | 8 | import qualified System.Timeout as S 9 | import Control.Monad.IO.Unlift 10 | 11 | -- | Unlifted 'S.timeout'. 12 | -- 13 | -- @since 0.1.0.0 14 | timeout :: MonadUnliftIO m => Int -> m a -> m (Maybe a) 15 | timeout x y = withRunInIO $ \run -> S.timeout x $ run y 16 | -------------------------------------------------------------------------------- /unliftio/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/AsyncSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE CPP #-} 3 | module UnliftIO.AsyncSpec (spec) where 4 | 5 | import Test.Hspec 6 | import Test.Hspec.QuickCheck 7 | import Test.QuickCheck 8 | import UnliftIO 9 | import UnliftIO.Internals.Async 10 | import Data.List (nub) 11 | import Control.Applicative 12 | import Control.Concurrent (myThreadId, threadDelay) 13 | import qualified Control.Exception as CE (ErrorCall(..), try) 14 | import GHC.Conc.Sync (ThreadStatus(..), threadStatus) 15 | import Control.Concurrent.STM (throwSTM) 16 | import Control.Exception (getMaskingState, MaskingState (Unmasked)) 17 | 18 | data MyExc = MyExc 19 | deriving (Show, Eq, Typeable) 20 | instance Exception MyExc 21 | 22 | spec :: Spec 23 | spec = do 24 | describe "replicateConcurrently_" $ do 25 | prop "works" $ \(NonNegative cnt) -> do 26 | ref <- newIORef (0 :: Int) 27 | replicateConcurrently_ cnt $ atomicModifyIORef' ref $ \i -> (i + 1, ()) 28 | readIORef ref `shouldReturn` cnt 29 | 30 | it "uses a different thread per replicated action" $ 31 | forAllShrink ((+ 1) . abs <$> arbitrary) (filter (>= 1) . shrink) $ \n -> do 32 | threadIdsRef <- newIORef [] 33 | let action = myThreadId >>= \tid -> atomicModifyIORef' threadIdsRef (\acc -> (tid:acc, ())) 34 | replicateConcurrently_ n action 35 | tids <- readIORef threadIdsRef 36 | tids `shouldBe` (nub tids) 37 | 38 | #if MIN_VERSION_base(4,8,0) 39 | describe "flatten" $ do 40 | -- NOTE: cannot make this test a property test given 41 | -- Flat and Conc cannot have an Eq property 42 | it "flattens all alternative trees" $ do 43 | let 44 | concValue :: Conc IO Int 45 | concValue = 46 | conc (pure 1) <|> conc (pure 2) <|> pure 3 47 | -- Alt (Alt (Action (pure 1)) (Action (pure 2))) 48 | -- (Pure 3) 49 | flatConc <- flatten concValue 50 | case flatConc of 51 | FlatAlt (FlatAction action1) 52 | (FlatAction action2) 53 | [(FlatPure 3)] -> do 54 | action1 `shouldReturn` 1 55 | action2 `shouldReturn` 2 56 | _ -> expectationFailure "expecting flatten to work but didn't" 57 | 58 | describe "conc" $ do 59 | it "handles sync exceptions" $ do 60 | runConc (conc (pure ()) *> conc (throwIO MyExc)) 61 | `shouldThrow` (== MyExc) 62 | 63 | it "handles async exceptions" $ do 64 | tidVar <- newEmptyMVar 65 | result <- CE.try $ runConc (conc (pure ()) 66 | *> conc (takeMVar tidVar >>= (`throwTo` (CE.ErrorCall "having error"))) 67 | *> conc (myThreadId 68 | >>= putMVar tidVar 69 | >> threadDelay 1000100)) 70 | case result of 71 | Right _ -> 72 | expectationFailure "Expecting an error, got none" 73 | Left (SomeAsyncException err) -> 74 | displayException err `shouldBe` "having error" 75 | 76 | it "has an Unmasked masking state for given subroutines" $ 77 | uninterruptibleMask_ $ 78 | runConc $ conc (threadDelay maxBound) <|> 79 | conc (getMaskingState `shouldReturn` Unmasked) 80 | 81 | -- NOTE: Older versions of GHC have a timeout function that doesn't 82 | -- work on Windows 83 | #if !WINDOWS 84 | it "allows to kill parent via timeout" $ do 85 | ref <- newIORef (0 :: Int) 86 | mres <- timeout 20 $ runConc $ 87 | conc (pure ()) *> 88 | conc ((writeIORef ref 1 >> threadDelay maxBound >> writeIORef ref 2) 89 | `finally` writeIORef ref 3) 90 | mres `shouldBe` Nothing 91 | res <- readIORef ref 92 | case res of 93 | 0 -> putStrLn "make timeout longer" 94 | 1 -> error "it's 1" 95 | 2 -> error "it's 2" 96 | 3 -> pure () 97 | _ -> error $ "what? " ++ show res 98 | #endif 99 | 100 | it "throws right exception on empty" $ 101 | runConc empty `shouldThrow` (== EmptyWithNoAlternative) 102 | 103 | describe "Conc Applicative instance" $ do 104 | prop "doesn't fork a new thread on a pure call" $ \i -> 105 | runConc (pure (i :: Int)) `shouldReturn` i 106 | 107 | it "evaluates all needed sub-routines " $ do 108 | runConc (conc (pure ()) *> conc (throwIO MyExc)) 109 | `shouldThrow` (== MyExc) 110 | 111 | it "cleanup on brackets work" $ do 112 | var <- newTVarIO (0 :: Int) 113 | let worker = conc $ bracket_ 114 | (atomically $ modifyTVar' var (+ 1)) 115 | (atomically $ modifyTVar' var (subtract 1)) 116 | (threadDelay 10000000 >> error "this should never happen") 117 | count = 10 118 | killer = conc $ atomically $ do 119 | count' <- readTVar var 120 | checkSTM $ count == count' 121 | throwSTM MyExc 122 | composed = foldr (*>) killer (replicate count worker) 123 | runConc composed `shouldThrow` (== MyExc) 124 | atomically (readTVar var) `shouldReturn` 0 125 | 126 | it "re-throws exception that happened first" $ do 127 | let composed = conc (throwIO MyExc) *> conc (threadDelay 1000000 >> error "foo") 128 | runConc composed `shouldThrow` (== MyExc) 129 | 130 | describe "Conc Alternative instance" $ do 131 | it "is left associative" $ do 132 | let 133 | concValue :: Conc IO Int 134 | concValue = 135 | conc (pure 1) <|> conc (pure 2) <|> conc (pure 3) 136 | case concValue of 137 | Alt (Alt (Action action1) (Action action2)) (Action action3) -> do 138 | action1 `shouldReturn` 1 139 | action2 `shouldReturn` 2 140 | action3 `shouldReturn` 3 141 | 142 | _ -> expectationFailure "expecting Conc Alternative to be left associative, but it wasn't" 143 | 144 | it "executes body of all alternative blocks" $ do 145 | var <- newEmptyMVar 146 | runConc $ 147 | conc (takeMVar var) <|> 148 | conc (threadDelay maxBound) <|> 149 | conc (threadDelay 100 >> pure ()) 150 | -- if a GC runs at the right time, it's possible that both `takeMVar` and 151 | -- `runConc` itself will be in a "blocked indefinitely on MVar" situation, 152 | -- adding line bellow to avoid that 153 | putMVar var () 154 | 155 | it "finishes all threads that didn't finish first" $ do 156 | ref <- newIORef [] 157 | runConc $ 158 | conc (do tid <- myThreadId 159 | atomicModifyIORef' ref (\acc -> (tid:acc, ())) 160 | -- it is never going to finish 161 | threadDelay maxBound) <|> 162 | conc (do tid <- myThreadId 163 | -- it finishes after registering thread id 164 | atomicModifyIORef' ref (\acc -> (tid:acc, ())) 165 | threadDelay 500) <|> 166 | conc (do tid <- myThreadId 167 | atomicModifyIORef' ref (\acc -> (tid:acc, ())) 168 | -- it is never going to finish 169 | threadDelay maxBound) 170 | threads <- readIORef ref 171 | statusList <- mapM threadStatus threads 172 | length (filter (== ThreadFinished) statusList) `shouldBe` 3 173 | 174 | it "nesting works" $ do 175 | var <- newEmptyMVar 176 | let sillyAlts :: Conc IO a -> Conc IO a 177 | sillyAlts c = c <|> conc (takeMVar var >> error "shouldn't happen") 178 | res <- runConc $ sillyAlts $ (+) 179 | <$> sillyAlts (conc (pure 1)) 180 | <*> sillyAlts (conc (pure 2)) 181 | res `shouldBe` 3 182 | putMVar var () 183 | 184 | #endif 185 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/DirectorySpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module UnliftIO.DirectorySpec (spec) where 3 | 4 | import Test.Hspec 5 | #if MIN_VERSION_directory(1,3,1) 6 | import System.FilePath 7 | import UnliftIO.IO 8 | import UnliftIO.Directory 9 | import UnliftIO.Temporary 10 | 11 | 12 | spec :: Spec 13 | spec = do 14 | describe "createFileLink" $ do 15 | it "mirror" $ do 16 | withSystemTempDirectory "createFileLink.mirror" $ \fp -> do 17 | let fileContent = "i am the same" 18 | fileContent' = "I AM THE SAME" 19 | origin = fp "origin.txt" 20 | link = fp "link.txt" 21 | writeFile origin fileContent 22 | createFileLink origin link 23 | linkContent <- readFile link 24 | linkContent `shouldBe`fileContent 25 | writeFile origin fileContent' 26 | linkContent' <- readFile link 27 | linkContent' `shouldBe`fileContent' 28 | #else 29 | spec :: Spec 30 | spec = pure () 31 | #endif 32 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/ExceptionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module UnliftIO.ExceptionSpec (spec) where 4 | 5 | import qualified Control.Exception 6 | import Control.Monad (void, (<=<)) 7 | import Data.Bifunctor (first) 8 | import Test.Hspec 9 | import UnliftIO 10 | import UnliftIO.Concurrent (threadDelay) 11 | 12 | #if MIN_VERSION_async(2,2,0) 13 | cancelled :: AsyncCancelled 14 | cancelled = AsyncCancelled 15 | #else 16 | cancelled :: Control.Exception.AsyncException 17 | cancelled = Control.Exception.ThreadKilled 18 | #endif 19 | 20 | spec :: Spec 21 | spec = do 22 | let -- The callback will run in a thread that gets cancelled immediately, 23 | -- then get Exception2 thrown synchronously after 1 second. 24 | withAsyncExceptionThrown :: (IO a -> IO b) -> IO b 25 | withAsyncExceptionThrown f = do 26 | var <- newEmptyMVar 27 | a <- async $ f $ do 28 | putMVar var () 29 | threadDelay 1000000 30 | throwIO Exception2 31 | -- wait until thread is running, then cancel 32 | takeMVar var 33 | cancel a 34 | -- check result 35 | wait a 36 | -- The callback will run in a thread that gets Exception1 thrown as 37 | -- an async exception immediately, then get Exception2 thrown 38 | -- synchronously after 1 second. 39 | withWrappedAsyncExceptionThrown :: (IO a -> IO b) -> IO b 40 | withWrappedAsyncExceptionThrown f = do 41 | var <- newEmptyMVar 42 | a <- async $ f $ do 43 | putMVar var () 44 | threadDelay 1000000 45 | throwIO Exception2 46 | -- wait until thread is running, then cancel 47 | takeMVar var 48 | throwTo (asyncThreadId a) Exception1 49 | -- check result 50 | wait a 51 | describe "catchSyncOrAsync" $ do 52 | it "should catch sync exceptions" $ do 53 | result <- (`catchSyncOrAsync` return) $ throwIO Exception1 54 | result `shouldBe` Exception1 55 | it "should catch async exceptions" $ do 56 | result <- withAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return 57 | result `shouldBe` cancelled 58 | it "should catch unliftio-wrapped async exceptions" $ do 59 | result <- withWrappedAsyncExceptionThrown $ \m -> m `catchSyncOrAsync` return 60 | fromExceptionUnwrap result `shouldBe` Just Exception1 61 | describe "handleSyncOrAsync" $ do 62 | it "should catch sync exceptions" $ do 63 | result <- handleSyncOrAsync return $ throwIO Exception1 64 | result `shouldBe` Exception1 65 | it "should catch async exceptions" $ do 66 | result <- withAsyncExceptionThrown $ \m -> handleSyncOrAsync return m 67 | result `shouldBe` cancelled 68 | it "should catch unliftio-wrapped async exceptions" $ do 69 | result <- withWrappedAsyncExceptionThrown $ \m -> handleSyncOrAsync return m 70 | fromExceptionUnwrap result `shouldBe` Just Exception1 71 | describe "trySyncOrAsync" $ do 72 | it "should catch sync exceptions" $ do 73 | result <- trySyncOrAsync $ void $ throwIO Exception1 74 | result `shouldBe` Left Exception1 75 | it "should catch async exceptions" $ do 76 | result <- withAsyncExceptionThrown $ \m -> trySyncOrAsync (void m) 77 | result `shouldBe` Left cancelled 78 | it "should catch unliftio-wrapped async exceptions" $ do 79 | result <- withWrappedAsyncExceptionThrown $ \m -> trySyncOrAsync (void m) 80 | first fromExceptionUnwrap result `shouldBe` Left (Just Exception1) 81 | 82 | describe "fromExceptionUnwrap" $ do 83 | it "should be the inverse of toAsyncException" $ do 84 | fromExceptionUnwrap (toAsyncException Exception1) `shouldBe` Just Exception1 85 | it "should be the inverse of toSyncException" $ do 86 | let toAsyncToSync = toSyncException . toAsyncException 87 | fromSyncFromAsyc = fromExceptionUnwrap <=< fromExceptionUnwrap 88 | fromSyncFromAsyc (toAsyncToSync Exception1) `shouldBe` Just Exception1 89 | 90 | let shouldLeft x = either (const Nothing) Just x `shouldBe` Nothing 91 | shouldRight x = either (Just . show) (const Nothing) x `shouldBe` Nothing 92 | describe "pureTry" $ do 93 | it "Right for defined values" $ shouldRight $ pureTry () 94 | it "Left for bottom" $ shouldLeft $ pureTry (undefined :: ()) 95 | it "Right for wrapped bottom" $ shouldRight $ pureTry $ Just (undefined :: ()) 96 | describe "pureTryDeep" $ do 97 | it "Right for defined values" $ shouldRight $ pureTryDeep () 98 | it "Left for bottom" $ shouldLeft $ pureTryDeep (undefined :: ()) 99 | it "Left for wrapped bottom" $ shouldLeft $ pureTryDeep $ Just (undefined :: ()) 100 | 101 | describe "mapExceptionM" $ do 102 | it "should convert an exception" $ do 103 | result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception1) 104 | result `shouldBe` (Left Exception2 :: Either Exception2 ()) 105 | it "should not convert unrelated exceptions" $ do 106 | result <- try $ mapExceptionM (\Exception1 -> Exception2) (throwIO Exception2) 107 | result `shouldBe` (Left Exception2 :: Either Exception2 ()) 108 | 109 | data Exception1 = Exception1 deriving (Show, Eq) 110 | instance Exception Exception1 111 | 112 | data Exception2 = Exception2 deriving (Show, Eq) 113 | instance Exception Exception2 114 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/IO/FileSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | module UnliftIO.IO.FileSpec where 7 | 8 | import Test.Hspec 9 | -- Atomic/durable file writing is not supported on Windows. 10 | #ifndef WINDOWS 11 | import Control.Monad (forM_) 12 | import Data.Bool (bool) 13 | import System.FilePath (()) 14 | import Test.QuickCheck 15 | import UnliftIO.Directory 16 | import UnliftIO.Exception 17 | import UnliftIO.IO 18 | import UnliftIO.IO.File as File 19 | import UnliftIO.Temporary (withSystemTempDirectory) 20 | import qualified Data.ByteString as B 21 | import qualified Data.ByteString.Builder as BB 22 | import qualified Data.ByteString.Lazy as BL 23 | #if __GLASGOW_HASKELL__ < 820 24 | import Data.Monoid 25 | #endif 26 | 27 | data ExpectedException = 28 | ExpectedException 29 | deriving (Show) 30 | 31 | instance Exception ExpectedException 32 | 33 | spec :: Spec 34 | spec = do 35 | describe "ensureFileDurable" $ 36 | it "ensures a file is durable with an fsync" $ 37 | withSystemTempDirectory "rio" $ \dir -> do 38 | let fp = dir "ensure_file_durable" 39 | writeFile fp "Hello World" 40 | File.ensureFileDurable fp 41 | contents <- B.readFile fp 42 | contents `shouldBe` "Hello World" 43 | withBinaryFileSpec False "withBinaryFile" withBinaryFile 44 | writeBinaryFileSpec "writeBinaryFile" writeBinaryFile 45 | -- Above two specs are validating the specs behavior by applying to 46 | -- known good implementations 47 | withBinaryFileSpec True "withBinaryFileAtomic" File.withBinaryFileAtomic 48 | writeBinaryFileSpec "writeBinaryFileAtomic" File.writeBinaryFileAtomic 49 | withBinaryFileSpec False "withBinaryFileDurable" File.withBinaryFileDurable 50 | writeBinaryFileSpec "writeBinaryFileDurable" File.writeBinaryFileDurable 51 | withBinaryFileSpec True "withBinaryFileDurableAtomic" File.withBinaryFileDurableAtomic 52 | writeBinaryFileSpec "writeBinaryFileDurableAtomic" File.writeBinaryFileDurableAtomic 53 | 54 | writeFileUtf8 fp str = withBinaryFile fp WriteMode (`BB.hPutBuilder` BB.stringUtf8 str) 55 | 56 | withBinaryFileSpec :: 57 | Bool -- ^ Should we test atomicity 58 | -> String 59 | -> (forall a. FilePath -> IOMode -> (Handle -> IO a) -> IO a) 60 | -> Spec 61 | withBinaryFileSpec atomic fname withFileTestable = do 62 | let hello = "Hello World" 63 | helloString = "Hello World" 64 | writeHello fp = writeFileUtf8 fp helloString 65 | -- Create a file, write "Hello World" into it and apply the action. 66 | withHelloFileTestable fp iomode action = do 67 | writeHello fp 68 | withFileTestable fp iomode action 69 | goodbye = "Goodbye yall" 70 | modifiedPermissions = 71 | setOwnerExecutable True $ 72 | setOwnerReadable True $ setOwnerWritable True emptyPermissions 73 | describe fname $ do 74 | it "read" $ 75 | withSystemTempDirectory "rio" $ \dir -> do 76 | let fp = dir fname ++ "-read" 77 | withHelloFileTestable fp ReadWriteMode (`B.hGet` B.length hello) `shouldReturn` 78 | hello 79 | it "write" $ 80 | withSystemTempDirectory "rio" $ \dir -> do 81 | let fp = dir fname ++ "-write" 82 | withHelloFileTestable fp WriteMode (`B.hPut` goodbye) 83 | B.readFile fp `shouldReturn` goodbye 84 | it "read/write" $ 85 | withSystemTempDirectory "rio" $ \dir -> do 86 | let fp = dir fname ++ "-read-write" 87 | withHelloFileTestable fp ReadWriteMode $ \h -> do 88 | B.hGetLine h `shouldReturn` hello 89 | B.hPut h goodbye 90 | B.readFile fp `shouldReturn` (hello <> goodbye) 91 | it "append" $ 92 | withSystemTempDirectory "rio" $ \dir -> do 93 | let fp = dir fname ++ "-append" 94 | privet = "Привет Мир" -- some unicode won't hurt 95 | encodeUtf8 = BL.toStrict . BB.toLazyByteString . BB.stringUtf8 96 | writeFileUtf8 fp privet 97 | setPermissions fp modifiedPermissions 98 | withFileTestable fp AppendMode $ \h -> B.hPut h goodbye 99 | B.readFile fp `shouldReturn` (encodeUtf8 privet <> goodbye) 100 | it "sub-directory" $ 101 | withSystemTempDirectory "rio" $ \dir -> do 102 | let subDir = dir fname ++ "-sub-directory" 103 | fp = subDir "test.file" 104 | createDirectoryIfMissing True subDir 105 | withHelloFileTestable fp ReadWriteMode $ \h -> do 106 | B.hGetLine h `shouldReturn` hello 107 | B.hPut h goodbye 108 | B.readFile fp `shouldReturn` (hello <> goodbye) 109 | it "relative-directory" $ 110 | withSystemTempDirectory "rio" $ \dir -> do 111 | let relDir = fname ++ "-relative-directory" 112 | subDir = dir relDir 113 | fp = relDir "test.file" 114 | createDirectoryIfMissing True subDir 115 | withCurrentDirectoryCompat dir $ do 116 | withHelloFileTestable fp ReadWriteMode $ \h -> do 117 | B.hGetLine h `shouldReturn` hello 118 | B.hPut h goodbye 119 | B.readFile fp `shouldReturn` (hello <> goodbye) 120 | it "modified-permissions" $ 121 | forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> 122 | withSystemTempDirectory "rio" $ \dir -> do 123 | let fp = dir fname ++ "-modified-permissions" 124 | writeHello fp 125 | setPermissions fp modifiedPermissions 126 | withFileTestable fp iomode $ \h -> B.hPut h goodbye 127 | getPermissions fp `shouldReturn` modifiedPermissions 128 | it "exception - Does not corrupt files" $ 129 | bool expectFailure property atomic $ -- should fail for non-atomic 130 | forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> 131 | withSystemTempDirectory "rio" $ \dir -> do 132 | let fp = dir fname ++ "-exception" 133 | _ :: Either ExpectedException () <- 134 | try $ 135 | withHelloFileTestable fp iomode $ \h -> do 136 | B.hPut h goodbye 137 | throwIO ExpectedException 138 | B.readFile fp `shouldReturn` hello 139 | it "exception - Does not leave files behind" $ 140 | bool expectFailure property atomic $ -- should fail for non-atomic 141 | forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> 142 | withSystemTempDirectory "rio" $ \dir -> do 143 | let fp = dir fname ++ "-exception" 144 | _ :: Either ExpectedException () <- 145 | try $ 146 | withFileTestable fp iomode $ \h -> do 147 | B.hPut h goodbye 148 | throwIO ExpectedException 149 | doesFileExist fp `shouldReturn` False 150 | listDirectoryCompat dir `shouldReturn` [] 151 | it "delete - file" $ 152 | bool expectFailure property atomic $ -- should fail for non-atomic 153 | forM_ [WriteMode, ReadWriteMode, AppendMode] $ \iomode -> 154 | withSystemTempDirectory "rio" $ \dir -> do 155 | let fp = dir fname ++ "-delete" 156 | withHelloFileTestable fp iomode $ \h -> do 157 | removeFile fp 158 | B.hPut h goodbye 159 | doesFileExist fp `shouldReturn` True 160 | 161 | writeBinaryFileSpec :: String -> (FilePath -> B.ByteString -> IO ()) -> SpecWith () 162 | writeBinaryFileSpec fname writeFileTestable = do 163 | let hello = "Hello World" 164 | describe fname $ do 165 | it "write" $ 166 | withSystemTempDirectory "rio" $ \dir -> do 167 | let fp = dir fname ++ "-write" 168 | writeFileTestable fp hello 169 | B.readFile fp `shouldReturn` hello 170 | it "default-permissions" $ 171 | withSystemTempDirectory "rio" $ \dir -> do 172 | let fp = dir fname ++ "-default-permissions" 173 | defaultPermissions = 174 | setOwnerReadable True $ setOwnerWritable True emptyPermissions 175 | writeFileTestable fp hello 176 | getPermissions fp `shouldReturn` defaultPermissions 177 | 178 | 179 | listDirectoryCompat :: FilePath -> IO [FilePath] 180 | #if MIN_VERSION_directory(1,2,5) 181 | listDirectoryCompat = listDirectory 182 | #else 183 | listDirectoryCompat path = 184 | filter f <$> getDirectoryContents path 185 | where f filename = filename /= "." && filename /= ".." 186 | #endif 187 | 188 | withCurrentDirectoryCompat :: FilePath -> IO a -> IO a 189 | #if MIN_VERSION_directory(1,2,3) 190 | withCurrentDirectoryCompat = withCurrentDirectory 191 | #else 192 | withCurrentDirectoryCompat dir action = 193 | bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do 194 | setCurrentDirectory dir 195 | action 196 | #endif 197 | 198 | #else 199 | spec :: Spec 200 | spec = pure () 201 | #endif 202 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/IOSpec.hs: -------------------------------------------------------------------------------- 1 | module UnliftIO.IOSpec (spec) where 2 | 3 | import Test.Hspec 4 | import UnliftIO.IO 5 | import Control.Concurrent (threadDelay) 6 | 7 | spec :: Spec 8 | spec = do 9 | describe "getMonotonicTime" $ do 10 | it "increases" $ do 11 | x <- getMonotonicTime 12 | threadDelay 5000 13 | y <- getMonotonicTime 14 | y - x `shouldSatisfy` (>= 5e-3) 15 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/MemoizeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module UnliftIO.MemoizeSpec (spec) where 3 | 4 | import Control.Concurrent (threadDelay) 5 | import Control.Monad (replicateM_) 6 | import Test.Hspec 7 | import Test.Hspec.QuickCheck 8 | import UnliftIO 9 | import Data.Typeable 10 | 11 | data Dummy = Dummy 12 | deriving (Show, Typeable) 13 | instance Exception Dummy 14 | 15 | spec :: Spec 16 | spec = do 17 | let basics maker = do 18 | prop "sanity" $ \i -> do 19 | x <- maker $ return (i :: Int) 20 | runMemoized x `shouldReturn` i 21 | prop "runs once" $ \i -> do 22 | count <- newIORef (0 :: Int) 23 | x <- maker $ do 24 | modifyIORef' count (+ 1) 25 | return (i :: Int) 26 | replicateM_ 10 $ runMemoized x `shouldReturn` i 27 | readIORef count `shouldReturn` 1 28 | it "runs once with exception" $ do 29 | count <- newIORef (0 :: Int) 30 | x <- maker $ do 31 | modifyIORef' count (+ 1) 32 | throwIO Dummy 33 | replicateM_ 10 $ runMemoized x `shouldThrow` (\Dummy -> True) 34 | readIORef count `shouldReturn` 1 35 | describe "memoizeRef" $ basics memoizeRef 36 | describe "memoizeMVar" $ do 37 | basics memoizeMVar 38 | prop "runs once in multiple threads" $ \i -> do 39 | count <- newIORef (0 :: Int) 40 | x <- memoizeMVar $ do 41 | threadDelay 10000 42 | atomicModifyIORef' count $ \cnt -> (cnt + 1, ()) 43 | return (i :: Int) 44 | replicateConcurrently_ 10 $ runMemoized x `shouldReturn` i 45 | readIORef count `shouldReturn` 1 46 | -------------------------------------------------------------------------------- /unliftio/test/UnliftIO/PooledAsyncSpec.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE DeriveDataTypeable#-} 2 | {-#LANGUAGE BangPatterns#-} 3 | 4 | module UnliftIO.PooledAsyncSpec (spec) where 5 | 6 | import Test.Hspec 7 | import Control.Concurrent 8 | import Data.List (sort) 9 | import Test.QuickCheck 10 | import qualified Data.Set as Set 11 | import Data.Functor ((<$>)) 12 | import UnliftIO 13 | 14 | data MyPooledException = PoolHellException 15 | deriving (Show, Typeable) 16 | 17 | instance Exception MyPooledException 18 | 19 | -- | Strip out duplicates. (Taken from rio) 20 | nubOrd :: Ord a => [a] -> [a] 21 | nubOrd = 22 | loop Set.empty 23 | where 24 | loop _ [] = [] 25 | loop !s (a:as) 26 | | a `Set.member` s = loop s as 27 | | otherwise = a : loop (Set.insert a s) as 28 | 29 | spec :: Spec 30 | spec = do 31 | let exAction :: Int -> IO Int 32 | exAction x = do 33 | if (x == 2) then throwIO PoolHellException else return () 34 | return x 35 | 36 | action :: Int -> IO ThreadId 37 | action x = do 38 | threadDelay (2 * 10^5) 39 | myThreadId 40 | 41 | myVar :: IO (TVar Int) 42 | myVar = atomically $ newTVar 0 43 | 44 | maxTVar :: Int -> TVar Int -> IO () 45 | maxTVar cval tvar = do 46 | atomically $ do 47 | v <- readTVar tvar 48 | if cval >= v 49 | then writeTVar tvar cval 50 | else return () 51 | 52 | poolException :: Selector MyPooledException 53 | poolException = const True 54 | 55 | describe "pooled mapConcurrencyN" $ do 56 | it "Throws exception properly" $ do 57 | (pooledMapConcurrentlyN 5 exAction [1..5]) `shouldThrow` poolException 58 | 59 | it "total thread should be >= 1" $ do 60 | (pooledMapConcurrentlyN 0 action [1..5]) `shouldThrow` anyErrorCall 61 | 62 | it "should not spawn more than five threads for five concurrent tasks" $ do 63 | xs <- (pooledMapConcurrentlyN 5 action [1..5]) 64 | (length $ nubOrd xs) `shouldSatisfy` (<= (5 :: Int)) 65 | 66 | it "should not spawn more than three threads for five concurrent tasks" $ do 67 | xs <- (pooledMapConcurrentlyN 3 action [1..5]) 68 | (length $ nubOrd xs) `shouldSatisfy` (<= (3 :: Int)) 69 | 70 | it "should spawn only one thread" $ do 71 | xs <- (pooledMapConcurrentlyN 1 action [1..5]) 72 | (length $ nubOrd xs) `shouldBe` 1 73 | 74 | it "never uses more than the given number of pools and doesn't miss any return values" $ 75 | forAllShrink ((+ 1) . abs <$> arbitrary) (filter (>= 1) . shrink) $ \threads -> 76 | property $ \list -> do 77 | threadIdsVar <- newTVarIO [] 78 | let go :: Int -> IO Int 79 | go i = do 80 | tid <- myThreadId 81 | atomically $ modifyTVar threadIdsVar (tid :) 82 | return i 83 | list' <- pooledMapConcurrentlyN threads go list 84 | sort list' `shouldBe` sort list 85 | tids <- readTVarIO threadIdsVar 86 | length (nubOrd tids) `shouldSatisfy` (<= threads) 87 | 88 | describe "pooled mapConcurrencyN_" $ do 89 | it "Throws exception properly" $ do 90 | (pooledMapConcurrentlyN_ 5 exAction [1..5]) `shouldThrow` poolException 91 | 92 | it "total thread should be >= 1" $ do 93 | (pooledMapConcurrentlyN_ 0 action [1..5]) `shouldThrow` anyErrorCall 94 | 95 | it "find proper maximum value" $ do 96 | var <- myVar 97 | xs <- (pooledMapConcurrentlyN_ 5 (\x -> maxTVar x var) [1..5]) 98 | newVar <- atomically $ readTVar var 99 | atomically $ writeTVar var 0 100 | newVar `shouldBe` 5 101 | 102 | it "find proper maximum value with 2 threads" $ do 103 | var <- myVar 104 | xs <- (pooledMapConcurrentlyN_ 2 (\x -> maxTVar x var) [1..5]) 105 | newVar <- atomically $ readTVar var 106 | atomically $ writeTVar var 0 107 | newVar `shouldBe` 5 108 | 109 | it "find proper maximum value with 1 threads" $ do 110 | var <- myVar 111 | xs <- (pooledMapConcurrentlyN_ 1 (\x -> maxTVar x var) [1..5]) 112 | newVar <- atomically $ readTVar var 113 | atomically $ writeTVar var 0 114 | newVar `shouldBe` 5 115 | 116 | it "make sure activity is happening in different threads" $ do 117 | let myThreads :: IO (TVar [ThreadId]) 118 | myThreads = atomically $ newTVar [] 119 | 120 | collectThreads :: TVar [ThreadId] -> IO () 121 | collectThreads threadVar = do 122 | tid <- myThreadId 123 | atomically $ do 124 | tvar <- readTVar threadVar 125 | writeTVar threadVar (tid:tvar) 126 | threadDelay $ 2 * 10^5 127 | 128 | tid <- myThreads 129 | xs <- pooledMapConcurrentlyN_ 5 (\_ -> collectThreads tid) [1..5] 130 | tids <- atomically $ readTVar tid 131 | (length $ nubOrd tids) `shouldSatisfy` (<= 5) 132 | 133 | it "Not more than 5 threads will be spawned even if pooling is set to 8 " $ do 134 | let myThreads :: IO (TVar [ThreadId]) 135 | myThreads = atomically $ newTVar [] 136 | 137 | collectThreads :: TVar [ThreadId] -> IO () 138 | collectThreads threadVar = do 139 | tid <- myThreadId 140 | atomically $ do 141 | tvar <- readTVar threadVar 142 | writeTVar threadVar (tid:tvar) 143 | threadDelay $ 2 * 10^5 144 | 145 | tid <- myThreads 146 | xs <- pooledMapConcurrentlyN_ 8 (\_ -> collectThreads tid) [1..5] 147 | tids <- atomically $ readTVar tid 148 | (length $ nubOrd tids) `shouldSatisfy` (<= 5) 149 | 150 | describe "replicate concurrencyN" $ do 151 | it "Throws exception properly" $ do 152 | (pooledReplicateConcurrentlyN 5 1 (exAction 2)) `shouldThrow` poolException 153 | 154 | it "total thread should be >= 1" $ do 155 | (pooledReplicateConcurrentlyN 0 1 (action 1)) `shouldThrow` anyErrorCall 156 | 157 | it "Read tvar value should be 100" $ do 158 | var <- myVar 159 | xs <- (pooledReplicateConcurrentlyN 5 5 (maxTVar 100 var)) 160 | newVar <- atomically $ readTVar var 161 | atomically $ writeTVar var 0 162 | newVar `shouldBe` 100 163 | 164 | it "should not spawn more than five threads for five concurrent tasks" $ do 165 | xs <- (pooledReplicateConcurrentlyN 5 5 (action 1)) 166 | (length $ nubOrd xs) `shouldSatisfy` (<= (5 :: Int)) 167 | 168 | it "should not spawn more than three threads for five concurrent tasks" $ do 169 | xs <- (pooledReplicateConcurrentlyN 3 5 (action 1)) 170 | (length $ nubOrd xs) `shouldSatisfy` (<= (3 :: Int)) 171 | 172 | it "should spawn only one thread" $ do 173 | xs <- (pooledReplicateConcurrentlyN 1 5 (action 1)) 174 | (length $ nubOrd xs) `shouldBe` 1 175 | 176 | it "should give empty list" $ do 177 | xs <- (pooledReplicateConcurrentlyN 3 0 (action 1)) 178 | xs `shouldBe` [] 179 | 180 | it "should give empty list for -ve count" $ do 181 | xs <- (pooledReplicateConcurrentlyN 3 (-3) (action 1)) 182 | xs `shouldBe` [] 183 | 184 | describe "pooled replicateConcurrencyN_" $ do 185 | it "Throws exception properly" $ do 186 | (pooledReplicateConcurrentlyN_ 5 1 (exAction 2)) `shouldThrow` poolException 187 | 188 | it "total thread should be >= 1" $ do 189 | (pooledReplicateConcurrentlyN_ 0 2 (action 1)) `shouldThrow` anyErrorCall 190 | 191 | it "find proper maximum value" $ do 192 | var <- myVar 193 | pooledReplicateConcurrentlyN_ 5 3 (maxTVar 200 var) 194 | newVar <- atomically $ readTVar var 195 | atomically $ writeTVar var 0 196 | newVar `shouldBe` 200 197 | 198 | it "Should be initial value" $ do 199 | var <- myVar 200 | pooledReplicateConcurrentlyN_ 5 (-2) (maxTVar 200 var) 201 | newVar <- atomically $ readTVar var 202 | atomically $ writeTVar var 0 203 | newVar `shouldBe` 0 204 | --------------------------------------------------------------------------------