blockio (empty) → 0.1.0.0
raw patch · 17 files changed
+2375/−0 lines, 17 filesdep +QuickCheckdep +Win32dep +async
Dependencies added: QuickCheck, Win32, async, base, blockio, blockio-uring, bytestring, deepseq, fs-api, fs-sim, io-classes, primitive, tasty, tasty-hunit, tasty-quickcheck, temporary, unix, vector
Files
- CHANGELOG.md +5/−0
- LICENSE +201/−0
- NOTICE +13/−0
- blockio.cabal +163/−0
- src-linux/System/FS/BlockIO/Async.hs +160/−0
- src-linux/System/FS/BlockIO/Internal.hs +78/−0
- src-macos/System/FS/BlockIO/Internal.hs +55/−0
- src-sim/System/FS/BlockIO/Sim.hs +324/−0
- src-windows/System/FS/BlockIO/Internal.hs +61/−0
- src/System/FS/BlockIO.hs +195/−0
- src/System/FS/BlockIO/API.hs +284/−0
- src/System/FS/BlockIO/IO.hs +175/−0
- src/System/FS/BlockIO/IO/Internal.hs +122/−0
- src/System/FS/BlockIO/Serial.hs +140/−0
- src/System/FS/BlockIO/Serial/Internal.hs +12/−0
- test-sim/Main.hs +90/−0
- test/Main.hs +297/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for blockio++## 0.1.0.0 -- 2025-07-15++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,201 @@+ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ NOTICE view
@@ -0,0 +1,13 @@+Copyright (c) 2023-2025 Cardano Development Foundation++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ blockio.cabal view
@@ -0,0 +1,163 @@+cabal-version: 3.4+name: blockio+version: 0.1.0.0+synopsis: Perform batches of disk I/O operations.+description:+ Perform batches of disk I\/O operations. Performing batches of disk I\/O can+ lead to performance improvements over performing each disk I\/O operation+ individually. Performing batches of disk I\/O /concurrently/ can lead to an+ even bigger performance improvement depending on the implementation of batched+ I\/O.++ The batched I\/O functionality in the library is separated into an /abstract/+ /interface/ and /implementations/ of that abstract interface. The advantage of+ programming against an abstract interface is that code can be agnostic to the+ implementation of the interface, allowing implementations to be freely swapped+ out. The library provides multiple implementations of batched I\/O:+ platform-dependent implementations using the /real/ file system (with+ asynchronous I\/O), and a simulated implementation for testing purposes.++ See the "System.FS.BlockIO" module for an example of how to use the library.++license: Apache-2.0+license-files:+ LICENSE+ NOTICE++author:+ Duncan Coutts, Joris Dral, Matthias Heinzel, Wolfgang Jeltsch, Wen Kokke, and Alex Washburn++maintainer: joris@well-typed.com+copyright: (c) 2023-2025 Cardano Development Foundation+category: System+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12++source-repository head+ type: git+ location: https://github.com/IntersectMBO/lsm-tree+ subdir: blockio++source-repository this+ type: git+ location: https://github.com/IntersectMBO/lsm-tree+ subdir: blockio+ tag: blockio-0.1.0.0++common warnings+ ghc-options:+ -Wall -Wcompat -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wpartial-fields -Widentities+ -Wredundant-constraints -Wmissing-export-lists+ -Wno-unticked-promoted-constructors -Wunused-packages++ ghc-options: -Werror=missing-deriving-strategies++common language+ default-language: GHC2021+ default-extensions:+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ LambdaCase++flag serialblockio+ description: Use serial HasBlockIO regardless of the operating system+ default: False+ manual: True++library+ import: language, warnings+ hs-source-dirs: src+ exposed-modules:+ System.FS.BlockIO+ System.FS.BlockIO.API+ System.FS.BlockIO.IO+ System.FS.BlockIO.Serial.Internal++ other-modules:+ System.FS.BlockIO.IO.Internal+ System.FS.BlockIO.Serial++ build-depends:+ , base >=4.16 && <4.22+ , deepseq ^>=1.4 || ^>=1.5+ , fs-api ^>=0.4+ , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1+ , primitive ^>=0.9+ , vector ^>=0.13++ if os(linux)+ hs-source-dirs: src-linux+ other-modules: System.FS.BlockIO.Internal+ build-depends: unix ^>=2.8.7++ if !flag(serialblockio)+ other-modules: System.FS.BlockIO.Async+ build-depends: blockio-uring ^>=0.1++ elif os(osx)+ hs-source-dirs: src-macos+ build-depends: unix ^>=2.8.7+ other-modules: System.FS.BlockIO.Internal++ elif os(windows)+ hs-source-dirs: src-windows+ build-depends: Win32 ^>=2.14+ other-modules: System.FS.BlockIO.Internal++ if flag(serialblockio)+ cpp-options: -DSERIALBLOCKIO++test-suite test+ import: language, warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ , async+ , base <5+ , blockio+ , bytestring+ , fs-api+ , primitive+ , QuickCheck >=2.15.0.1+ , tasty+ , tasty-hunit+ , tasty-quickcheck+ , temporary+ , vector++ ghc-options: -threaded++library sim+ import: language, warnings+ visibility: public+ hs-source-dirs: src-sim+ exposed-modules: System.FS.BlockIO.Sim+ build-depends:+ , base >=4.16 && <4.22+ , blockio+ , bytestring ^>=0.11 || ^>=0.12+ , fs-api ^>=0.4+ , fs-sim ^>=0.4+ , io-classes ^>=1.6 || ^>=1.7 || ^>=1.8.0.1+ , io-classes:strict-stm+ , primitive ^>=0.9++test-suite test-sim+ import: language, warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: test-sim+ main-is: Main.hs+ build-depends:+ , base <5+ , blockio+ , blockio:sim+ , fs-api+ , fs-sim+ , io-classes:strict-stm+ , QuickCheck+ , tasty+ , tasty-quickcheck
+ src-linux/System/FS/BlockIO/Async.hs view
@@ -0,0 +1,160 @@+module System.FS.BlockIO.Async (+ asyncHasBlockIO+ ) where++import Control.Exception+import qualified Control.Exception as E+import Control.Monad.Primitive+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import Foreign.C.Error+import GHC.IO.Exception+import GHC.Stack+import System.FS.API (BufferOffset (..), FsErrorPath, FsPath,+ Handle (..), HasFS (..), ioToFsError)+import qualified System.FS.BlockIO.API as API+import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode,+ ioopHandle)+import qualified System.FS.BlockIO.IO.Internal as IOI+import System.FS.IO (HandleIO)+import System.FS.IO.Handle+import qualified System.IO.BlockIO as I+import System.IO.Error (ioeGetErrorType, ioeSetErrorString,+ isResourceVanishedError)+import System.Posix.Types++-- | IO instantiation of 'HasBlockIO', using @blockio-uring@.+asyncHasBlockIO ::+ (Handle HandleIO -> Bool -> IO ())+ -> (Handle HandleIO -> FileOffset -> FileOffset -> API.Advice -> IO ())+ -> (Handle HandleIO -> FileOffset -> FileOffset -> IO ())+ -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO)))+ -> (Handle HandleIO -> IO ())+ -> (FsPath -> IO ())+ -> (FsPath -> FsPath -> IO ())+ -> HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> IO (API.HasBlockIO IO HandleIO)+asyncHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hasFS ctxParams = do+ ctx <- I.initIOCtx (ctxParamsConv ctxParams)+ pure $ API.HasBlockIO {+ API.close = I.closeIOCtx ctx+ , API.submitIO = submitIO hasFS ctx+ , API.hSetNoCache+ , API.hAdvise+ , API.hAllocate+ , API.tryLockFile+ , API.hSynchronise+ , API.synchroniseDirectory+ , API.createHardLink+ }++ctxParamsConv :: IOI.IOCtxParams -> I.IOCtxParams+ctxParamsConv IOI.IOCtxParams{IOI.ioctxBatchSizeLimit, IOI.ioctxConcurrencyLimit} =+ I.IOCtxParams {+ I.ioctxBatchSizeLimit = ioctxBatchSizeLimit+ , I.ioctxConcurrencyLimit = ioctxConcurrencyLimit+ }++submitIO ::+ HasCallStack+ => HasFS IO HandleIO+ -> I.IOCtx+ -> V.Vector (IOOp RealWorld HandleIO)+ -> IO (VU.Vector IOResult)+submitIO hasFS ioctx ioops = do+ ioops' <- mapM ioopConv ioops+ ress <- I.submitIO ioctx ioops' `catch` rethrowFsError+ hzipWithM rethrowErrno ioops ress+ where+ rethrowFsError :: IOError -> IO a+ rethrowFsError e@IOError{}+ -- Pattern matching on the error is brittle, because the structure of+ -- the exception might change between versions of @blockio-uring@.+ -- Nonetheless, it's better than nothing.+ | isResourceVanishedError e+ , ioe_location e == "IOCtx closed"+ = throwIO (IOI.mkClosedError hasFS "submitIO")+ | ioeGetErrorType e == InvalidArgument+ , ioe_location e == "MutableByteArray is unpinned"+ = throwIO (IOI.mkNotPinnedError hasFS "submitIO")+ | otherwise+ = throwIO e++ rethrowErrno ::+ HasCallStack+ => IOOp RealWorld HandleIO+ -> I.IOResult+ -> IO IOResult+ rethrowErrno ioop res = do+ case res of+ I.IOResult c -> pure (IOResult c)+ I.IOError e -> throwAsFsError e+ where+ throwAsFsError :: HasCallStack => Errno -> IO a+ throwAsFsError errno = E.throwIO $ ioToFsError fep (fromErrno errno)++ fep :: FsErrorPath+ fep = mkFsErrorPath hasFS (handlePath (ioopHandle ioop))++ fromErrno :: Errno -> IOError+ fromErrno errno = ioeSetErrorString+ (errnoToIOError "submitIO" errno Nothing Nothing)+ ("submitIO failed: " <> ioopType)++ ioopType :: String+ ioopType = case ioop of+ IOOpRead{} -> "IOOpRead"+ IOOpWrite{} -> "IOOpWrite"++ioopConv :: IOOp RealWorld HandleIO -> IO (I.IOOp RealWorld)+ioopConv (IOOpRead h off buf bufOff c) = handleFd h >>= \fd ->+ pure (I.IOOpRead fd off buf (unBufferOffset bufOff) c)+ioopConv (IOOpWrite h off buf bufOff c) = handleFd h >>= \fd ->+ pure (I.IOOpWrite fd off buf (unBufferOffset bufOff) c)++-- This only checks whether the handle is open when we convert to an Fd. After+-- that, the handle could be closed when we're still performing blockio+-- operations.+--+-- TODO: if the handle were to have a reader/writer lock, then we could take the+-- reader lock in 'submitIO'. However, the current implementation of 'Handle'+-- only allows mutually exclusive access to the underlying file descriptor, so it+-- would require a change in @fs-api@. See [fs-sim#49].+handleFd :: Handle HandleIO -> IO Fd+handleFd h = withOpenHandle "submitIO" (handleRaw h) pure++{-# SPECIALISE hzipWithM ::+ (VUM.Unbox b, VUM.Unbox c)+ => (a -> b -> IO c)+ -> V.Vector a+ -> VU.Vector b+ -> IO (VU.Vector c)+ #-}+-- | Heterogeneous blend of `V.zipWithM` and `VU.zipWithM`+--+-- The @vector@ package does not provide functions that take distinct vector+-- containers as arguments, so we write it by hand to prevent having to convert+-- one vector type to the other.+hzipWithM ::+ forall m a b c. (PrimMonad m, VUM.Unbox b, VUM.Unbox c)+ => (a -> b -> m c)+ -> V.Vector a+ -> VU.Vector b+ -> m (VU.Vector c)+hzipWithM f v1 v2 = do+ res <- VUM.unsafeNew n+ loop res 0+ where+ !n = min (V.length v1) (VU.length v2)++ loop :: VUM.MVector (PrimState m) c -> Int -> m (VU.Vector c)+ loop !res !i+ | i == n = VU.unsafeFreeze res+ | otherwise = do+ let !x = v1 `V.unsafeIndex` i+ !y = v2 `VU.unsafeIndex` i+ !z <- f x y+ VUM.write res i z+ loop res (i+1)
+ src-linux/System/FS/BlockIO/Internal.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}++module System.FS.BlockIO.Internal (+ ioHasBlockIO+ ) where++import qualified System.FS.API as FS+import System.FS.API (FsPath, Handle (..), HasFS)+import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO)+import qualified System.FS.BlockIO.IO.Internal as IOI+import System.FS.IO (HandleIO)+import qualified System.FS.IO.Handle as FS+import qualified System.Posix.Fcntl as Fcntl+import qualified System.Posix.Files as Unix+import qualified System.Posix.Unistd as Unix++#if SERIALBLOCKIO+import qualified System.FS.BlockIO.Serial as Serial+#else+import qualified System.FS.BlockIO.Async as Async+#endif++ioHasBlockIO ::+ HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> IO (HasBlockIO IO HandleIO)+#if SERIALBLOCKIO+ioHasBlockIO hfs _params =+ Serial.serialHasBlockIO+ hSetNoCache+ hAdvise+ hAllocate+ (IOI.tryLockFileIO hfs)+ hSynchronise+ (synchroniseDirectory hfs)+ (IOI.createHardLinkIO hfs Unix.createLink)+ hfs+#else+ioHasBlockIO hfs params =+ Async.asyncHasBlockIO+ hSetNoCache+ hAdvise+ hAllocate+ (IOI.tryLockFileIO hfs)+ hSynchronise+ (synchroniseDirectory hfs)+ (IOI.createHardLinkIO hfs Unix.createLink)+ hfs+ params+#endif++hSetNoCache :: Handle HandleIO -> Bool -> IO ()+hSetNoCache h b =+ FS.withOpenHandle "hSetNoCache" (handleRaw h) (flip Fcntl.fileSetCaching (not b))++hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()+hAdvise h off len advice = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd ->+ Fcntl.fileAdvise fd off len advice'+ where+ advice' = case advice of+ AdviceNormal -> Fcntl.AdviceNormal+ AdviceRandom -> Fcntl.AdviceRandom+ AdviceSequential -> Fcntl.AdviceSequential+ AdviceWillNeed -> Fcntl.AdviceWillNeed+ AdviceDontNeed -> Fcntl.AdviceDontNeed+ AdviceNoReuse -> Fcntl.AdviceNoReuse++hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO ()+hAllocate h off len = FS.withOpenHandle "hAllocate" (handleRaw h) $ \fd ->+ Fcntl.fileAllocate fd off len++hSynchronise :: Handle HandleIO -> IO ()+hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd ->+ Unix.fileSynchronise fd++synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO ()+synchroniseDirectory hfs path =+ FS.withFile hfs path FS.ReadMode $ hSynchronise
+ src-macos/System/FS/BlockIO/Internal.hs view
@@ -0,0 +1,55 @@+module System.FS.BlockIO.Internal (+ ioHasBlockIO+ ) where++import qualified System.FS.API as FS+import System.FS.API (FsPath, Handle (..), HasFS)+import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO)+import qualified System.FS.BlockIO.IO.Internal as IOI+import qualified System.FS.BlockIO.Serial as Serial+import System.FS.IO (HandleIO)+import qualified System.FS.IO.Handle as FS+import qualified System.Posix.Fcntl as Unix+import qualified System.Posix.Files as Unix+import qualified System.Posix.Unistd as Unix++-- | For now we use the portable serial implementation of HasBlockIO. If you+-- want to provide a proper async I\/O implementation for OSX, then this is where+-- you should put it.+--+-- The recommended choice would be to use the POSIX AIO API.+ioHasBlockIO ::+ HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> IO (HasBlockIO IO HandleIO)+ioHasBlockIO hfs _params =+ Serial.serialHasBlockIO+ hSetNoCache+ hAdvise+ hAllocate+ (IOI.tryLockFileIO hfs)+ hSynchronise+ (synchroniseDirectory hfs)+ (IOI.createHardLinkIO hfs Unix.createLink)+ hfs++hSetNoCache :: Handle HandleIO -> Bool -> IO ()+hSetNoCache h b =+ FS.withOpenHandle "hSetNoCache" (handleRaw h) (flip Unix.fileSetCaching (not b))++-- TODO: it is unclear if MacOS supports @posix_fadvise(2)@, and it's hard to+-- check because there are no manual pages online. For now, it's just hardcoded+-- to be a no-op.+hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()+hAdvise _h _off _len _advice = pure ()++hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO ()+hAllocate _h _off _len = pure ()++hSynchronise :: Handle HandleIO -> IO ()+hSynchronise h = FS.withOpenHandle "hSynchronise" (handleRaw h) $ \fd ->+ Unix.fileSynchronise fd++synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO ()+synchroniseDirectory hfs path =+ FS.withFile hfs path FS.ReadMode $ hSynchronise
+ src-sim/System/FS/BlockIO/Sim.hs view
@@ -0,0 +1,324 @@+-- | Simulated instances of 'HasBlockIO' and 'HasFS'.+module System.FS.BlockIO.Sim (+ -- * Implementation details #impl#+ -- $impl++ -- * Runners+ runSimHasBlockIO+ , runSimErrorHasBlockIO+ -- * Initialisation+ , simHasBlockIO+ , simHasBlockIO'+ , simErrorHasBlockIO+ , simErrorHasBlockIO'+ -- ** Unsafe+ , unsafeFromHasFS+ ) where++import Control.Concurrent.Class.MonadMVar+import Control.Concurrent.Class.MonadSTM.Strict+import Control.Monad (void)+import Control.Monad.Class.MonadThrow+import Control.Monad.Primitive (PrimMonad)+import qualified Data.ByteString.Char8 as BS+import System.FS.API as API+import qualified System.FS.API.Lazy as API+import qualified System.FS.API.Strict as API+import System.FS.BlockIO.API (HasBlockIO (..), LockFileHandle (..),+ LockMode (..))+import System.FS.BlockIO.Serial.Internal+import System.FS.CallStack (prettyCallStack)+import System.FS.Sim.Error+import System.FS.Sim.MockFS hiding (hClose, hOpen)+import System.FS.Sim.STM++{- $impl++ We include below some documentation about the effects of calling the interface+ functions on the simulated instance of the 'HasBlockIO' interface.++ [IO context]: For uniform behaviour across implementations, the simulation+ creates and stores a mocked IO context that has the open/closed behaviour+ that is specified by the interface.++ ['close']: Close the mocked context++ ['submitIO']: Submit a batch of I\/O operations using serial I\/O using a+ 'HasFS'++ ['hSetNoCache']: No-op++ ['hAdvise']: No-op++ ['hAllocate']: No-op++ ['tryLockFile']: Simulate a lock by putting the lock state into the file+ contents++ ['hSynchronise']: No-op++ ['synchroniseDirectory']: No-op++ ['createHardLink']: Copy all file contents from the source path to the target+ path. Therefore, this is currently only correctly simulating hard links+ for /immutable/ files.+-}++-- | Simulate a 'HasBlockIO' using the given 'HasFS'.+--+-- === Unsafe+--+-- You will probably want to use one of the safe functions like+-- 'runSimHasBlockIO' or 'simErrorHasBlockIO' instead.+--+-- Only a simulated 'HasFS', like the 'simHasFS' and 'simErrorHasFS'+-- simulations, should be passed to 'unsafeFromHasFS'. Technically, one could+-- pass a 'HasFS' for the /real/ file system, but then the resulting+-- 'HasBlockIO' would contain a mix of simulated functions and real functions,+-- which is probably not what you want.+unsafeFromHasFS ::+ forall m. (MonadCatch m, MonadMVar m, PrimMonad m)+ => HasFS m HandleMock+ -> m (HasBlockIO m HandleMock)+unsafeFromHasFS hfs =+ serialHasBlockIO+ hSetNoCache+ hAdvise+ hAllocate+ (simTryLockFile hfs)+ simHSynchronise+ simSynchroniseDirectory+ (simCreateHardLink hfs)+ hfs+ where+ -- TODO: It should be possible for the implementations and simulation to+ -- throw an FsError when doing file I\/O with misaligned byte arrays after+ -- hSetNoCache. Maybe they should? It might be nicest to move hSetNoCache+ -- into fs-api and fs-sim because we'd need access to the internals.+ hSetNoCache _h _b = pure ()+ hAdvise _ _ _ _ = pure ()+ hAllocate _ _ _ = pure ()++ -- Disk operations are durable by construction+ simHSynchronise _ = pure ()+ simSynchroniseDirectory _ = pure ()++-- | Lock files are reader\/writer locks.+--+-- We implement this using the content of the lock file. The content is a+-- counter, positive for readers and negative (specifically -1) for writers.+-- There can be any number of readers, but only one writer. Writers can not+-- coexist with readers.+--+-- Warning: This implementation is not robust under concurrent use (because+-- operations on files are not atomic) but should be ok for casual use. A+-- proper implementation would need to be part of the underlying 'HasFS'+-- implementations.+--+-- Warning: regular file operations on the "locked" file, like 'hOpen' or+-- 'removeFile', will still work. 'simTryLockFile' only defines how multiple+-- lock acquisitions on the same file interact, not how lock acquisition+-- interacts with other file operations.+--+simTryLockFile ::+ forall m h. MonadThrow m+ => HasFS m h+ -> FsPath+ -> LockMode+ -> m (Maybe (LockFileHandle m))+simTryLockFile hfs path lockmode =+ API.withFile hfs path (ReadWriteMode AllowExisting) $ \h -> do+ n <- readCount h+ case lockmode of+ SharedLock | n >= 0 -> do writeCount h (n+1)+ mkLockFileHandle+ ExclusiveLock | n == 0 -> do writeCount h (-1)+ mkLockFileHandle+ _ -> pure Nothing+ where+ mkLockFileHandle = do+ -- A lock file handle keeps open the file in read mode, such that a locked+ -- file contributes to the number of open file handles. The mock FS allows+ -- multiple readers and up to one writer to open the file concurrently.+ h <- API.hOpen hfs path ReadMode+ pure (Just (LockFileHandle { hUnlock = hUnlock h }))++ hUnlock h0 =+ API.withFile hfs path (ReadWriteMode AllowExisting) $ \h -> do+ n <- readCount h+ case lockmode of+ SharedLock | n > 0 -> writeCount h (n-1)+ ExclusiveLock | n == -1 -> writeCount h 0+ _ -> throwIO countCorrupt+ hClose hfs h0++ readCount :: Handle h -> m Int+ readCount h = do+ content <- BS.toStrict <$> API.hGetAllAt hfs h 0+ case reads (BS.unpack content) of+ _ | BS.null content -> pure 0+ [(n, "")] -> pure n+ _ -> throwIO countCorrupt++ writeCount :: Handle h -> Int -> m ()+ writeCount h n = do+ API.hSeek hfs h AbsoluteSeek 0+ _ <- API.hPutAllStrict hfs h (BS.pack (show n))+ pure ()++ countCorrupt =+ FsError {+ fsErrorType = FsOther,+ fsErrorPath = fsToFsErrorPathUnmounted path,+ fsErrorString = "lock file content corrupted",+ fsErrorNo = Nothing,+ fsErrorStack = prettyCallStack,+ fsLimitation = False+ }++-- | @'simCreateHardLink' hfs source target@ creates a simulated hard link for+-- the @source@ path at the @target@ path.+--+-- The hard link is simulated by simply copying the source file to the target+-- path, which means that it should only be used to create hard links for files+-- that are not modified afterwards!+--+-- TODO: if we wanted to simulate proper hard links, we would have to bake the+-- feature into @fs-sim@.+simCreateHardLink :: MonadThrow m => HasFS m h -> FsPath -> FsPath -> m ()+simCreateHardLink hfs sourcePath targetPath =+ API.withFile hfs sourcePath API.ReadMode $ \sourceHandle ->+ API.withFile hfs targetPath (API.WriteMode API.MustBeNew) $ \targetHandle -> do+ -- This should /hopefully/ stream using lazy IO+ bs <- API.hGetAll hfs sourceHandle+ void $ API.hPutAll hfs targetHandle bs++{-------------------------------------------------------------------------------+ Runners+-------------------------------------------------------------------------------}++-- | @'runSimHasBlockIO' mockFS action@ runs an @action@ using a pair of+-- simulated 'HasFS' and 'HasBlockIO'.+--+-- The pair of interfaces share the same mocked file system. The initial state+-- of the mocked file system is set to @mockFs@. The final state of the mocked+-- file system is returned with the result of @action@.+--+-- If you want to have access to the current state of the mocked file system,+-- use 'simHasBlockIO' instead.+runSimHasBlockIO ::+ (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m)+ => MockFS+ -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a)+ -> m (a, MockFS)+runSimHasBlockIO mockFS k = do+ runSimFS mockFS $ \hfs -> do+ hbio <- unsafeFromHasFS hfs+ k hfs hbio++-- | @'runSimErrorHasBlockIO' mockFS errors action@ runs an @action@ using a+-- pair of simulated 'HasFS' and 'HasBlockIO' that allow fault injection.+--+-- The pair of interfaces share the same mocked file system. The initial state+-- of the mocked file system is set to @mockFs@. The final state of the mocked+-- file system is returned with the result of @action@.+--+-- The pair of interfaces share the same stream of errors. The initial state of+-- the stream of errors is set to @errors@. The final state of the stream of+-- errors is returned with the result of @action@.+--+-- If you want to have access to the current state of the mocked file system+-- or stream of errors, use 'simErrorHasBlockIO' instead.+runSimErrorHasBlockIO ::+ (MonadSTM m, PrimMonad m, MonadCatch m, MonadMVar m)+ => MockFS+ -> Errors+ -> (HasFS m HandleMock -> HasBlockIO m HandleMock -> m a)+ -> m (a, MockFS, Errors)+runSimErrorHasBlockIO mockFS errs k = do+ fsVar <- newTMVarIO mockFS+ errorsVar <- newTVarIO errs+ (hfs, hbio) <- simErrorHasBlockIO fsVar errorsVar+ a <- k hfs hbio+ fs' <- atomically $ takeTMVar fsVar+ errs' <- readTVarIO errorsVar+ pure (a, fs', errs')++{-------------------------------------------------------------------------------+ Initialisation+-------------------------------------------------------------------------------}++-- | @'simHasBlockIO' mockFsVar@ creates a pair of simulated 'HasFS' and+-- 'HasBlockIO'.+--+-- The pair of interfaces share the same mocked file system, which is stored in+-- @mockFsVar@. The current state of the mocked file system can be accessed by+-- the user by reading @mockFsVar@, but note that the user should not leave+-- @mockFsVar@ empty.+simHasBlockIO ::+ (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)+ => StrictTMVar m MockFS+ -> m (HasFS m HandleMock, HasBlockIO m HandleMock)+simHasBlockIO var = do+ let hfs = simHasFS var+ hbio <- unsafeFromHasFS hfs+ pure (hfs, hbio)++-- | @'simHasBlockIO' mockFs@ creates a pair of simulated 'HasFS' and+-- 'HasBlockIO' that allow fault injection.+--+-- The pair of interfaces share the same mocked file system. The initial state+-- of the mocked file system is set to @mockFs@.+--+-- If you want to have access to the current state of the mocked file system,+-- use 'simHasBlockIO' instead.+simHasBlockIO' ::+ (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)+ => MockFS+ -> m (HasFS m HandleMock, HasBlockIO m HandleMock)+simHasBlockIO' mockFS = do+ hfs <- simHasFS' mockFS+ hbio <- unsafeFromHasFS hfs+ pure (hfs, hbio)++-- | @'simErrorHasBlockIO' mockFsVar errorsVar@ creates a pair of simulated+-- 'HasFS' and 'HasBlockIO' that allow fault injection.+--+-- The pair of interfaces share the same mocked file system, which is stored in+-- @mockFsVar@. The current state of the mocked file system can be accessed by+-- the user by reading @mockFsVar@, but note that the user should not leave+-- @mockFsVar@ empty.+--+-- The pair of interfaces share the same stream of errors, which is stored in+-- @errorsVar@. The current state of the stream of errors can be accessed by the+-- user by reading @errorsVar@.+simErrorHasBlockIO ::+ forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)+ => StrictTMVar m MockFS+ -> StrictTVar m Errors+ -> m (HasFS m HandleMock, HasBlockIO m HandleMock)+simErrorHasBlockIO fsVar errorsVar = do+ let hfs = simErrorHasFS fsVar errorsVar+ hbio <- unsafeFromHasFS hfs+ pure (hfs, hbio)++-- | @'simErrorHasBlockIO' mockFs errors@ creates a pair of simulated 'HasFS'+-- and 'HasBlockIO' that allow fault injection.+--+-- The pair of interfaces share the same mocked file system. The initial state+-- of the mocked file system is set to @mockFs@.+--+-- The pair of interfaces share the same stream of errors. The initial state of+-- the stream of errors is set to @errors@.+--+-- If you want to have access to the current state of the mocked file system+-- or stream of errors, use 'simErrorHasBlockIO' instead.+simErrorHasBlockIO' ::+ (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)+ => MockFS+ -> Errors+ -> m (HasFS m HandleMock, HasBlockIO m HandleMock)+simErrorHasBlockIO' mockFS errs = do+ hfs <- simErrorHasFS' mockFS errs+ hbio <- unsafeFromHasFS hfs+ pure (hfs, hbio)
+ src-windows/System/FS/BlockIO/Internal.hs view
@@ -0,0 +1,61 @@+module System.FS.BlockIO.Internal (+ ioHasBlockIO+ ) where++import Control.Exception (throwIO)+import Control.Monad (unless)+import qualified System.FS.API as FS+import System.FS.API (FsPath, Handle (..), HasFS)+import System.FS.BlockIO.API (Advice (..), FileOffset, HasBlockIO)+import qualified System.FS.BlockIO.IO.Internal as IOI+import qualified System.FS.BlockIO.Serial as Serial+import System.FS.IO (HandleIO)+import qualified System.FS.IO.Handle as FS+import System.IO.Error (doesNotExistErrorType, ioeSetErrorString,+ mkIOError)+import qualified System.Win32.File as Windows+import qualified System.Win32.HardLink as Windows++-- | For now we use the portable serial implementation of HasBlockIO. If you+-- want to provide a proper async I\/O implementation for Windows, then this is+-- where you should put it.+--+-- The recommended choice would be to use the Win32 IOCP API.+ioHasBlockIO ::+ HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> IO (HasBlockIO IO HandleIO)+ioHasBlockIO hfs _params =+ Serial.serialHasBlockIO+ hSetNoCache+ hAdvise+ hAllocate+ (IOI.tryLockFileIO hfs)+ hSynchronise+ (synchroniseDirectory hfs)+ (IOI.createHardLinkIO hfs Windows.createHardLink)+ hfs++hSetNoCache :: Handle HandleIO -> Bool -> IO ()+hSetNoCache _h _b = pure ()++hAdvise :: Handle HandleIO -> FileOffset -> FileOffset -> Advice -> IO ()+hAdvise _h _off _len _advice = pure ()++hAllocate :: Handle HandleIO -> FileOffset -> FileOffset -> IO ()+hAllocate _h _off _len = pure ()++hSynchronise :: Handle HandleIO -> IO ()+hSynchronise h = FS.withOpenHandle "hAdvise" (handleRaw h) $ \fd ->+ Windows.flushFileBuffers fd++synchroniseDirectory :: HasFS IO HandleIO -> FsPath -> IO ()+synchroniseDirectory hfs path = do+ b <- FS.doesDirectoryExist hfs path+ unless b $+ throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs (FS.mkFsPath [])) ioerr+ where+ ioerr =+ ioeSetErrorString+ (mkIOError doesNotExistErrorType "synchroniseDirectory" Nothing Nothing)+ ("synchroniseDirectory: directory does not exist")
+ src/System/FS/BlockIO.hs view
@@ -0,0 +1,195 @@+module System.FS.BlockIO (+ -- * Description+ -- $description++ -- * Re-exports+ module System.FS.BlockIO.API+ , module System.FS.BlockIO.IO++ -- * Example+ -- $example+) where++import System.FS.BlockIO.API+import System.FS.BlockIO.IO++{-------------------------------------------------------------------------------+ Examples+-------------------------------------------------------------------------------}++{- $description++ The 'HasBlockIO' record type defines an /abstract interface/. A value of a+ 'HasBlockIO' type is what we call an /instance/ of the abstract interface, and+ an instance is produced by a function that we call an /implementation/. In+ principle, we can have multiple instances of the same implementation.++ There are currently two known implementations of the interface:++ * An implementation using the real file system, which can be found in the+ "System.FS.BlockIO.IO" module. This implementation is platform-dependent,+ but has largely similar observable behaviour.++ * An implementation using a simulated file system, which can be found in the+ @System.FS.BlockIO.Sim@ module of the @blockio:sim@ sublibrary. This+ implementation is uniform across platforms.++ The 'HasBlockIO' abstract interface is an extension of the 'HasFS' abstract+ interface that is provided by the+ [@fs-api@](https://hackage.haskell.org/package/fs-api) package. Whereas+ 'HasFS' defines many primitive functions, for example for opening a file, the+ main feature of 'HasBlockIO' is to define a function for performing batched+ I\/O. As such, users of @blockio@ will more often than not need to pass both a+ 'HasFS' and a 'HasBlockIO' instance to their functions.+-}++{- $example++ >>> import Control.Monad+ >>> import Control.Monad.Primitive+ >>> import Data.Primitive.ByteArray+ >>> import Data.Vector qualified as V+ >>> import Data.Word+ >>> import Debug.Trace+ >>> import System.FS.API as FS+ >>> import System.FS.BlockIO.IO+ >>> import System.FS.BlockIO.API+ >>> import System.FS.IO++ The main feature of the 'HasBlockIO' abstract interface is that it provides a+ function for performing batched I\/O using 'submitIO'. Depending on the+ implementation of the interface, performing I\/O in batches concurrently using+ 'submitIO' can be much faster than performing each I\/O operation in a+ sequential order. We will not go into detail about this performance+ consideration here, but more information can be found in the+ "System.FS.BlockIO.IO" module. Instead, we will show an example of how+ 'submitIO' can be used in your own projects.++ We aim to build an example that writes some contents to a file using+ 'submitIO', and then reads the contents out again using 'submitIO'. The file+ contents will simply be bytes.++ >>> type Byte = Word8++ The first part of the example is to write out bytes to a given file path using+ 'submitIO'. We define a @writeFile@ function that does just that. The file is+ assumed to not exist already.++ The bytes, which are provided as separate bytes, are written into a buffer (a+ mutable byte array). Note that the buffer should be /pinned/ memory to prevent+ pointer aliasing. In the case of write operations, this buffer is used to+ communicate to the backend what the bytes are that should be written to disk.+ For simplicity, we create a separate 'IOOpWrite' instruction for each byte.+ This instruction requires information about the write operation. In order of+ appearence these are: the file handle to write bytes to, the offset into that+ file, the buffer, the offset into that buffer, and the number of bytes to+ write. Finally, all instructions are batched together and submitted in one go+ using 'submitIO'. For each instruction, an 'IOResult' is returned, which+ describes in this case the number of written bytes. If any of the instructions+ failed to be performed, an error is thrown. We print the 'IOResult's to+ standard output.++ Note that in real scenarios it would be much more performant to aggregate the+ bytes into larger chunks, and to create an instruction for each of those+ chunks. A sensible size for those chunks would be the disk page size (4Kb for+ example), or a multiple of that disk page size. The disk page size is+ typically the smallest chunk of memory that can be written to or read from the+ disk. In some cases it is also desirable or even required that the buffers are+ aligned to the disk page size. For example, alignment is required when using+ direct I\/O.++ >>> :{+ writeFile ::+ HasFS IO HandleIO+ -> HasBlockIO IO HandleIO+ -> FsPath+ -> [Byte]+ -> IO ()+ writeFile hasFS hasBlockIO file bytes = do+ let numBytes = length bytes+ FS.withFile hasFS file (FS.WriteMode FS.MustBeNew) $ \h -> do+ buffer <- newPinnedByteArray numBytes+ forM_ (zip [0..] bytes) $ \(i, byte) ->+ let bufferOffset = fromIntegral i+ in writeByteArray @Byte buffer bufferOffset byte+ results <- submitIO hasBlockIO $ V.fromList [+ IOOpWrite h fileOffset buffer bufferOffset 1+ | i <- take numBytes [0..]+ , let fileOffset = fromIntegral i+ bufferOffset = FS.BufferOffset i+ ]+ print results+ :}++ The second part of the example is to read a given number of bytes from a given+ file path using 'submitIO'. We define a @readFile@ function that follows the+ same general structure and behaviour as @writeFile@, but @readFile@ is of+ course reading bytes instead of writing bytes.++ >>> :{+ readFile ::+ HasFS IO HandleIO+ -> HasBlockIO IO HandleIO+ -> FsPath+ -> Int+ -> IO [Byte]+ readFile hasFS hasBlockIO file numBytes = do+ FS.withFile hasFS file FS.ReadMode $ \h -> do+ buffer <- newPinnedByteArray numBytes+ results <- submitIO hasBlockIO $ V.fromList [+ IOOpRead h fileOffset buffer bufferOffset numBytes+ | i <- [0..3]+ , let fileOffset = fromIntegral i+ bufferOffset = FS.BufferOffset i+ numBytes = 1+ ]+ print results+ forM (take numBytes [0..]) $ \i ->+ let bufferOffset = i+ in readByteArray @Byte buffer i+ :}++ Now we can combine @writeFile@ and @readFile@ into a very small example called+ @writeReadFile@, which does what we set out to do: write a few bytes to a+ (temporary) file and read them out again using 'submitIO'. We also print the+ bytes that were written and the bytes that were read, so that the user can+ check by hand whether the bytes match.++ >>> :{+ writeReadFile :: HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO ()+ writeReadFile hasFS hasBlockIO = do+ let file = FS.mkFsPath ["simple_example.txt"]+ let bytesIn = [1,2,3,4]+ print bytesIn+ writeFile hasFS hasBlockIO file bytesIn+ bytesOut <- readFile hasFS hasBlockIO file 4+ print bytesOut+ FS.removeFile hasFS file+ :}++ In order to run @writeReadFile@, we will need 'HasFS' and 'HasBlockIO'+ instances. This is where the separation between interface and implementation+ shines: @writeReadFile@ is agnostic to the implementations of the the abstract+ interfaces, so we could pick any implementations and slot them in. For this+ example we will use the /real/ implementation from "System.FS.BlockIO.IO", but+ we could have used the /simulated/ implementation from the @blockio:sim@+ sub-library just as well. We define the @example@ function, which uses+ 'withIOHasBlockIO' to instantiate both a 'HasFS' and 'HasBlockIO' instance,+ which we pass to 'writeReadFile'.++ >>> :{+ example :: IO ()+ example =+ withIOHasBlockIO (MountPoint "") defaultIOCtxParams $ \hasFS hasBlockIO ->+ writeReadFile hasFS hasBlockIO+ :}++ Finally, we can run the example to produce some output. As we can see, the+ input bytes match the output bytes.++ >>> example+ [1,2,3,4]+ [IOResult 1,IOResult 1,IOResult 1,IOResult 1]+ [IOResult 1,IOResult 1,IOResult 1,IOResult 1]+ [1,2,3,4]+-}
+ src/System/FS/BlockIO/API.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++-- | Abstract interface, types, and utilities.+module System.FS.BlockIO.API (+ -- * HasBlockIO+ HasBlockIO (..)+ , IOOp (..)+ , ioopHandle+ , ioopFileOffset+ , ioopBuffer+ , ioopBufferOffset+ , ioopByteCount+ , IOResult (..)+ -- ** Advice+ , Advice (..)+ , hAdviseAll+ , hDropCacheAll+ -- ** File locks+ , GHC.LockMode (..)+ , GHC.FileLockingNotSupported (..)+ , LockFileHandle (..)+ -- ** Storage synchronisation+ , synchroniseFile+ , synchroniseDirectoryRecursive+ -- * Re-exports+ , ByteCount+ , FileOffset+ ) where++import Control.DeepSeq+import Control.Monad (forM_)+import Control.Monad.Class.MonadThrow (MonadThrow (..))+import Control.Monad.Primitive (PrimMonad (PrimState))+import Data.Primitive.ByteArray (MutableByteArray)+import qualified Data.Vector as V+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import qualified GHC.IO.Handle.Lock as GHC+import GHC.Stack (HasCallStack)+import qualified System.FS.API as FS+import System.FS.API (BufferOffset, FsPath, Handle (..), HasFS)+import System.Posix.Types (ByteCount, FileOffset)+import Text.Printf++-- | Abstract interface for submitting large batches of I\/O operations. This+-- interface is an extension of the 'HasFS' interface that is provided by the+-- @fs-api@ package.+--+-- The interface tries to specify uniform behaviour, but each implementation can+-- have subtly different effects for a variety of reasons. However, for the most+-- part the underlying implementation of an instance of the interface should not+-- affect the correctness of programs that use the interface.+--+-- For uniform behaviour across implementations, functions that create a new+-- instance of the interface should initialise an IO context. This IO context+-- may be of any shape, as long as the context has two modes: open and closed.+-- This context is only important for the 'close' and 'submitIO' functions. As+-- long as the IO context is open, 'submitIO' should perform batches of I\/O+-- operations as expected, but 'submitIO' should throw an error as soon as the+-- IO context is closed. Once the IO context is closed, it can not be re-opened+-- again. Instead, the user should create a new instance of the interface.+--+-- Note: there are a bunch of functions in the interface that have nothing to do+-- with submitting large batches of I\/O operations. In fact, only 'close' and+-- 'submitIO' are related to that. All other functions were put in this record+-- for simplicity because the authors of the library needed them and it was more+-- straightforward to add them here then to add them to @fs-api@. Still these+-- unrelated functions could and should all be moved into @fs-api@ at some point+-- in the future.+--+data HasBlockIO m h = HasBlockIO {+ -- | (Idempotent) close the IO context that is required for running+ -- 'submitIO'.+ --+ -- Using 'submitIO' after 'close' throws an 'FsError' exception.+ --+ close :: HasCallStack => m ()++ -- | Submit a batch of I\/O operations and wait for the result.+ --+ -- Results correspond to input 'IOOp's in a pair-wise manner, i.e., one can+ -- match 'IOOp's with 'IOResult's by indexing into both vectors at the same+ -- position.+ --+ -- If any of the I\/O operations fails, an 'FsError' exception will be thrown.+ --+ -- The buffers in the 'IOOp's should be pinned memory. If any buffer is+ -- unpinned memory, an 'FsError' exception will be thrown.+ --+ , submitIO :: HasCallStack => V.Vector (IOOp (PrimState m) h) -> m (VU.Vector IOResult)++ -- TODO: once file caching is disabled, subsequent reads/writes with+ -- misaligned byte arrays should throw an error. Preferably, this should+ -- happen in both the simulation and real implementation, even if the real+ -- implementation does not support setting the file caching mode. This would+ -- make the behaviour of the file caching mode more uniform across+ -- implementations and platforms.++ -- | Set the file data caching mode for a file handle.+ --+ , hSetNoCache :: Handle h -> Bool -> m ()++ -- | Predeclare an access pattern for file data.+ --+ , hAdvise :: Handle h -> FileOffset -> FileOffset -> Advice -> m ()++ -- | Allocate file space.+ --+ , hAllocate :: Handle h -> FileOffset -> FileOffset -> m ()++ -- NOTE: though it would have been nicer to allow locking /file handles/+ -- instead of /file paths/, it would make the implementation of this+ -- function in 'IO' much more complex. In particular, if we want to reuse+ -- "GHC.IO.Handle.Lock" functionality, then we have to either ...+ --+ -- 1. Convert there and back between OS-specific file descriptors and+ -- 'GHC.Handle's, which is not possible on Windows without creating new+ -- file descriptors, or ...+ -- 2. Vendor all of the "GHC.IO.Handle.Lock" code and its dependencies+ -- (i.e., modules), which is a prohibitively large body of code for GHC+ -- versions before @9.0@.+ --+ -- The current interface is therefore limited, but should be sufficient for+ -- use cases where a lock file is used to guard against concurrent access by+ -- different processes. e.g., a database lock file.+ --+ -- TODO: it is /probably/ possible to provide a 'onLockFileHandle' function+ -- that allows you to use 'LockFileHandle' as a 'Handle', but only within a+ -- limited scope. That is, it has to fit the style of @withHandleToHANDLE ::+ -- Handle -> (HANDLE -> IO a) -> IO a@ from the @Win32@ package.++ -- | Try to acquire a file lock without blocking.+ --+ -- This function throws 'GHC.FileLockingNotSupported' when file locking is+ -- not supported.+ --+ , tryLockFile :: FsPath -> GHC.LockMode -> m (Maybe (LockFileHandle m))++ -- | Synchronise file contents with the storage device.+ --+ -- This ensures that all changes to the file handle's contents, which might+ -- exist only in memory as buffered system cache pages, are+ -- transferred/flushed to disk. This will also update the file handle's+ -- associated metadata.+ --+ , hSynchronise :: Handle h -> m ()++ -- | Synchronise a directory with the storage device.+ --+ -- This ensures that all changes to the directory, which might exist only in+ -- memory as buffered changes, are transferred/flushed to disk. This will+ -- also update the directory's associated metadata.+ --+ , synchroniseDirectory :: FsPath -> m ()++ -- | Create a hard link for an existing file at the source path and a new+ -- file at the target path.+ --+ , createHardLink :: FsPath -> FsPath -> m ()+ }++instance NFData (HasBlockIO m h) where+ rnf (HasBlockIO a b c d e f g h i) =+ rwhnf a `seq` rwhnf b `seq` rnf c `seq`+ rwhnf d `seq` rwhnf e `seq` rwhnf f `seq`+ rwhnf g `seq` rwhnf h `seq` rwhnf i++data IOOp s h =+ IOOpRead !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount+ | IOOpWrite !(Handle h) !FileOffset !(MutableByteArray s) !BufferOffset !ByteCount++instance NFData (IOOp s h) where+ rnf = rwhnf++ioopHandle :: IOOp s h -> Handle h+ioopHandle (IOOpRead h _ _ _ _) = h+ioopHandle (IOOpWrite h _ _ _ _) = h++ioopFileOffset :: IOOp s h -> FileOffset+ioopFileOffset (IOOpRead _ off _ _ _) = off+ioopFileOffset (IOOpWrite _ off _ _ _) = off++ioopBuffer :: IOOp s h -> MutableByteArray s+ioopBuffer (IOOpRead _ _ buf _ _) = buf+ioopBuffer (IOOpWrite _ _ buf _ _) = buf++ioopBufferOffset :: IOOp s h -> BufferOffset+ioopBufferOffset (IOOpRead _ _ _ bufOff _) = bufOff+ioopBufferOffset (IOOpWrite _ _ _ bufOff _) = bufOff++ioopByteCount :: IOOp s h -> ByteCount+ioopByteCount (IOOpRead _ _ _ _ c) = c+ioopByteCount (IOOpWrite _ _ _ _ c) = c++-- | Number of read/written bytes.+newtype IOResult = IOResult ByteCount+ deriving stock (Show, Eq)+ deriving newtype VP.Prim++newtype instance VUM.MVector s IOResult = MV_IOResult (VP.MVector s IOResult)+newtype instance VU.Vector IOResult = V_IOResult (VP.Vector IOResult)++deriving via (VU.UnboxViaPrim IOResult) instance VGM.MVector VU.MVector IOResult+deriving via (VU.UnboxViaPrim IOResult) instance VG.Vector VU.Vector IOResult++instance VUM.Unbox IOResult++{-------------------------------------------------------------------------------+ Advice+-------------------------------------------------------------------------------}++-- | Copy of "System.Posix.Fcntl.Advice" from the @unix@ package+data Advice =+ AdviceNormal+ | AdviceRandom+ | AdviceSequential+ | AdviceWillNeed+ | AdviceDontNeed+ | AdviceNoReuse+ deriving stock (Show, Eq)++-- | Apply 'Advice' to all bytes of a file, which is referenced by a 'Handle'.+hAdviseAll :: HasBlockIO m h -> Handle h -> Advice -> m ()+hAdviseAll hbio h advice = hAdvise hbio h 0 0 advice -- len=0 implies until the end of file++-- | Drop the full file referenced by a 'Handle' from the OS page cache, if+-- present.+hDropCacheAll :: HasBlockIO m h -> Handle h -> m ()+hDropCacheAll hbio h = hAdviseAll hbio h AdviceDontNeed++{-------------------------------------------------------------------------------+ Storage synchronisation+-------------------------------------------------------------------------------}++{-# SPECIALISE synchroniseFile :: HasFS IO h -> HasBlockIO IO h -> FsPath -> IO () #-}+-- | Synchronise a file's contents and metadata with the storage device.+synchroniseFile :: MonadThrow m => HasFS m h -> HasBlockIO m h -> FsPath -> m ()+synchroniseFile hfs hbio path =+ FS.withFile hfs path (FS.ReadWriteMode FS.MustExist) $ hSynchronise hbio++{-# SPECIALISE synchroniseDirectoryRecursive ::+ HasFS IO h+ -> HasBlockIO IO h+ -> FsPath+ -> IO ()+ #-}+-- | Synchronise a directory's contents and metadata with the storage device,+-- and recursively for all entries in the directory.+synchroniseDirectoryRecursive ::+ MonadThrow m+ => HasFS m h+ -> HasBlockIO m h+ -> FsPath+ -> m ()+synchroniseDirectoryRecursive hfs hbio path = do+ entries <- FS.listDirectory hfs path+ forM_ entries $ \entry -> do+ let path' = path FS.</> FS.mkFsPath [entry]+ isFile <- FS.doesFileExist hfs path'+ if isFile then+ synchroniseFile hfs hbio path'+ else do+ isDirectory <- FS.doesDirectoryExist hfs path'+ if isDirectory then do+ synchroniseDirectoryRecursive hfs hbio path'+ synchroniseDirectory hbio path'+ else+ error $ printf+ "listDirectoryRecursive: %s is not a file or directory"+ (show path')++{-------------------------------------------------------------------------------+ File locks+-------------------------------------------------------------------------------}++-- | A handle to a file locked using 'tryLockFile'.+newtype LockFileHandle m = LockFileHandle {+ -- | Release a file lock acquired using 'tryLockFile'.+ hUnlock :: m ()+ }
+ src/System/FS/BlockIO/IO.hs view
@@ -0,0 +1,175 @@+-- | Implementations using the real file system.+--+-- The implementation of the 'HasBlockIO' interface provided in this module is+-- platform-dependent. Most importantly, on Linux, the implementation of+-- 'submitIO' is backed by @blockio-uring@: a library for asynchronous I\/O. On+-- Windows and MacOS, the implementation of 'submitIO' only supports serial+-- I\/O.+module System.FS.BlockIO.IO (+ -- * Implementation details #impl#+ -- $impl++ -- * Initialisation+ ioHasBlockIO+ , withIOHasBlockIO+ -- ** Parameters+ , IOI.IOCtxParams (..)+ , IOI.defaultIOCtxParams+ -- ** Unsafe+ , unsafeFromHasFS+ , withUnsafeFromHasFS+ ) where++import Control.Exception (bracket)+import System.FS.API (HasFS, MountPoint)+import System.FS.BlockIO.API (HasBlockIO (..))+import qualified System.FS.BlockIO.Internal as I+import qualified System.FS.BlockIO.IO.Internal as IOI+import System.FS.IO (HandleIO, ioHasFS)++{- $impl++ Though the 'HasBlockIO' interface tries to capture uniform behaviour, each+ function in this implementation for the real file system can have subtly+ different effects depending on the underlying patform. For example, some+ features are not provided by some operating systems, and in some cases the+ features behave subtly differently for different operating systems. For this+ reason, we include below some documentation about the effects of calling the+ interface functions on different platforms.++ Note: if the @serialblockio@ Cabal flag is enabled, then the Linux+ implementation uses a mocked context and serial I\/O for 'close' and+ 'submitIO', just like the MacOS and Windows implementations do.++ [IO context]: When an instance of the 'HasBlockIO' interface for Linux+ systems is initialised, an @io_uring@ context is created using the+ @blockio-uring@ package and stored in the 'HasBlockIO' closure. For uniform+ behaviour, each other platform creates and stores a mocked IO context that+ has the same open/closed behaviour as an @io_uring@ context. In summary,+ each platform creates:++ * Linux: an @io_uring@ context provided by the @blockio-uring@ package+ * MacOS: a mocked context using an @MVar@+ * Windows: a mocked conext using an @MVar@++ ['close']:++ * Linux: close the @io_uring@ context through the @blockio-uring@ package+ * MacOS: close the mocked context+ * Windows: close the mocked context++ ['submitIO']: Submit a batch of I\/O operations using:++ * Linux: the @submitIO@ function from the @blockio-uring@ package+ * MacOS: serial I\/O using a 'HasFS'+ * Windows: serial I\/O using a 'HasFS'++ ['hSetNoCache']:++ * Linux: set the @O_DIRECT@ flag+ * MacOS: set the @F_NOCACHE@ flag+ * Windows: no-op++ ['hAdvise']:++ * Linux: perform @posix_fadvise(2)@+ * MacOS: no-op+ * Windows: no-op++ ['hAllocate']:++ * Linux: perform @posix_fallocate(2)@+ * MacOS: no-op+ * Windows: no-op++ ['tryLockFile']: This uses different locking methods depending on the OS.++ * Linux: Open file descriptor (OFD)+ * MacOS: @flock@+ * Windows: @LockFileEx@++ ['hSynchronise']:++ * Linux: perform @fsync(2)@+ * MacOS: perform @fsync(2)@+ * Windows: perform @flushFileBuffers@++ ['synchroniseDirectory']:++ * Linux: perform @fsync(2)@+ * MacOS: perform @fsync(2)@+ * Windows: no-op++ ['createHardLink']:++ * Linux: perform @link@+ * MacOS: perform @link@+ * Windows: perform @CreateHardLinkW@+-}++-- | An implementation of the 'HasBlockIO' interface using the real file system.+--+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer+-- used. 'withUnsafeFromHasFS' does this automatically.+--+-- === Unsafe+--+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.+--+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to+-- 'unsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated file+-- system, but then the resulting 'HasBlockIO' would contain a mix of simulated+-- and real functions, which is probably not what you want.+unsafeFromHasFS ::+ HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> IO (HasBlockIO IO HandleIO)+unsafeFromHasFS = I.ioHasBlockIO++-- | Perform an action using a 'HasBlockIO' instance that is only open for the+-- duration of the action.+--+-- The 'HasBlockIO' is initialised using 'unsafeFromHasFS'.+--+-- === Unsafe+--+-- You will probably want to use 'ioHasBlockIO' or 'withIOHasBlockIO' instead.+--+-- Only a 'HasFS' for the real file system, like 'ioHasFS', should be passed to+-- 'withUnsafeFromHasFS'. Technically, one could pass a 'HasFS' for a simulated+-- file system, but then the resulting 'HasBlockIO' would contain a mix of+-- simulated and real functions, which is probably not what you want.+withUnsafeFromHasFS ::+ HasFS IO HandleIO+ -> IOI.IOCtxParams+ -> (HasBlockIO IO HandleIO -> IO a)+ -> IO a+withUnsafeFromHasFS hfs params =+ bracket (unsafeFromHasFS hfs params) (\HasBlockIO{close} -> close)++-- | An implementation of the 'HasBlockIO' interface using the real file system.+--+-- Make sure to use 'close' the resulting 'HasBlockIO' when it is no longer+-- used. 'withIOHasBlockIO' does this automatically.+--+-- The 'HasFS' interface is instantiated using 'ioHasFS'.+ioHasBlockIO ::+ MountPoint+ -> IOI.IOCtxParams+ -> IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)+ioHasBlockIO mount params = do+ let hfs = ioHasFS mount+ hbio <- unsafeFromHasFS hfs params+ pure (hfs, hbio)++-- | Perform an action using a 'HasFS' and a 'HasBlockIO' instance. The latter+-- is only open for the duration of the action.+--+-- The 'HasFS' and 'HasBlockIO' interfaces are initialised using 'ioHasBlockIO'.+withIOHasBlockIO ::+ MountPoint+ -> IOI.IOCtxParams+ -> (HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO a)+ -> IO a+withIOHasBlockIO mount params action =+ bracket (ioHasBlockIO mount params) (\(_, HasBlockIO{close}) -> close) (uncurry action)
+ src/System/FS/BlockIO/IO/Internal.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}++module System.FS.BlockIO.IO.Internal (+ IOCtxParams (..)+ , defaultIOCtxParams+ , mkClosedError+ , mkNotPinnedError+ , tryLockFileIO+ , createHardLinkIO+ ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),+ MonadThrow (..), bracketOnError, try)+import GHC.IO.Exception+ (IOErrorType (InvalidArgument, ResourceVanished))+import qualified GHC.IO.Handle.Lock as GHC+import GHC.Stack (HasCallStack)+import qualified System.FS.API as FS+import System.FS.API (FsError (..), FsPath, HasFS)+import System.FS.BlockIO.API (LockFileHandle (..))+import System.FS.IO (HandleIO)+import qualified System.IO as GHC+import System.IO.Error (ioeSetErrorString, mkIOError)++{-------------------------------------------------------------------------------+ IO context+-------------------------------------------------------------------------------}++-- | Concurrency parameters for initialising the 'IO' context in a 'HasBlockIO'+-- instance.+--+-- [IO context parameters]: These parameters are interpreted differently based+-- on the underlying platform:+--+-- * Linux: Pass the parameters to 'initIOCtx' in the @blockio-uring@ package+-- * MacOS: Ignore the parameters+-- * Windows: Ignore the parameters+--+-- For more information about what these parameters mean and how to configure+-- them, see the @blockio-uring@ package.+data IOCtxParams = IOCtxParams {+ ioctxBatchSizeLimit :: !Int,+ ioctxConcurrencyLimit :: !Int+ }++instance NFData IOCtxParams where+ rnf (IOCtxParams x y) = rnf x `seq` rnf y++-- | Default parameters. Some manual tuning of parameters might be required to+-- achieve higher performance targets (see 'IOCtxParams').+defaultIOCtxParams :: IOCtxParams+defaultIOCtxParams = IOCtxParams {+ ioctxBatchSizeLimit = 64,+ ioctxConcurrencyLimit = 64 * 3+ }++{-------------------------------------------------------------------------------+ Errors+-------------------------------------------------------------------------------}++mkClosedError :: HasCallStack => HasFS m h -> String -> FsError+mkClosedError hasFS loc =+ FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr+ where+ ioerr =+ ioeSetErrorString+ (mkIOError ResourceVanished loc Nothing Nothing)+ ("HasBlockIO closed: " <> loc)++mkNotPinnedError :: HasCallStack => HasFS m h -> String -> FsError+mkNotPinnedError hasFS loc =+ FS.ioToFsError (FS.mkFsErrorPath hasFS (FS.mkFsPath [])) ioerr+ where+ ioerr =+ ioeSetErrorString+ (mkIOError InvalidArgument loc Nothing Nothing)+ ("MutableByteArray is unpinned: " <> loc)++{-------------------------------------------------------------------------------+ File locks+-------------------------------------------------------------------------------}++tryLockFileIO :: HasFS IO HandleIO -> FsPath -> GHC.LockMode -> IO (Maybe (LockFileHandle IO))+tryLockFileIO hfs fsp mode = do+ fp <- FS.unsafeToFilePath hfs fsp -- shouldn't fail because we are in IO+ rethrowFsErrorIO hfs fsp $+ bracketOnError (GHC.openFile fp GHC.WriteMode) GHC.hClose $ \h -> do+ bracketOnError (GHC.hTryLock h mode) (\_ -> GHC.hUnlock h) $ \b -> do+ if b then+ pure $ Just LockFileHandle { hUnlock = rethrowFsErrorIO hfs fsp $ do+ GHC.hUnlock h+ `finally` GHC.hClose h+ }+ else+ pure $ Nothing++-- This is copied/adapted from System.FS.IO+rethrowFsErrorIO :: HasCallStack => HasFS IO HandleIO -> FsPath -> IO a -> IO a+rethrowFsErrorIO hfs fp action = do+ res <- try action+ case res of+ Left err -> handleError err+ Right a -> pure a+ where+ handleError :: HasCallStack => IOError -> IO a+ handleError ioErr =+ throwIO $ FS.ioToFsError (FS.mkFsErrorPath hfs fp) ioErr++{-------------------------------------------------------------------------------+ Hard links+-------------------------------------------------------------------------------}++createHardLinkIO ::+ HasFS IO HandleIO+ -> (FilePath -> FilePath -> IO ())+ -> (FsPath -> FsPath -> IO ())+createHardLinkIO hfs f = \source target -> do+ source' <- FS.unsafeToFilePath hfs source -- shouldn't fail because we are in IO+ target' <- FS.unsafeToFilePath hfs target -- shouldn't fail because we are in IO+ f source' target'
+ src/System/FS/BlockIO/Serial.hs view
@@ -0,0 +1,140 @@+module System.FS.BlockIO.Serial (+ serialHasBlockIO+ ) where++import Control.Concurrent.Class.MonadMVar+import Control.Monad (unless)+import Control.Monad.Class.MonadThrow+import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)+import Data.Primitive (MutableByteArray, isMutableByteArrayPinned)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import qualified Data.Vector.Unboxed.Mutable as VUM+import GHC.Stack (HasCallStack)+import System.FS.API+import qualified System.FS.BlockIO.API as API+import System.FS.BlockIO.API (IOOp (..), IOResult (..), LockMode (..))+import qualified System.FS.BlockIO.IO.Internal as IOI++{-# SPECIALISE serialHasBlockIO ::+ Eq h+ => (Handle h -> Bool -> IO ())+ -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> IO ())+ -> (Handle h -> API.FileOffset -> API.FileOffset -> IO ())+ -> (FsPath -> LockMode -> IO (Maybe (API.LockFileHandle IO)))+ -> (Handle h -> IO ())+ -> (FsPath -> IO ())+ -> (FsPath -> FsPath -> IO ())+ -> HasFS IO h+ -> IO (API.HasBlockIO IO h)+ #-}+-- | IO instantiation of 'HasBlockIO', using an existing 'HasFS'. Thus this+-- implementation does not take advantage of parallel I\/O.+serialHasBlockIO ::+ (MonadThrow m, MonadMVar m, PrimMonad m, Eq h)+ => (Handle h -> Bool -> m ())+ -> (Handle h -> API.FileOffset -> API.FileOffset -> API.Advice -> m ())+ -> (Handle h -> API.FileOffset -> API.FileOffset -> m ())+ -> (FsPath -> LockMode -> m (Maybe (API.LockFileHandle m)))+ -> (Handle h -> m ())+ -> (FsPath -> m ())+ -> (FsPath -> FsPath -> m ())+ -> HasFS m h+ -> m (API.HasBlockIO m h)+serialHasBlockIO hSetNoCache hAdvise hAllocate tryLockFile hSynchronise synchroniseDirectory createHardLink hfs = do+ ctx <- initIOCtx (SomeHasFS hfs)+ pure $ API.HasBlockIO {+ API.close = close ctx+ , API.submitIO = submitIO hfs ctx+ , API.hSetNoCache+ , API.hAdvise+ , API.hAllocate+ , API.tryLockFile+ , API.hSynchronise+ , API.synchroniseDirectory+ , API.createHardLink+ }++data IOCtx m = IOCtx { ctxFS :: SomeHasFS m, openVar :: MVar m Bool }++{-# SPECIALISE guardIsOpen :: IOCtx IO -> IO () #-}+guardIsOpen :: (HasCallStack, MonadMVar m, MonadThrow m) => IOCtx m -> m ()+guardIsOpen ctx = readMVar (openVar ctx) >>= \b ->+ case ctxFS ctx of+ SomeHasFS hfs ->+ unless b $ throwIO $ IOI.mkClosedError hfs "submitIO"++{-# SPECIALISE initIOCtx :: SomeHasFS IO -> IO (IOCtx IO) #-}+initIOCtx :: MonadMVar m => SomeHasFS m -> m (IOCtx m)+initIOCtx someHasFS = IOCtx someHasFS <$> newMVar True++{-# SPECIALISE close :: IOCtx IO -> IO () #-}+close :: MonadMVar m => IOCtx m -> m ()+close ctx = modifyMVar_ (openVar ctx) $ const (pure False)++{-# SPECIALISE submitIO ::+ HasFS IO h+ -> IOCtx IO -> V.Vector (IOOp RealWorld h)+ -> IO (VU.Vector IOResult) #-}+submitIO ::+ (HasCallStack, MonadMVar m, MonadThrow m, PrimMonad m)+ => HasFS m h+ -> IOCtx m+ -> V.Vector (IOOp (PrimState m) h)+ -> m (VU.Vector IOResult)+submitIO hfs ctx ioops = do+ guardIsOpen ctx+ hmapM (ioop hfs) ioops++{-# SPECIALISE ioop :: HasFS IO h -> IOOp RealWorld h -> IO IOResult #-}+-- | Perform the IOOp using synchronous I\/O.+ioop ::+ MonadThrow m+ => HasFS m h+ -> IOOp (PrimState m) h+ -> m IOResult+ioop hfs (IOOpRead h off buf bufOff c) = do+ guardPinned hfs buf "submitIO"+ IOResult <$> hGetBufExactlyAt hfs h buf bufOff c (fromIntegral off)+ioop hfs (IOOpWrite h off buf bufOff c) = do+ guardPinned hfs buf "submitIO"+ IOResult <$> hPutBufExactlyAt hfs h buf bufOff c (fromIntegral off)++{-# SPECIALISE guardPinned :: HasFS IO h -> MutableByteArray RealWorld -> String -> IO () #-}+guardPinned ::+ MonadThrow m+ => HasFS m h+ -> MutableByteArray (PrimState m)+ -> String+ -> m ()+guardPinned hfs buf loc =+ unless (isMutableByteArrayPinned buf) $+ throwIO (IOI.mkNotPinnedError hfs loc)++{-# SPECIALISE hmapM ::+ VUM.Unbox b+ => (a -> IO b)+ -> V.Vector a+ -> IO (VU.Vector b) #-}+-- | Heterogeneous blend of 'V.mapM' and 'VU.mapM'.+--+-- The @vector@ package does not provide functions that take distinct vector+-- containers as arguments, so we write it by hand to prevent having to convert+-- one vector type to the other.+hmapM ::+ forall m a b. (PrimMonad m, VUM.Unbox b)+ => (a -> m b)+ -> V.Vector a+ -> m (VU.Vector b)+hmapM f v = do+ res <- VUM.unsafeNew n+ loop res 0+ where+ !n = V.length v+ loop !res !i+ | i == n = VU.unsafeFreeze res+ | otherwise = do+ let !x = v `V.unsafeIndex` i+ !z <- f x+ VUM.unsafeWrite res i z+ loop res (i+1)
+ src/System/FS/BlockIO/Serial/Internal.hs view
@@ -0,0 +1,12 @@+-- | This is an internal module that has to be exposed for technical reasons. Do+-- not use it.+module System.FS.BlockIO.Serial.Internal (+ -- We have to re-export from somewhere so that the @blockio:sim@ sub-library+ -- can use it. Unfortunately, this makes the function part of the public API+ -- even though we'd prefer to keep it truly hidden. There are ways around+ -- this, for example using a new private sub-library that contains the+ -- "System.FS.BlockIO.Serial" module, but it's a lot of boilerplate.+ serialHasBlockIO+ ) where++import System.FS.BlockIO.Serial (serialHasBlockIO)
+ test-sim/Main.hs view
@@ -0,0 +1,90 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main (main) where++import qualified System.FS.API as FS+import System.FS.BlockIO.API+import System.FS.BlockIO.Sim (simHasBlockIO)+import qualified System.FS.Sim.MockFS as MockFS+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck (testProperty)++import Control.Concurrent.Class.MonadSTM.Strict++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "blockio:test-sim" [+ testProperty "prop_tryLockFileTwice" prop_tryLockFileTwice+ ]++{-------------------------------------------------------------------------------+ File locks+-------------------------------------------------------------------------------}++instance Arbitrary LockMode where+ arbitrary = elements [SharedLock, ExclusiveLock]+ shrink SharedLock = []+ shrink ExclusiveLock = []++-- TODO: belongs in base+deriving stock instance Show LockMode++prop_tryLockFileTwice :: LockMode -> LockMode -> Property+prop_tryLockFileTwice mode1 mode2 = ioProperty $ do+ fsvar <- newTMVarIO MockFS.empty+ (_hfs, hbio) <- simHasBlockIO fsvar+ let path = FS.mkFsPath ["lockfile"]++ let expected@(x1, y1) = case (mode1, mode2) of+ (ExclusiveLock, ExclusiveLock) -> (True, False)+ (ExclusiveLock, SharedLock ) -> (True, False)+ (SharedLock , ExclusiveLock) -> (True, False)+ (SharedLock , SharedLock ) -> (True, True)++ before <- atomically (readTMVar fsvar)+ x2 <- tryLockFile hbio path mode1+ after1 <- atomically (readTMVar fsvar)+ y2 <- tryLockFile hbio path mode2+ after2 <- atomically (readTMVar fsvar)++ let addLabel = tabulate "modes" [show (mode1, mode2)]++ let addCounterexample = counterexample+ ( "Expecting: " <> showExpected expected <>+ "\nbut got: " <> showReal (x2, y2) )+ . counterexample+ ( "FS before: " ++ show before ++ "\n"+ <> "FS after1: " ++ show after1 ++ "\n"+ <> "FS after2: " ++ show after2)++ pure $ addCounterexample $ addLabel $+ cmpBoolMaybeConstructor x1 x2 .&&. cmpBoolMaybeConstructor y1 y2++cmpBoolMaybeConstructor :: Bool -> Maybe a -> Bool+cmpBoolMaybeConstructor True (Just _) = True+cmpBoolMaybeConstructor False Nothing = True+cmpBoolMaybeConstructor _ _ = False++showExpected :: (Bool, Bool) -> String+showExpected (x, y) =+ "(" <> showBoolAsMaybeConstructor x <>+ ", " <> showBoolAsMaybeConstructor y <>+ ")"++showBoolAsMaybeConstructor :: Bool -> String+showBoolAsMaybeConstructor b+ | b = "Just _"+ | otherwise = "Nothing"++showReal :: (Maybe a, Maybe a) -> String+showReal (x, y) =+ "(" <> showMaybeConstructor x <>+ ", " <> showMaybeConstructor y <>+ ")"++showMaybeConstructor :: Maybe a -> String+showMaybeConstructor Nothing = "Nothing"+showMaybeConstructor (Just _) = "Just _"
+ test/Main.hs view
@@ -0,0 +1,297 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Main (main) where++import Control.Concurrent (modifyMVar_, newMVar, threadDelay,+ withMVar)+import Control.Concurrent.Async+import Control.Exception (Exception (..),+ SomeException (SomeException), bracket, try)+import Control.Monad+import Control.Monad.Primitive+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as LBS+import Data.Foldable (traverse_)+import Data.Functor.Compose (Compose (Compose))+import qualified Data.List as List+import Data.Maybe (catMaybes)+import Data.Primitive.ByteArray+import Data.Typeable+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU+import System.FS.API+import qualified System.FS.API.Lazy as FS+import qualified System.FS.API.Strict as FS+import System.FS.API.Strict (hPutAllStrict)+import qualified System.FS.BlockIO.API as FS+import System.FS.BlockIO.API+import qualified System.FS.BlockIO.IO as IO+import System.FS.IO+import System.IO.Temp+import Test.QuickCheck+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (testProperty)++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "blockio:test" [+ testCase "example_initClose" example_initClose+ , testCase "example_closeIsIdempotent" example_closeIsIdempotent+ , testProperty "prop_readWrite" prop_readWrite+ , testProperty "prop_submitToClosedCtx" prop_submitToClosedCtx++ -- Context+ , testProperty "prop_submitIO_contextClosed" prop_submitIO_contextClosed++ -- Pinned vs. unpinned buffers+ , testProperty "prop_submitIO_buffersPinned" prop_submitIO_buffersPinned+ , testProperty "prop_submitIO_buffersUnpinned" prop_submitIO_buffersUnpinned++ -- File locks+ , testProperty "prop_tryLockFileExclusiveTwice" prop_tryLockFileExclusiveTwice++ -- Storage synchronisation+ , testProperty "prop_synchronise" prop_synchronise+ , testProperty "prop_synchroniseFile_fileDoesNotExist"+ prop_synchroniseFile_fileDoesNotExist+ , testProperty "prop_synchroniseDirectory_directoryDoesNotExist"+ prop_synchroniseDirectory_directoryDoesNotExist+ ]++instance Arbitrary ByteString where+ arbitrary = BS.pack <$> arbitrary+ shrink = fmap BS.pack . shrink . BS.unpack++fromByteStringPinned :: PrimMonad m => ByteString -> m (MutableByteArray (PrimState m))+fromByteStringPinned bs = do+ mba <- newPinnedByteArray (BS.length bs)+ forM_ (zip [0..] (BS.unpack bs)) $ \(i, x) -> writeByteArray mba i x+ pure mba++toByteString :: PrimMonad m => Int -> MutableByteArray (PrimState m) -> m ByteString+toByteString n mba = do+ w8s <- forM [0..n-1] $ \i -> readByteArray mba i+ pure (BS.pack w8s)++example_initClose :: Assertion+example_initClose = withSystemTempDirectory "example_initClose" $ \dirPath -> do+ let mount = FS.MountPoint dirPath+ IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \_ _ -> pure ()++example_closeIsIdempotent :: Assertion+example_closeIsIdempotent = withSystemTempDirectory "example_closeIsIdempotent" $ \dirPath -> do+ let mount = FS.MountPoint dirPath+ hbio <- IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \_ hbio -> pure hbio+ close hbio+ eith <- try @SomeException (close hbio)+ case eith of+ Left (e :: SomeException) ->+ assertFailure ("Close on a closed context threw an error : " <> show e)+ Right () ->+ pure ()++prop_readWrite :: ByteString -> Property+prop_readWrite bs = ioProperty $ withSystemTempDirectory "prop_readWrite" $ \dirPath -> do+ let mount = FS.MountPoint dirPath+ IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \hfs hbio -> do+ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ let n = BS.length bs+ writeBuf <- fromByteStringPinned bs+ [IOResult m] <- VU.toList <$> submitIO hbio (V.singleton (IOOpWrite h 0 writeBuf 0 (fromIntegral n)))+ let writeTest = n === fromIntegral m+ readBuf <- newPinnedByteArray n+ [IOResult o] <- VU.toList <$> submitIO hbio (V.singleton (IOOpRead h 0 readBuf 0 (fromIntegral n)))+ let readTest = o === m+ bs' <- toByteString n readBuf+ let cmpTest = bs === bs'+ pure $ writeTest .&&. readTest .&&. cmpTest++prop_submitToClosedCtx :: ByteString -> Property+prop_submitToClosedCtx bs = ioProperty $ withSystemTempDirectory "prop_a" $ \dir -> do+ let mount = FS.MountPoint dir+ IO.withIOHasBlockIO mount IO.defaultIOCtxParams $ \hfs hbio -> do+ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ void $ hPutAllStrict hfs h bs+ syncVar <- newMVar False+ fmap (conjoin . catMaybes) $ forConcurrently [0 .. BS.length bs - 1] $ \i ->+ if i == 0 then do+ threadDelay 15+ modifyMVar_ syncVar $ \_ -> do+ close hbio+ pure True+ pure Nothing+ else do+ readBuf <- newPinnedByteArray (BS.length bs)+ withMVar syncVar $ \b -> do+ eith <- try @SomeException $ submitIO hbio (V.singleton (IOOpRead h 0 readBuf (fromIntegral i) 1))+ pure $ case eith of+ Left _ -> Just $ tabulate "submitIO successful" [show False] $ counterexample "expected failure, but got success" (b === True)+ Right _ -> Just $ tabulate "submitIO successful" [show True] $ counterexample "expected success, but got failure" (b === False)++{-------------------------------------------------------------------------------+ Closed context+-------------------------------------------------------------------------------}++-- | Test that 'submitIO' on a closed context returns a "context closed" error+prop_submitIO_contextClosed :: Property+prop_submitIO_contextClosed =+ ioProperty $+ withTempIOHasBlockIO "prop_submitIO_unpinnedBuffers" $ \hfs hbio ->+ FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do+ void $ FS.hPutAll hfs h $ LBS.pack [1..100]+ buf <- newByteArray 17+ let ioops = V.fromList [+ IOOpWrite h 0 buf 0 17+ , IOOpRead h 0 buf 0 17+ ]+ close hbio+ eith <- try @FsError $ submitIO hbio ioops+ pure $ case eith of+ Left e+ | isClosedError e+ -> property True+ | otherwise+ -> counterexample ("Unexpected error: " <> displayException e) False+ Right _+ -> counterexample ("Unexpected success") False+ where+ path = FS.mkFsPath ["temp-file"]++-- TODO: add a property that checks @isClosedError . mkClosedError = True@+isClosedError :: FsError -> Bool+isClosedError e+ -- TODO: add an FsResourceVanished constructor to FsErrorType?+ | fsErrorType e == FsOther+ , "HasBlockIO closed: " `List.isPrefixOf` (fsErrorString e)+ = True+ | otherwise+ = False++{-------------------------------------------------------------------------------+ Pinned vs. unpinned buffers+-------------------------------------------------------------------------------}++-- | Test that 'submitIO' using pinned buffers returns /no/ "unpinned buffers"+-- error+prop_submitIO_buffersPinned :: Property+prop_submitIO_buffersPinned =+ ioProperty $+ withTempIOHasBlockIO "prop_submitIO_pinnedBuffers" $ \hfs hbio ->+ FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do+ void $ FS.hPutAll hfs h $ LBS.pack [1..100]+ buf <- newPinnedByteArray 17+ let ioops = V.fromList [+ IOOpWrite h 0 buf 0 17+ , IOOpRead h 0 buf 0 17+ ]+ eith <- try @FsError $ submitIO hbio ioops+ pure $ case eith of+ Left e+ -> counterexample ("Unexpected error: " <> displayException e) False+ Right _+ -> property True+ where+ path = FS.mkFsPath ["temp-file"]++-- | Test that 'submitIO' using unpinned buffers returns an "unpinned buffers" error+prop_submitIO_buffersUnpinned :: Property+prop_submitIO_buffersUnpinned =+ ioProperty $+ withTempIOHasBlockIO "prop_submitIO_unpinnedBuffers" $ \hfs hbio ->+ FS.withFile hfs path (FS.ReadWriteMode FS.MustBeNew) $ \h -> do+ void $ FS.hPutAll hfs h $ LBS.pack [1..100]+ buf <- newByteArray 17+ let ioops = V.fromList [+ IOOpWrite h 0 buf 0 17+ , IOOpRead h 0 buf 0 17+ ]+ eith <- try @FsError $ submitIO hbio ioops+ pure $ case eith of+ Left e+ | isNotPinnedError e+ -> property True+ | otherwise+ -> counterexample ("Unexpected error: " <> displayException e) False+ Right _+ -> counterexample ("Unexpected success") False+ where+ path = FS.mkFsPath ["temp-file"]++-- TODO: add a property that checks @isNotPinnedError . mkNotPinnedError = True@+isNotPinnedError :: FsError -> Bool+isNotPinnedError e+ | fsErrorType e == FsInvalidArgument+ , "MutableByteArray is unpinned: " `List.isPrefixOf` (fsErrorString e)+ = True+ | otherwise+ = False++{-------------------------------------------------------------------------------+ File locks+-------------------------------------------------------------------------------}++withTempIOHasBlockIO :: FilePath -> (HasFS IO HandleIO -> HasBlockIO IO HandleIO -> IO a) -> IO a+withTempIOHasBlockIO path action = withSystemTempDirectory path $ \dir -> do+ IO.withIOHasBlockIO (MountPoint dir) IO.defaultIOCtxParams action++showLeft :: Show a => String -> Either a b -> String+showLeft x = \case+ Left e -> show e+ Right _ -> x++prop_tryLockFileExclusiveTwice :: Property+prop_tryLockFileExclusiveTwice = ioProperty $+ withTempIOHasBlockIO "prop_tryLockFileExclusiveTwice" $ \_hfs hbio -> do+ bracket (tryLockFile hbio fsp ExclusiveLock)+ (traverse_ hUnlock) $ \_ ->+ bracket (try @SomeException (tryLockFile hbio fsp ExclusiveLock))+ (traverse_ hUnlock . Compose) $ \case+ Left (SomeException e)+ | Just (e' :: FsError) <- cast e -> pure $ label (show $ fsErrorType e') $ True+ x -> pure $ counterexample+ ( "Opening a session twice in the same directory \+ \should fail with an FsError, but it returned \+ \the following instead: " <> showLeft "LockFileHandle" x )+ False+ where+ fsp = FS.mkFsPath ["lockfile"]++{-------------------------------------------------------------------------------+ Storage synchronisation+-------------------------------------------------------------------------------}++prop_synchronise :: Property+prop_synchronise =+ ioProperty $+ withTempIOHasBlockIO "temp" $ \hfs hbio -> do+ FS.createDirectory hfs dir+ FS.withFile hfs file (FS.ReadWriteMode FS.MustBeNew) $ \h ->+ void $ FS.hPutAllStrict hfs h (BSC.pack "file-contents")+ FS.synchroniseFile hfs hbio file+ FS.synchroniseDirectory hbio dir+ where+ dir = FS.mkFsPath ["dir"]+ file = dir FS.</> FS.mkFsPath ["file"]++prop_synchroniseFile_fileDoesNotExist :: Property+prop_synchroniseFile_fileDoesNotExist =+ expectFailure $+ ioProperty $+ withTempIOHasBlockIO "temp" $ \hfs hbio -> do+ FS.synchroniseFile hfs hbio file+ where+ file = FS.mkFsPath ["file"]++prop_synchroniseDirectory_directoryDoesNotExist :: Property+prop_synchroniseDirectory_directoryDoesNotExist =+ expectFailure $+ ioProperty $+ withTempIOHasBlockIO "temp" $ \_hfs hbio -> do+ FS.synchroniseDirectory hbio dir+ where+ dir = FS.mkFsPath ["dir"]