diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for blockio + +## 0.1.0.0 -- 2025-07-15 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. diff --git a/blockio.cabal b/blockio.cabal new file mode 100644 --- /dev/null +++ b/blockio.cabal @@ -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 diff --git a/src-linux/System/FS/BlockIO/Async.hs b/src-linux/System/FS/BlockIO/Async.hs new file mode 100644 --- /dev/null +++ b/src-linux/System/FS/BlockIO/Async.hs @@ -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) diff --git a/src-linux/System/FS/BlockIO/Internal.hs b/src-linux/System/FS/BlockIO/Internal.hs new file mode 100644 --- /dev/null +++ b/src-linux/System/FS/BlockIO/Internal.hs @@ -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 diff --git a/src-macos/System/FS/BlockIO/Internal.hs b/src-macos/System/FS/BlockIO/Internal.hs new file mode 100644 --- /dev/null +++ b/src-macos/System/FS/BlockIO/Internal.hs @@ -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 diff --git a/src-sim/System/FS/BlockIO/Sim.hs b/src-sim/System/FS/BlockIO/Sim.hs new file mode 100644 --- /dev/null +++ b/src-sim/System/FS/BlockIO/Sim.hs @@ -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) diff --git a/src-windows/System/FS/BlockIO/Internal.hs b/src-windows/System/FS/BlockIO/Internal.hs new file mode 100644 --- /dev/null +++ b/src-windows/System/FS/BlockIO/Internal.hs @@ -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") diff --git a/src/System/FS/BlockIO.hs b/src/System/FS/BlockIO.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO.hs @@ -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] +-} diff --git a/src/System/FS/BlockIO/API.hs b/src/System/FS/BlockIO/API.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO/API.hs @@ -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 () + } diff --git a/src/System/FS/BlockIO/IO.hs b/src/System/FS/BlockIO/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO/IO.hs @@ -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) diff --git a/src/System/FS/BlockIO/IO/Internal.hs b/src/System/FS/BlockIO/IO/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO/IO/Internal.hs @@ -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' diff --git a/src/System/FS/BlockIO/Serial.hs b/src/System/FS/BlockIO/Serial.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO/Serial.hs @@ -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) diff --git a/src/System/FS/BlockIO/Serial/Internal.hs b/src/System/FS/BlockIO/Serial/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/BlockIO/Serial/Internal.hs @@ -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) diff --git a/test-sim/Main.hs b/test-sim/Main.hs new file mode 100644 --- /dev/null +++ b/test-sim/Main.hs @@ -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 _" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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"]