fs-api (empty) → 0.3.0.0
raw patch · 19 files changed
+2378/−0 lines, 19 filesdep +Win32dep +basedep +bytestring
Dependencies added: Win32, base, bytestring, containers, deepseq, digest, directory, filepath, fs-api, io-classes, primitive, safe-wild-cards, tasty, tasty-quickcheck, temporary, text, unix, unix-bytestring
Files
- CHANGELOG.md +83/−0
- LICENSE +177/−0
- NOTICE +14/−0
- README.md +26/−0
- fs-api.cabal +96/−0
- src-unix/System/FS/IO/Unix.hs +176/−0
- src-win32/System/FS/IO/Windows.hs +130/−0
- src/System/FS/API.hs +371/−0
- src/System/FS/API/Lazy.hs +138/−0
- src/System/FS/API/Strict.hs +32/−0
- src/System/FS/API/Types.hs +471/−0
- src/System/FS/CRC.hs +92/−0
- src/System/FS/CallStack.hs +28/−0
- src/System/FS/Condense.hs +113/−0
- src/System/FS/IO.hs +116/−0
- src/System/FS/IO/Handle.hs +70/−0
- test/Main.hs +11/−0
- test/Test/System/FS/API/FsPath.hs +84/−0
- test/Test/System/FS/IO.hs +150/−0
+ CHANGELOG.md view
@@ -0,0 +1,83 @@+# Revision history for fs-api++## 0.3.0.0 -- 2024-08-26++### Breaking++* Remove orphan `Show` instance for `Foreign.C.Error.Errno`.+* Provide implementations for the new primitives in the `IO` implementation of+ `HasFS`. As a result, `ioHasFS` now requires that `PrimState IO ~ PrimState m`.+* Rename `Util.CallStack` and `Util.Condense` to `System.FS.CallStack` and+ `System.FS.Condense` respectively.+* Make modules in the `System.FS.IO.Internal` hierarchy public, inspired by+ "Internal convention is a mistake". The following modules are moved/renamed:+ * `System.FS.IO.Internal` is moved to `System.FS.IO.Unix` on Linux and MacOS+ systems, and moved to `System.FS.IO.Windows` on Windows systems.+ * `System.FS.IO.Internal.Handle` is moved to `System.FS.IO.Handle`.++### Non-breaking++* Add new primitives to the `HasFS` interface for performing file I/O with+ user-supplied buffers: `hGetBufSome`, `hGetBufSomeAt`, `hPutBufSome`, and+ `hPutBufSomeAt`.+* Add compound functions, built from the new primitives in `HasFS`:+ `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`, and+ `hPutBufExactlyAt`.+* `NFData` instances for `FsPath`, `HasFS` and `Handle`.+* Add `FsPath` combinators: `(<.>)` and `addExtension`, `(</>)` and `combine`.++### Patch++* Add a clarification in the documentation of `FsPath` that the user is+ responsible for picking sensible directory/file names.+* Bump upper version bounds for `io-classes` to `1.6`+* Make it build with `ghc-9.10`.+* New `primitive ^>=0.9` dependency+* Tight dependency bounds.++## 0.2.0.1 -- 2023-10-30++### Patch++* Make it build with `ghc-9.8`.++## 0.2.0.0 -- 2023-08-01++### Breaking++* Modules that are required for `ioHasFS` should never be used by client code.+ For this reason, we move the relevant modules into an `Internal` hierarchy.+ * Move the `System.IO.FS` module to `System.FS.IO.Internal`.+ * Move the `System.FS.Handle` module to `System.FS.IO.Internal.Handle`.+* Move strict and lazy compound definitions for reading/writing bytes into+ separate modules `System.FS.API.Strict` and `System.FS.API.Lazy`. Both modules+ re-export `System.FS.API`.++### Non-breaking++* Re-export `System.FS.API.Types` from `System.FS.API`.++### Patch++* Bump upper version bounds for `io-classes` to `1.3`++## 0.1.0.3 -- 2023-06-2++### Patch++* Enable building with `ghc-9.4`.+* Remove `asserts` package flag.++## 0.1.0.2 -- 2023-05-25++* Enable building with ghc-9.6++## 0.1.0.1 -- 2023-04-24++### Non-breaking++Update the code to compile with `io-sim-1.0.0.1`.++## 0.1.0.0 -- 2023-03-27++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,177 @@++ 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
+ NOTICE view
@@ -0,0 +1,14 @@+Copyright 2019-2024 Input Output Global Inc (IOG)++ 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.+
+ README.md view
@@ -0,0 +1,26 @@+# fs-api++The `fs-api` package provides an abstract interface to filesystems. The abstract+interface is a datatype called `HasFS`, which is parameterised over a monad `m`+that filesystem operations run in, and the type of file handles `h`.+`removeFile` is an example of a filesystem operation in this interface.++```haskell+data HasFS m h = HasFS {+ {- omitted -}+ -- | Remove the file (which must exist)+ , removeFile :: HasCallStack => FsPath -> m ()+ {- omitted -}+ }+```++Code that is written using this interface can be run against any implementation+of a file system. The `System.FS.IO` module provides a function for initialising+a `HasFS` interface for the real filesystem.++```haskell+ioHasFS :: (MonadIO m, PrimState IO ~ PrimState m) => MountPoint -> HasFS m HandleIO+```++Note that `ioHasFS` requires some context in the form of a `MountPoint`: the+base directory in which the filesystem operations should be run.
+ fs-api.cabal view
@@ -0,0 +1,96 @@+cabal-version: 3.0+name: fs-api+version: 0.3.0.0+synopsis: Abstract interface for the file system+description: Abstract interface for the file system.+license: Apache-2.0+license-files:+ LICENSE+ NOTICE++copyright: 2019-2024 Input Output Global Inc (IOG)+author: IOG Engineering Team+maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com)+category: System+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md++tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10++source-repository head+ type: git+ location: https://github.com/input-output-hk/fs-sim+ subdir: fs-api++library+ hs-source-dirs: src+ exposed-modules:+ System.FS.API+ System.FS.API.Lazy+ System.FS.API.Strict+ System.FS.API.Types+ System.FS.CallStack+ System.FS.Condense+ System.FS.CRC+ System.FS.IO+ System.FS.IO.Handle++ default-language: Haskell2010+ build-depends:+ , base >=4.14 && <4.21+ , bytestring ^>=0.10 || ^>=0.11 || ^>=0.12+ , containers ^>=0.5 || ^>=0.6 || ^>=0.7+ , deepseq ^>=1.4 || ^>=1.5+ , digest ^>=0.0+ , directory ^>=1.3+ , filepath ^>=1.4 || ^>=1.5+ , io-classes ^>=1.0 || ^>=1.1 || ^>=1.2 || ^>=1.3 || ^>=1.4 || ^>=1.5+ , primitive ^>=0.9+ , safe-wild-cards ^>=1.0+ , text ^>=1.2 || ^>=2.0 || ^>=2.1++ if os(windows)+ hs-source-dirs: src-win32+ exposed-modules: System.FS.IO.Windows+ build-depends: Win32 >=2.6.1.0++ -- every other distribution is handled like it is Unix-based+ else+ hs-source-dirs: src-unix+ exposed-modules: System.FS.IO.Unix+ build-depends:+ , unix ^>=2.7 || ^>=2.8+ , unix-bytestring ^>=0.4++ ghc-options:+ -Wall -Wcompat -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wpartial-fields -Widentities+ -Wredundant-constraints -Wmissing-export-lists -Wunused-packages++test-suite fs-api-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ Test.System.FS.API.FsPath+ Test.System.FS.IO++ default-language: Haskell2010+ build-depends:+ , base+ , bytestring+ , filepath+ , fs-api+ , primitive+ , tasty+ , tasty-quickcheck+ , temporary+ , text++ ghc-options:+ -Wall -Wcompat -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wpartial-fields -Widentities+ -Wredundant-constraints -Wmissing-export-lists -Wunused-packages+ -fno-ignore-asserts
+ src-unix/System/FS/IO/Unix.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}++-- | This module is mainly meant to be used for the 'IO' implementation of+-- 'System.FS.API.HasFS'.+module System.FS.IO.Unix (+ FHandle+ , close+ , getSize+ , open+ , pread+ , preadBuf+ , pwriteBuf+ , read+ , readBuf+ , seek+ , truncate+ , write+ , writeBuf+ ) where++import Prelude hiding (read, truncate)++import Control.Monad (void)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as Internal+import Data.Int (Int64)+import Data.Word (Word32, Word64, Word8)+import Foreign (Ptr)+import System.FS.API.Types (AllowExisting (..), OpenMode (..),+ SeekMode (..))+import System.FS.IO.Handle+import qualified System.Posix as Posix+import System.Posix (ByteCount, Fd (..), FileOffset)+import qualified System.Posix.IO.ByteString.Ext as Posix (fdPreadBuf,+ fdPwriteBuf)++type FHandle = HandleOS Fd++-- | Some sensible defaults for the 'OpenFileFlags'.+--+-- NOTE: the 'unix' package /already/ exports a smart constructor called+-- @defaultFileFlags@ already, but we define our own to not be depedent by+-- whichever default choice unix's library authors made, and to be able to+-- change our minds later if necessary. In particular, we are interested in the+-- 'append' and 'exclusive' flags, which were largely the reason why we+-- introduced this low-level module.+defaultFileFlags :: Posix.OpenFileFlags+defaultFileFlags = Posix.OpenFileFlags {+ Posix.append = False+ , Posix.exclusive = False+ , Posix.noctty = False+ , Posix.nonBlock = False+ , Posix.trunc = False+# if MIN_VERSION_unix(2,8,0)+ , Posix.nofollow = False+ , Posix.creat = Nothing+ , Posix.cloexec = False+ , Posix.directory = False+ , Posix.sync = False+# endif+ }++-- | Opens a file from disk.+open :: FilePath -> OpenMode -> IO Fd+# if MIN_VERSION_unix(2,8,0)+open fp openMode = Posix.openFd fp posixOpenMode fileFlags+ where+ (posixOpenMode, fileFlags) = case openMode of+ ReadMode -> ( Posix.ReadOnly+ , defaultFileFlags+ )+ AppendMode ex -> ( Posix.WriteOnly+ , defaultFileFlags { Posix.append = True+ , Posix.exclusive = isExcl ex+ , Posix.creat = Just Posix.stdFileMode }+ )+ ReadWriteMode ex -> ( Posix.ReadWrite+ , defaultFileFlags { Posix.exclusive = isExcl ex+ , Posix.creat = Just Posix.stdFileMode }+ )+ WriteMode ex -> ( Posix.ReadWrite+ , defaultFileFlags { Posix.exclusive = isExcl ex+ , Posix.creat = Just Posix.stdFileMode }+ )++ isExcl AllowExisting = False+ isExcl MustBeNew = True+# else+open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags+ where+ (posixOpenMode, fileMode, fileFlags) = case openMode of+ ReadMode -> ( Posix.ReadOnly+ , Nothing+ , defaultFileFlags+ )+ AppendMode ex -> ( Posix.WriteOnly+ , Just Posix.stdFileMode+ , defaultFileFlags { Posix.append = True+ , Posix.exclusive = isExcl ex }+ )+ ReadWriteMode ex -> ( Posix.ReadWrite+ , Just Posix.stdFileMode+ , defaultFileFlags { Posix.exclusive = isExcl ex }+ )+ WriteMode ex -> ( Posix.ReadWrite+ , Just Posix.stdFileMode+ , defaultFileFlags { Posix.exclusive = isExcl ex }+ )++ isExcl AllowExisting = False+ isExcl MustBeNew = True+# endif++-- | Writes the data pointed by the input 'Ptr Word8' into the input 'FHandle'.+write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32+write h data' bytes = withOpenHandle "write" h $ \fd ->+ fromIntegral <$> Posix.fdWriteBuf fd data' (fromIntegral bytes)++-- | Seek within the file.+--+-- The offset may be negative.+--+-- We don't return the new offset since the behaviour of lseek is rather odd+-- (e.g., the file pointer may not actually be moved until a subsequent write)+seek :: FHandle -> SeekMode -> Int64 -> IO ()+seek h seekMode offset = withOpenHandle "seek" h $ \fd ->+ void $ Posix.fdSeek fd seekMode (fromIntegral offset)++-- | Reads a given number of bytes from the input 'FHandle'.+read :: FHandle -> Word64 -> IO ByteString+read h bytes = withOpenHandle "read" h $ \fd ->+ Internal.createUptoN (fromIntegral bytes) $ \ptr ->+ fromIntegral <$> Posix.fdReadBuf fd ptr (fromIntegral bytes)++readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount+readBuf f buf c = withOpenHandle "readBuf" f $ \fd -> Posix.fdReadBuf fd buf c++writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount+writeBuf f buf c = withOpenHandle "writeBuf" f $ \fd -> Posix.fdWriteBuf fd buf c++pread :: FHandle -> Word64 -> Word64 -> IO ByteString+pread h bytes offset = withOpenHandle "pread" h $ \fd ->+ Internal.createUptoN (fromIntegral bytes) $ \ptr ->+ fromIntegral <$> Posix.fdPreadBuf fd ptr (fromIntegral bytes) (fromIntegral offset)++-- | @'preadBuf' fh buf c off@ reads @c@ bytes into the buffer @buf@ from the file+-- handle @fh@ at the file offset @off@. This does not move the position of the+-- file handle.+preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount+preadBuf h buf c off = withOpenHandle "preadBuf" h $ \fd -> Posix.fdPreadBuf fd buf c off++-- | @'pwriteBuf' fh buf c off@ writes @c@ bytes from the data in the buffer+-- @buf@ to the file handle @fh@ at the file offset @off@. This does not move+-- the position of the file handle.+pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount+pwriteBuf h buf c off = withOpenHandle "pwriteBuf" h $ \fd -> Posix.fdPwriteBuf fd buf c off++-- | Truncates the file managed by the input 'FHandle' to the input size.+truncate :: FHandle -> Word64 -> IO ()+truncate h sz = withOpenHandle "truncate" h $ \fd ->+ Posix.setFdSize fd (fromIntegral sz)++-- | Close handle+--+-- This is a no-op when the handle is already closed.+close :: FHandle -> IO ()+close h = closeHandleOS h Posix.closeFd++-- | File size of the given file pointer+--+-- NOTE: This is not thread safe (changes made to the file in other threads+-- may affect this thread).+getSize :: FHandle -> IO Word64+getSize h = withOpenHandle "getSize" h $ \fd ->+ fromIntegral . Posix.fileSize <$> Posix.getFdStatus fd
+ src-win32/System/FS/IO/Windows.hs view
@@ -0,0 +1,130 @@+{-# OPTIONS_GHC -Wno-dodgy-imports #-}++-- | This module is mainly meant to be used for the 'IO' implementation of+-- 'System.FS.API.HasFS'.+module System.FS.IO.Windows (+ FHandle+ , close+ , getSize+ , open+ , pread+ , preadBuf+ , pwriteBuf+ , read+ , readBuf+ , seek+ , truncate+ , write+ , writeBuf+ ) where++import Prelude hiding (read, truncate)++import Control.Monad (void)+import Data.Bits ((.|.))+import Data.ByteString+import Data.ByteString.Internal as Internal+import Data.Word (Word32, Word64, Word8)+import Foreign (Int64, Ptr)+import System.FS.API.Types (AllowExisting (..), OpenMode (..),+ SeekMode (..))+import System.FS.IO.Handle+import System.Posix.Types+import System.Win32++type FHandle = HandleOS HANDLE++open :: FilePath -> OpenMode -> IO HANDLE+open filename openMode = do+ h <- createFile filename+ accessMode+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE)+ Nothing+ creationDisposition+ fILE_ATTRIBUTE_NORMAL+ Nothing+ -- There is no AppendMode in Windows, so we manually seek to the end of+ -- the file. For now we don't need to carry a flag that this handle is in+ -- AppendMode, but we may need to if we add more commands (read and seek+ -- are disabled in AppendMode and truncate only works in AppendMode, write+ -- moves the file offset in all modes).+ case openMode of+ AppendMode{} -> void $ setFilePointerEx h 0 fILE_END+ _ -> return ()+ return h+ where+ (accessMode, creationDisposition) = case openMode of+ ReadMode -> (gENERIC_READ, oPEN_EXISTING)+ AppendMode ex -> ( gENERIC_WRITE, createNew ex)+ WriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex)+ ReadWriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex)+ createNew AllowExisting = oPEN_ALWAYS+ createNew MustBeNew = cREATE_NEW++write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32+write fh data' bytes = withOpenHandle "write" fh $ \h ->+ win32_WriteFile h data' (fromIntegral bytes) Nothing++seek :: FHandle -> SeekMode -> Int64 -> IO ()+seek fh seekMode size = void <$> withOpenHandle "seek" fh $ \h ->+ setFilePointerEx h size (fromSeekMode seekMode)++fromSeekMode :: SeekMode -> FilePtrDirection+fromSeekMode AbsoluteSeek = fILE_BEGIN+fromSeekMode RelativeSeek = fILE_CURRENT+fromSeekMode SeekFromEnd = fILE_END++read :: FHandle -> Word64 -> IO ByteString+read fh bytes = withOpenHandle "read" fh $ \h ->+ Internal.createUptoN (fromIntegral bytes) $ \ptr ->+ fromIntegral <$> win32_ReadFile h ptr (fromIntegral bytes) Nothing++getCurrentFileOffset :: HANDLE -> IO Int64+getCurrentFileOffset h = setFilePointerEx h 0 fILE_CURRENT++readBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount+readBuf fh buf c = withOpenHandle "readBuf" fh $ \h ->+ fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing++writeBuf :: FHandle -> Ptr Word8 -> ByteCount -> IO ByteCount+writeBuf fh buf c = withOpenHandle "writeBuf" fh $ \h ->+ fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing++pread :: FHandle -> Word64 -> Word64 -> IO ByteString+pread fh bytes pos = withOpenHandle "pread" fh $ \h ->+ Internal.createUptoN (fromIntegral bytes) $ \ptr -> do+ initialOffset <- getCurrentFileOffset h+ _ <- setFilePointerEx h (fromIntegral pos) fILE_BEGIN+ n <- fromIntegral <$> win32_ReadFile h ptr (fromIntegral bytes) Nothing+ _ <- setFilePointerEx h initialOffset fILE_BEGIN+ return n++preadBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount+preadBuf fh buf c off = withOpenHandle "preadBuf" fh $ \h -> do+ initialOffset <- getCurrentFileOffset h+ _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN+ n <- fromIntegral <$> win32_ReadFile h buf (fromIntegral c) Nothing+ _ <- setFilePointerEx h initialOffset fILE_BEGIN+ return n++pwriteBuf :: FHandle -> Ptr Word8 -> ByteCount -> FileOffset -> IO ByteCount+pwriteBuf fh buf c off = withOpenHandle "pwriteBuf" fh $ \h -> do+ initialOffset <- getCurrentFileOffset h+ _ <- setFilePointerEx h (fromIntegral off) fILE_BEGIN+ n <- fromIntegral <$> win32_WriteFile h buf (fromIntegral c) Nothing+ _ <- setFilePointerEx h initialOffset fILE_BEGIN+ return n++-- We only allow truncate in AppendMode, but Windows do not support it, so we manually seek to the end.+-- It is important that the logical end of the handle stays alligned to the physical end of the file.+truncate :: FHandle -> Word64 -> IO ()+truncate fh size = withOpenHandle "truncate" fh $ \h -> do+ _ <- setFilePointerEx h (fromIntegral size) (fromSeekMode AbsoluteSeek)+ setEndOfFile h++close :: FHandle -> IO ()+close fh = closeHandleOS fh closeHandle++getSize :: FHandle -> IO Word64+getSize fh = withOpenHandle "getSize" fh $ \h ->+ bhfiSize <$> getFileInformationByHandle h
+ src/System/FS/API.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++-- | An abstract view over the filesystem.+module System.FS.API (+ -- * Record that abstracts over the filesystem+ HasFS (..)+ -- * Types+ , module Types+ -- * Opening and closing files+ , hClose'+ , withFile+ -- * SomeHasFS+ , SomeHasFS (..)+ -- * File I\/O with user-supplied buffers+ , BufferOffset (..)+ , hGetBufExactly+ , hGetBufExactlyAt+ , hPutBufExactly+ , hPutBufExactlyAt+ ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.Class.MonadThrow+import Control.Monad.Primitive (PrimMonad (..))+import qualified Data.ByteString as BS+import Data.Int (Int64)+import Data.Primitive (MutableByteArray)+import Data.Set (Set)+import Data.Word+import SafeWildCards+import System.Posix.Types (ByteCount)++import System.FS.API.Types as Types+import System.FS.CallStack++{------------------------------------------------------------------------------+ Record that abstracts over the filesystem+------------------------------------------------------------------------------}++-- | Abstract interface for performing file I\/O+--+-- [User-supplied buffers #user-supplied-buffers#]: For functions that require+-- user-supplied buffers (i.e., 'MutableByteArray'), it is the user's+-- responsiblity to provide buffers that are large enough. Behaviour is+-- undefined if the I\/O operations access the buffer outside it's allocated+-- range.+data HasFS m h = HasFS {+ -- | Debugging: human-readable description of file system state+ dumpState :: m String++ -- Operations of files++ -- | Open a file+ , hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)++ -- | Close a file+ , hClose :: HasCallStack => Handle h -> m ()++ -- | Is the handle open?+ , hIsOpen :: HasCallStack => Handle h -> m Bool++ -- | Seek handle+ --+ -- The offset is an 'Int64' rather than a 'Word64' because it may be+ -- negative (for use in relative positioning).+ --+ -- Unlike the Posix @lseek@, 'hSeek' does not return the new seek position+ -- because the value returned by Posix is rather strange and unreliable+ -- and we don't want to emulate it's behaviour.+ , hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()++ -- | Try to read @n@ bytes from a handle+ --+ -- When at the end of the file, an empty bytestring will be returned.+ --+ -- The returned bytestring will typically have length @n@, but may be+ -- shorter in case of a partial read, see #277. However, a partial read+ -- will always return at least 1 byte, as returning 0 bytes would mean+ -- that we have reached EOF.+ --+ -- Postcondition: for the length of the returned bytestring @bs@ we have+ -- @length bs >= 0@ and @length bs <= n@.+ , hGetSome :: HasCallStack => Handle h -> Word64 -> m BS.ByteString++ -- | Same as 'hGetSome', but does not affect the file offset. An additional argument+ -- is used to specify the offset. This allows it to be called concurrently for the+ -- same file handle. However, the actual level of parallelism achieved depends on+ -- the implementation and the operating system: generally on Unix it will be+ -- \"more parallel\" than on Windows.+ , hGetSomeAt :: HasCallStack+ => Handle h+ -> Word64 -- The number of bytes to read.+ -> AbsOffset -- The offset at which to read.+ -> m BS.ByteString++ -- | Write to a handle+ --+ -- The return value indicates the number of bytes written and will+ -- typically be equal to @l@, the length of the bytestring, but may be+ -- shorter in case of a partial write, see #277.+ --+ -- If nothing can be written at all, an exception will be thrown.+ --+ -- Postcondition: the return value @n@ is @n > 0@ and @n <= l@, unless the+ -- given bytestring is empty, in which case @n@ can be 0.+ , hPutSome :: HasCallStack => Handle h -> BS.ByteString -> m Word64++ -- | Truncate the file to the specified size+ --+ -- NOTE: Only supported in append mode.+ , hTruncate :: HasCallStack => Handle h -> Word64 -> m ()++ -- | Return current file size+ --+ -- NOTE: This is not thread safe (changes made to the file in other threads+ -- may affect this thread).+ , hGetSize :: HasCallStack => Handle h -> m Word64++ -- Operations of directories++ -- | Create new directory+ , createDirectory :: HasCallStack => FsPath -> m ()++ -- | Create new directory if it doesn't exist.+ --+ -- @createDirectoryIfMissing True@ will also try to create all parent dirs.+ , createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()++ -- | List contents of a directory+ , listDirectory :: HasCallStack => FsPath -> m (Set String)++ -- | Check if the path exists and is a directory+ , doesDirectoryExist :: HasCallStack => FsPath -> m Bool++ -- | Check if the path exists and is a file+ , doesFileExist :: HasCallStack => FsPath -> m Bool++ -- | Remove the directory (which must exist) and its contents+ , removeDirectoryRecursive :: HasCallStack => FsPath -> m ()++ -- | Remove the file (which must exist)+ , removeFile :: HasCallStack => FsPath -> m ()++ -- | Rename the file (which must exist) from the first path to the second+ -- path. If there is already a file at the latter path, it is replaced by+ -- the new one.+ --+ -- NOTE: only works for files within the same folder.+ , renameFile :: HasCallStack => FsPath -> FsPath -> m ()++ -- | Useful for better error reporting+ , mkFsErrorPath :: FsPath -> FsErrorPath++ -- | Create an absolute 'FilePath' from a relative 'FsPath'.+ --+ -- This is an escape hatch for creating absolute paths when @m ~'IO'@.+ --+ -- Postcondition: Should throw an error for any @m@ that is not @IO@+ -- (or for which we do not have @'MonadIO' m@).+ , unsafeToFilePath :: FsPath -> m FilePath++ -- === File I\/O with user-supplied buffers++ -- | Like 'hGetSome', but the bytes are read into a user-supplied buffer.+ -- See [__User-supplied buffers__](#user-supplied-buffers).+ , hGetBufSome :: HasCallStack+ => Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to read+ -> m ByteCount+ -- | Like 'hGetSomeAt', but the bytes are read into a user-supplied buffer.+ -- See [__User-supplied buffers__](#user-supplied-buffers).+ , hGetBufSomeAt :: HasCallStack+ => Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to read+ -> AbsOffset -- ^ The file offset at which to read+ -> m ByteCount+ -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer.+ -- See [__User-supplied buffers__](#user-supplied-buffers).+ , hPutBufSome :: HasCallStack+ => Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to write+ -> m ByteCount+ -- | Like 'hPutSome', but the bytes are written from a user-supplied buffer+ -- at a given file offset. This offset does not affect the offset stored in+ -- the file handle (see also 'hGetSomeAt'). See [__User-supplied buffers__](#user-supplied-buffers).+ , hPutBufSomeAt :: HasCallStack+ => Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to write+ -> AbsOffset -- ^ The file offset at which to write+ -> m ByteCount+ }++{-------------------------------------------------------------------------------+ Opening and closing files+-------------------------------------------------------------------------------}++withFile :: (HasCallStack, MonadThrow m)+ => HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a+withFile HasFS{..} fp openMode = bracket (hOpen fp openMode) hClose++-- | Returns 'True' when the handle was still open.+hClose' :: (HasCallStack, Monad m) => HasFS m h -> Handle h -> m Bool+hClose' HasFS { hClose, hIsOpen } h = do+ isOpen <- hIsOpen h+ if isOpen then do+ hClose h+ return True+ else+ return False++{-------------------------------------------------------------------------------+ SomeHasFS+-------------------------------------------------------------------------------}++-- | It is often inconvenient to have to parameterise over @h@. This data type+-- hides an existential @h@ parameter of a 'HasFS'.+data SomeHasFS m where+ SomeHasFS :: Eq h => HasFS m h -> SomeHasFS m++{-------------------------------------------------------------------------------+ File I\/O with user-supplied buffers+-------------------------------------------------------------------------------}++-- | Absolute offset into a buffer (i.e., 'MutableByteArray').+--+-- Can be negative, because buffer offsets can be added together to change+-- offset positions. This is similar to 'plusPtr' for 'Ptr' types. However, note+-- that reading or writing from a buffer at a negative offset leads to undefined+-- behaviour.+newtype BufferOffset = BufferOffset { unBufferOffset :: Int }+ deriving (Eq, Ord, Enum, Bounded, Num, Show)++-- | Wrapper for 'hGetBufSome' that ensures that we read exactly as many+-- bytes as requested. If EOF is found before the requested number of bytes is+-- read, an 'FsError' exception is thrown.+hGetBufExactly :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to read+ -> m ByteCount+hGetBufExactly hfs h buf bufOff c = go c bufOff+ where+ go :: ByteCount -> BufferOffset -> m ByteCount+ go !remainingCount !currentBufOff+ | remainingCount == 0 = pure c+ | otherwise = do+ readBytes <- hGetBufSome hfs h buf currentBufOff c+ if readBytes == 0 then+ throwIO FsError {+ fsErrorType = FsReachedEOF+ , fsErrorPath = mkFsErrorPath hfs $ handlePath h+ , fsErrorString = "hGetBufExactly found eof before reading " ++ show c ++ " bytes"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ -- We know the length <= remainingBytes, so this can't underflow.+ else go (remainingCount - readBytes)+ (currentBufOff + fromIntegral readBytes)++-- | Wrapper for 'hGetBufSomeAt' that ensures that we read exactly as many bytes+-- as requested. If EOF is found before the requested number of bytes is read,+-- an 'FsError' exception is thrown.+hGetBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to read bytes into+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to read+ -> AbsOffset -- ^ The file offset at which to read+ -> m ByteCount+hGetBufExactlyAt hfs h buf bufOff c off = go c off bufOff+ where+ go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount+ go !remainingCount !currentOffset !currentBufOff+ | remainingCount == 0 = pure c+ | otherwise = do+ readBytes <- hGetBufSomeAt hfs h buf currentBufOff c currentOffset+ if readBytes == 0 then+ throwIO FsError {+ fsErrorType = FsReachedEOF+ , fsErrorPath = mkFsErrorPath hfs $ handlePath h+ , fsErrorString = "hGetBufExactlyAt found eof before reading " ++ show c ++ " bytes"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ -- We know the length <= remainingBytes, so this can't underflow.+ else go (remainingCount - readBytes)+ (currentOffset + fromIntegral readBytes)+ (currentBufOff + fromIntegral readBytes)++-- | Wrapper for 'hPutBufSome' that ensures we write exactly as many bytes as+-- requested.+hPutBufExactly :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to write+ -> m ByteCount+hPutBufExactly hbfs h buf bufOff c = go c bufOff+ where+ go :: ByteCount -> BufferOffset -> m ByteCount+ go !remainingCount !currentBufOff = do+ writtenBytes <- hPutBufSome hbfs h buf currentBufOff remainingCount+ let remainingCount' = remainingCount - writtenBytes+ if remainingCount' == 0+ then pure c+ else go remainingCount'+ (currentBufOff + fromIntegral writtenBytes)++-- | Wrapper for 'hPutBufSomeAt' that ensures we write exactly as many bytes as+-- requested.+hPutBufExactlyAt :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> MutableByteArray (PrimState m) -- ^ Buffer to write bytes from+ -> BufferOffset -- ^ Offset into buffer+ -> ByteCount -- ^ The number of bytes to write+ -> AbsOffset -- ^ The file offset at which to write+ -> m ByteCount+hPutBufExactlyAt hbfs h buf bufOff c off = go c off bufOff+ where+ go :: ByteCount -> AbsOffset -> BufferOffset -> m ByteCount+ go !remainingCount !currentOffset !currentBufOff = do+ writtenBytes <- hPutBufSomeAt hbfs h buf currentBufOff remainingCount currentOffset+ let remainingCount' = remainingCount - writtenBytes+ if remainingCount' == 0+ then pure c+ else go remainingCount'+ (currentOffset + fromIntegral writtenBytes)+ (currentBufOff + fromIntegral writtenBytes)++{-------------------------------------------------------------------------------+ Other+--------------------------------------------------------------------------------}++-- Without this, the module won't compile because the instance below is in the+-- same declaration group as the datatype definition. For more info, see+-- https://blog.monadfix.com/th-groups.+$(pure[])++instance NFData (HasFS m h) where+ rnf $(fields 'HasFS) =+ dumpState `seq` hOpen `seq` hClose `seq` hIsOpen `seq` hSeek `seq`+ hGetSome `seq`hGetSomeAt `seq` hPutSome `seq` hTruncate `seq`+ hGetSize `seq` createDirectory `seq` createDirectoryIfMissing `seq`+ listDirectory `seq` doesDirectoryExist `seq` doesFileExist `seq`+ removeDirectoryRecursive `seq` removeFile `seq` renameFile `seq`+ mkFsErrorPath `seq` unsafeToFilePath `seq` hGetBufSome `seq`+ hGetBufSomeAt `seq` hPutBufSome `seq` hPutBufSomeAt `seq` ()
+ src/System/FS/API/Lazy.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module System.FS.API.Lazy (+ -- * API+ module API+ -- * Lazy functions+ , hGetAll+ , hGetAllAt+ , hGetExactly+ , hGetExactlyAt+ , hPut+ , hPutAll+ ) where++import Control.Monad (foldM)+import Control.Monad.Class.MonadThrow (MonadThrow (throwIO))+import qualified Data.ByteString as BS+import Data.ByteString.Builder (Builder)+import qualified Data.ByteString.Builder as BS+import qualified Data.ByteString.Lazy as BL+import Data.Word (Word64)+import System.FS.API as API+import System.FS.API.Strict+import System.FS.CallStack (HasCallStack, prettyCallStack)++-- | Makes sure it reads all requested bytes.+-- If eof is found before all bytes are read, it throws an exception.+hGetExactly :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> Word64+ -> m BL.ByteString+hGetExactly hasFS h n = go n []+ where+ go :: Word64 -> [BS.ByteString] -> m BL.ByteString+ go remainingBytes acc+ | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc+ | otherwise = do+ bs <- hGetSome hasFS h remainingBytes+ if BS.null bs then+ throwIO FsError {+ fsErrorType = FsReachedEOF+ , fsErrorPath = mkFsErrorPath hasFS $ handlePath h+ , fsErrorString = "hGetExactly found eof before reading " ++ show n ++ " bytes"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ -- We know the length <= remainingBytes, so this can't underflow+ else go (remainingBytes - fromIntegral (BS.length bs)) (bs : acc)++-- | Like 'hGetExactly', but is thread safe since it does not change or depend+-- on the file offset. @pread@ syscall is used internally.+hGetExactlyAt :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> Word64 -- ^ The number of bytes to read.+ -> AbsOffset -- ^ The offset at which to read.+ -> m BL.ByteString+hGetExactlyAt hasFS h n offset = go n offset []+ where+ go :: Word64 -> AbsOffset -> [BS.ByteString] -> m BL.ByteString+ go remainingBytes currentOffset acc+ | remainingBytes == 0 = return $ BL.fromChunks $ reverse acc+ | otherwise = do+ bs <- hGetSomeAt hasFS h remainingBytes currentOffset+ let readBytes = BS.length bs+ if BS.null bs then+ throwIO FsError {+ fsErrorType = FsReachedEOF+ , fsErrorPath = mkFsErrorPath hasFS $ handlePath h+ , fsErrorString = "hGetExactlyAt found eof before reading " ++ show n ++ " bytes"+ , fsErrorNo = Nothing+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }+ -- We know the length <= remainingBytes, so this can't underflow.+ else go (remainingBytes - fromIntegral readBytes)+ (currentOffset + fromIntegral readBytes)+ (bs : acc)++-- | Read all the data from the given file handle 64kB at a time.+--+-- Stops when EOF is reached.+hGetAll :: Monad m => HasFS m h -> Handle h -> m BL.ByteString+hGetAll HasFS{..} hnd = go mempty+ where+ bufferSize = 64 * 1024+ go acc = do+ chunk <- hGetSome hnd bufferSize+ let acc' = chunk : acc+ if BS.null chunk+ then return $ BL.fromChunks $ reverse acc'+ else go acc'++-- | Like 'hGetAll', but is thread safe since it does not change or depend+-- on the file offset. @pread@ syscall is used internally.+hGetAllAt :: Monad m+ => HasFS m h+ -> Handle h+ -> AbsOffset -- ^ The offset at which to read.+ -> m BL.ByteString+hGetAllAt HasFS{..} hnd = go mempty+ where+ bufferSize = 64 * 1024+ go acc offset = do+ chunk <- hGetSomeAt hnd bufferSize offset+ let acc' = chunk : acc+ if BS.null chunk+ then return $ BL.fromChunks $ reverse acc'+ else go acc' (offset + fromIntegral (BS.length chunk))++-- | This function makes sure that the whole 'BL.ByteString' is written.+hPutAll :: forall m h+ . (HasCallStack, Monad m)+ => HasFS m h+ -> Handle h+ -> BL.ByteString+ -> m Word64+hPutAll hasFS h = foldM putChunk 0 . BL.toChunks+ where+ putChunk :: Word64 -> BS.ByteString -> m Word64+ putChunk written chunk = do+ written' <- hPutAllStrict hasFS h chunk+ return $! written + written'++-- | This function makes sure that the whole 'Builder' is written.+--+-- The chunk size of the resulting 'BL.ByteString' determines how much memory+-- will be used while writing to the handle.+hPut :: forall m h+ . (HasCallStack, Monad m)+ => HasFS m h+ -> Handle h+ -> Builder+ -> m Word64+hPut hasFS g = hPutAll hasFS g . BS.toLazyByteString
+ src/System/FS/API/Strict.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module System.FS.API.Strict (+ -- * API+ module API+ -- * Strict functions+ , hPutAllStrict+ ) where++import qualified Data.ByteString as BS+import Data.Word+import System.FS.API as API+import System.FS.CallStack++-- | This function makes sure that the whole 'BS.ByteString' is written.+hPutAllStrict :: forall m h+ . (HasCallStack, Monad m)+ => HasFS m h+ -> Handle h+ -> BS.ByteString+ -> m Word64+hPutAllStrict hasFS h = go 0+ where+ go :: Word64 -> BS.ByteString -> m Word64+ go !written bs = do+ n <- hPutSome hasFS h bs+ let bs' = BS.drop (fromIntegral n) bs+ written' = written + n+ if BS.null bs'+ then return written'+ else go written' bs'
+ src/System/FS/API/Types.hs view
@@ -0,0 +1,471 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- For Show Errno and Condense SeekMode instances+{-# OPTIONS_GHC -Wno-orphans #-}+module System.FS.API.Types (+ -- * Modes+ AllowExisting (..)+ , OpenMode (..)+ , SeekMode (..)+ , allowExisting+ -- * Paths+ , MountPoint (..)+ , fsFromFilePath+ , fsPathFromList+ , fsPathInit+ , fsPathSplit+ , fsPathToList+ , fsToFilePath+ , mkFsPath+ , (<.>)+ , addExtension+ , (</>)+ , combine+ -- ** opaque+ , FsPath+ -- * Handles+ , Handle (..)+ -- * Offset+ , AbsOffset (..)+ -- * Errors+ , FsError (..)+ , FsErrorPath (..)+ , FsErrorType (..)+ , fsToFsErrorPath+ , fsToFsErrorPathUnmounted+ , hasMountPoint+ , isFsErrorType+ , prettyFsError+ , sameFsError+ -- * From 'IOError' to 'FsError'+ , ioToFsError+ , ioToFsErrorType+ ) where++import Control.DeepSeq (NFData (..), force)+import Control.Exception+import Data.Function (on)+import Data.List (intercalate, stripPrefix)+import Data.Maybe (isJust)+import qualified Data.Text as Strict+import qualified Data.Text as Text+import Data.Word+import Foreign.C.Error (Errno (..))+import qualified Foreign.C.Error as C+import GHC.Generics (Generic)+import qualified GHC.IO.Exception as GHC+import GHC.Show (showCommaSpace)+import qualified System.FilePath as FilePath+import System.IO (SeekMode (..))+import qualified System.IO.Error as IO++import System.FS.CallStack+import System.FS.Condense++{-------------------------------------------------------------------------------+ Modes+-------------------------------------------------------------------------------}++-- | How to 'System.FS.API.hOpen' a new file.+data OpenMode+ = ReadMode+ | WriteMode AllowExisting+ | AppendMode AllowExisting+ | ReadWriteMode AllowExisting+ deriving (Eq, Show)++-- | When opening a file:+data AllowExisting+ = AllowExisting+ -- ^ The file may already exist. If it does, it is reopened. If it+ -- doesn't, it is created.+ | MustBeNew+ -- ^ The file may not yet exist. If it does, an error+ -- ('FsResourceAlreadyExist') is thrown.+ deriving (Eq, Show)++allowExisting :: OpenMode -> AllowExisting+allowExisting openMode = case openMode of+ ReadMode -> AllowExisting+ WriteMode ex -> ex+ AppendMode ex -> ex+ ReadWriteMode ex -> ex++{-------------------------------------------------------------------------------+ Paths+-------------------------------------------------------------------------------}++-- | A relative path.+--+-- === Invariant+--+-- The user of this library is tasked with picking sensible names of+-- directories/files on a path. Amongst others, the following should hold:+--+-- * Names are non-empty+--+-- * Names are monotonic, i.e., they are not equal to @..@+--+-- * Names should not contain path separators or drive letters+--+-- In particular, names that satisfy these invariants should result in an+-- 'FsPath' that remains relative to the HasFS instance root. For example, an+-- @'FsPath' ["/"]@ would try to access the root folder, which is most likely+-- outside of the scope of the HasFS instance.+--+-- \"@..@\" should not be used because @fs-sim@ will not be able to follow these+-- types of back-links. @fs-sim@ will interpret \"@..@\" as a directory name+-- instead.+newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] }+ deriving (Eq, Ord, Generic)+ deriving newtype NFData++-- | Create a path from a list of directory/file names. All of the names should+-- be non-empty.+fsPathFromList :: [Strict.Text] -> FsPath+fsPathFromList xs = UnsafeFsPath (force xs)++instance Show FsPath where+ show = intercalate "/" . map Strict.unpack . fsPathToList++instance Condense FsPath where+ condense = show++-- | Constructor for 'FsPath' ensures path is in normal form+mkFsPath :: [String] -> FsPath+mkFsPath = fsPathFromList . map Strict.pack++-- | Split 'FsPath' is essentially @(init fp, last fp)@+--+-- Like @init@ and @last@, 'Nothing' if empty.+fsPathSplit :: FsPath -> Maybe (FsPath, Strict.Text)+fsPathSplit fp =+ case reverse (fsPathToList fp) of+ [] -> Nothing+ p:ps -> Just (fsPathFromList (reverse ps), p)++-- | Drop the final component of the path+--+-- Undefined if the path is empty.+fsPathInit :: HasCallStack => FsPath -> FsPath+fsPathInit fp = case fsPathSplit fp of+ Nothing -> error $ "fsPathInit: empty path"+ Just (fp', _) -> fp'++-- | An alias for '<.>'.+addExtension :: FsPath -> String -> FsPath+addExtension = (<.>)++infixr 7 <.>+-- | Add an extension, even if there is already one there.+--+-- This works similarly to 'Filepath.<.>'.+(<.>) :: FsPath -> String -> FsPath+path <.> [] = path+path <.> ext = case fsPathSplit path of+ Nothing -> mkFsPath [ext']+ Just (dir, file) -> dir </> UnsafeFsPath [file `Text.append` Text.pack ext']+ where+ ext' = case ext of+ '.':_ -> ext+ _ -> '.':ext++-- | An alias for '</>'.+combine :: FsPath -> FsPath -> FsPath+combine = (</>)++infixr 5 </>+-- | Combine two paths with a path separator.+--+-- This works similarly to 'Filepath.</>', but since the arguments are+-- relative paths, the corner cases for 'FilePath.</>' do not apply.+-- Specifically, the second path will never start with a path separator or a+-- drive letter, so the result is simply the concatenation of the two paths.+--+-- If either operand is empty, the other operand is returned. The result of+-- combining two empty paths is the empty path+(</>) :: FsPath -> FsPath -> FsPath+UnsafeFsPath x </> UnsafeFsPath y = case (x, y) of+ ([], _) -> UnsafeFsPath y+ (_, []) -> UnsafeFsPath x+ _ -> fsPathFromList (x ++ y)++-- | Mount point+--+-- 'FsPath's are not absolute paths, but must be interpreted with respect to+-- a particualar mount point.+newtype MountPoint = MountPoint FilePath++fsToFilePath :: MountPoint -> FsPath -> FilePath+fsToFilePath (MountPoint mp) fp =+ mp FilePath.</> foldr (FilePath.</>) "" (map Strict.unpack $ fsPathToList fp)++fsFromFilePath :: MountPoint -> FilePath -> Maybe FsPath+fsFromFilePath (MountPoint mp) path = mkFsPath <$>+ stripPrefix (FilePath.splitDirectories mp) (FilePath.splitDirectories path)++-- | For better error reporting to the end user, we want to include the+-- mount point of the file. But the mountpoint may not always be available,+-- like when we mock the fs or we simulate fs errors.+data FsErrorPath = FsErrorPath (Maybe MountPoint) FsPath++fsToFsErrorPath :: MountPoint -> FsPath -> FsErrorPath+fsToFsErrorPath mp = FsErrorPath (Just mp)++-- | Like 'fsToFsErrorPath', but when we don't have a 'MountPoint'+fsToFsErrorPathUnmounted :: FsPath -> FsErrorPath+fsToFsErrorPathUnmounted = FsErrorPath Nothing++instance Show FsErrorPath where+ show (FsErrorPath (Just mp) fp) = fsToFilePath mp fp+ show (FsErrorPath Nothing fp) = show fp++instance Condense FsErrorPath where+ condense = show++-- | We only care to compare the 'FsPath', because the 'MountPoint' may not+-- exist.+instance Eq FsErrorPath where+ (FsErrorPath _ fp1) == (FsErrorPath _ fp2) = fp1 == fp2++{-------------------------------------------------------------------------------+ Handles+-------------------------------------------------------------------------------}++data Handle h = Handle {+ -- | The raw underlying handle+ handleRaw :: !h++ -- | The path corresponding to this handle+ --+ -- This is primarily useful for error reporting.+ , handlePath :: !FsPath+ }+ deriving (Generic)++instance NFData h => NFData (Handle h) where+ rnf (Handle handleRaw handlePath) = rnf handleRaw `seq` rnf handlePath++instance Eq h => Eq (Handle h) where+ (==) = (==) `on` handleRaw++instance Show (Handle h) where+ show (Handle _ fp) = "<Handle " ++ fsToFilePath (MountPoint "<root>") fp ++ ">"+++{-------------------------------------------------------------------------------+ Offset wrappers+-------------------------------------------------------------------------------}++newtype AbsOffset = AbsOffset { unAbsOffset :: Word64 }+ deriving (Eq, Ord, Enum, Bounded, Num, Show)++{-------------------------------------------------------------------------------+ Errors+-------------------------------------------------------------------------------}++data FsError = FsError {+ -- | Error type+ fsErrorType :: FsErrorType++ -- | Path to the file+ , fsErrorPath :: FsErrorPath++ -- | Human-readable string giving additional information about the error+ , fsErrorString :: String++ -- | The 'Errno', if available. This is more precise than the+ -- 'FsErrorType'.+ , fsErrorNo :: Maybe Errno++ -- | Call stack+ , fsErrorStack :: PrettyCallStack++ -- | Is this error due to a limitation of the mock file system?+ --+ -- The mock file system does not all of Posix's features and quirks.+ -- This flag will be set for such unsupported IO calls. Real I/O calls+ -- would not have thrown an error for these calls.+ , fsLimitation :: Bool+ }++-- This is a custom instance and not an auto-derive one, since 'Errno' does not+-- have a 'Show' instance, and we don't want to provide an orphan instance for+-- this @base@ type.+instance Show FsError where+ showsPrec n fserr = showParen (n >= 11) $+ showString "FsError {"+ . showString "fsErrorType = " . shows fsErrorType . showCommaSpace+ . showString "fsErrorPath = " . shows fsErrorPath . showCommaSpace+ . showString "fsErrorString = " . shows fsErrorString . showCommaSpace+ . showString "fsErrorNo = " . showsFsErrNo fsErrorNo . showCommaSpace+ . showString "fsErrorStack = " . shows fsErrorStack . showCommaSpace+ . showString "fsLimitation = " . shows fsLimitation+ . showString "}"+ where+ -- Quite a bit of boilerplate, but it should ensure that we won't silently+ -- change/forget to change the Show instance when fields are+ -- changed/re-ordered/added.+ FsError {+ fsErrorType = fsErrorType :: FsErrorType+ , fsErrorPath = fsErrorPath :: FsErrorPath+ , fsErrorString = fsErrorString :: String+ , fsErrorNo = fsErrorNo :: Maybe Errno+ , fsErrorStack = fsErrorStack :: PrettyCallStack+ , fsLimitation = fsLimitation :: Bool+ } = fserr+ _coveredAllCases = case fserr of+ FsError (_ :: FsErrorType) (_ :: FsErrorPath) (_ :: String)+ (_ :: Maybe Errno) (_ :: PrettyCallStack) (_ :: Bool) -> ()++ showsFsErrNo Nothing = showString "Nothing"+ showsFsErrNo (Just (Errno e)) = showString "Just "+ . showParen True (showString "Errno " . shows e)++data FsErrorType+ = FsIllegalOperation+ | FsResourceInappropriateType+ -- ^ e.g the user tried to open a directory with hOpen rather than a file.+ | FsResourceAlreadyInUse+ | FsResourceDoesNotExist+ | FsResourceAlreadyExist+ | FsReachedEOF+ | FsDeviceFull+ | FsTooManyOpenFiles+ | FsInsufficientPermissions+ | FsInvalidArgument+ | FsOther+ -- ^ Used for all other error types+ deriving (Show, Eq)++instance Exception FsError where+ displayException = prettyFsError++-- | Check if two errors are semantically the same error+--+-- This ignores the error string, the errno, and the callstack.+sameFsError :: FsError -> FsError -> Bool+sameFsError e e' = fsErrorType e == fsErrorType e'+ && fsErrorPath e == fsErrorPath e'++isFsErrorType :: FsErrorType -> FsError -> Bool+isFsErrorType ty e = fsErrorType e == ty++prettyFsError :: FsError -> String+prettyFsError FsError{..} = concat [+ show fsErrorType+ , " for "+ , show fsErrorPath+ , ": "+ , fsErrorString+ , " at "+ , show fsErrorStack+ ]++hasMountPoint :: FsError -> Bool+hasMountPoint FsError{fsErrorPath = FsErrorPath mp _} = isJust mp++{-------------------------------------------------------------------------------+ From 'IOError' to 'FsError'+-------------------------------------------------------------------------------}++-- | Translate exceptions thrown by IO functions to 'FsError'+--+-- We take the 'FsPath' as an argument. We could try to translate back from a+-- 'FilePath' to an 'FsPath' (given a 'MountPoint'), but we know the 'FsPath'+-- at all times anyway and not all IO exceptions actually include a filepath.+ioToFsError :: HasCallStack+ => FsErrorPath -> IOError -> FsError+ioToFsError fep ioErr = FsError+ { fsErrorType = ioToFsErrorType ioErr+ , fsErrorPath = fep+ -- We don't use 'ioeGetErrorString', because that only returns the+ -- description in case 'isUserErrorType' is true, otherwise it will+ -- return 'ioToFsErrorType', which we already include in 'fsErrorType'.+ -- So we use the underlying field directly.+ , fsErrorString = GHC.ioe_description ioErr+ , fsErrorNo = Errno <$> GHC.ioe_errno ioErr+ , fsErrorStack = prettyCallStack+ , fsLimitation = False+ }++-- | Assign an 'FsErrorType' to the given 'IOError'.+--+-- Note that we don't always use the classification made by+-- 'Foreign.C.Error.errnoToIOError' (also see 'System.IO.Error') because it+-- combines some errors into one 'IO.IOErrorType', e.g., @EMFILE@ (too many open+-- files) and @ENOSPC@ (no space left on device) both result in+-- 'ResourceExhausted' while we want to keep them separate. For this reason,+-- we do a classification of our own based on the @errno@ while sometimes+-- deferring to the existing classification.+--+-- See the ERRNO(3) man page for the meaning of the different errnos.+ioToFsErrorType :: IOError -> FsErrorType+ioToFsErrorType ioErr = case Errno <$> GHC.ioe_errno ioErr of+ Just errno+ | errno == C.eACCES+ || errno == C.eROFS+ || errno == C.ePERM+ -> FsInsufficientPermissions++ | errno == C.eNOSPC+ -> FsDeviceFull++ | errno == C.eMFILE+ || errno == C.eNFILE+ -> FsTooManyOpenFiles++ | errno == C.eNOENT+ || errno == C.eNXIO+ -> FsResourceDoesNotExist++ _ | IO.isAlreadyInUseErrorType eType+ -> FsResourceAlreadyInUse++ | IO.isAlreadyExistsErrorType eType+ -> FsResourceAlreadyExist++ | IO.isEOFErrorType eType+ -> FsReachedEOF++ | IO.isIllegalOperationErrorType eType+ -> FsIllegalOperation++ | eType == GHC.InappropriateType+ -> FsResourceInappropriateType++ | eType == GHC.InvalidArgument+ -> FsInvalidArgument++ | otherwise+ -> FsOther+ where+ eType :: IO.IOErrorType+ eType = IO.ioeGetErrorType ioErr++{-------------------------------------------------------------------------------+ Condense instances+-------------------------------------------------------------------------------}++instance Condense SeekMode where+ condense RelativeSeek = "r"+ condense AbsoluteSeek = "a"+ condense SeekFromEnd = "e"++instance Condense AllowExisting where+ condense AllowExisting = ""+ condense MustBeNew = "!"++instance Condense OpenMode where+ condense ReadMode = "r"+ condense (WriteMode ex) = "w" ++ condense ex+ condense (ReadWriteMode ex) = "rw" ++ condense ex+ condense (AppendMode ex) = "a" ++ condense ex++instance Condense (Handle h) where+ condense = show
+ src/System/FS/CRC.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Support for CRC+module System.FS.CRC (+ -- * Wrap digest functionality+ CRC (..)+ , computeCRC+ , initCRC+ , updateCRC+ -- * File system functions with CRC functionality+ , hGetAllAtCRC+ , hGetExactlyAtCRC+ , hPutAllCRC+ ) where++import Control.Monad (foldM)+import Control.Monad.Class.MonadThrow+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Coerce+import qualified Data.Digest.CRC32 as Digest+import Data.Word+import Foreign.Storable (Storable)+import GHC.Generics (Generic)+import GHC.Stack+import System.FS.API.Lazy+import System.FS.API.Strict++{-------------------------------------------------------------------------------+ Wrap functionality from digest+-------------------------------------------------------------------------------}++newtype CRC = CRC { getCRC :: Word32 }+ deriving (Eq, Show, Generic, Storable)++initCRC :: CRC+initCRC = CRC $ Digest.crc32 ([] :: [Word8])++updateCRC :: forall a. Digest.CRC32 a => a -> CRC -> CRC+updateCRC = coerce (flip (Digest.crc32Update :: Word32 -> a -> Word32))++computeCRC :: forall a. Digest.CRC32 a => a -> CRC+computeCRC = coerce (Digest.crc32 :: a -> Word32)++{-------------------------------------------------------------------------------+ File system functions that compute CRCs+-------------------------------------------------------------------------------}++-- | Variation on 'hPutAll' that also computes a CRC+hPutAllCRC :: forall m h. (HasCallStack, Monad m)+ => HasFS m h+ -> Handle h+ -> BL.ByteString+ -> m (Word64, CRC)+hPutAllCRC hasFS h = foldM putChunk (0, initCRC) . BL.toChunks+ where+ putChunk :: (Word64, CRC) -> BS.ByteString -> m (Word64, CRC)+ putChunk (written, crc) chunk = do+ chunkSize <- hPutAllStrict hasFS h chunk+ let !written' = written + chunkSize+ !crc' = updateCRC chunk crc+ return (written', crc')++-- | Variation on 'hGetExactlyAt' that also computes a CRC+hGetExactlyAtCRC :: forall m h. (HasCallStack, MonadThrow m)+ => HasFS m h+ -> Handle h+ -> Word64 -- ^ The number of bytes to read.+ -> AbsOffset -- ^ The offset at which to read.+ -> m (BL.ByteString, CRC)+hGetExactlyAtCRC hasFS h n offset = do+ -- TODO Interleave reading with computing the CRC. Better cache locality+ -- and fits better with incremental parsing, when we add support for that.+ bs <- hGetExactlyAt hasFS h n offset+ let !crc = computeCRC bs+ return (bs, crc)++-- | Variation on 'hGetAllAt' that also computes a CRC+hGetAllAtCRC :: forall m h. Monad m+ => HasFS m h+ -> Handle h+ -> AbsOffset -- ^ The offset at which to read.+ -> m (BL.ByteString, CRC)+hGetAllAtCRC hasFS h offset = do+ -- TODO Interleave reading with computing the CRC. Better cache locality+ -- and fits better with incremental parsing, when we add support for that.+ bs <- hGetAllAt hasFS h offset+ let !crc = computeCRC bs+ return (bs, crc)
+ src/System/FS/CallStack.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | CallStack with a nicer 'Show' instance+--+-- Use of this module is intended to /replace/ import of @GHC.Stack@+module System.FS.CallStack (+ prettyCallStack+ -- * opaque+ , PrettyCallStack+ -- * Re-exports+ , HasCallStack+ ) where++import GHC.Stack (CallStack, HasCallStack)+import qualified GHC.Stack as GHC++{-------------------------------------------------------------------------------+ Auxiliary: CallStack with different Show instance+-------------------------------------------------------------------------------}++-- | CallStack with 'Show' instance using 'prettyCallStack'+newtype PrettyCallStack = PrettyCallStack CallStack++instance Show PrettyCallStack where+ show (PrettyCallStack cs) = GHC.prettyCallStack cs++prettyCallStack :: HasCallStack => PrettyCallStack+prettyCallStack = PrettyCallStack GHC.callStack
+ src/System/FS/Condense.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Condensed but human-readable output (like 'Show').+module System.FS.Condense (+ Condense (..)+ , Condense1 (..)+ , condense1+ ) where++import qualified Data.ByteString as BS.Strict+import qualified Data.ByteString.Lazy as BS.Lazy+import Data.Int+import Data.List (intercalate)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text, unpack)+import Data.Void+import Data.Word+import Numeric.Natural+import Text.Printf (printf)++{-------------------------------------------------------------------------------+ Main class+-------------------------------------------------------------------------------}++-- | Condensed but human-readable output+class Condense a where+ condense :: a -> String++{-------------------------------------------------------------------------------+ Rank-1 types+-------------------------------------------------------------------------------}++class Condense1 f where+ liftCondense :: (a -> String) -> f a -> String++-- | Lift the standard 'condense' function through the type constructor+condense1 :: (Condense1 f, Condense a) => f a -> String+condense1 = liftCondense condense++{-------------------------------------------------------------------------------+ Default instances for deriving-via+-------------------------------------------------------------------------------}++newtype CondenseAsShow a = CondenseAsShow {getCondenseAsShow :: a}+ deriving Show++instance Show a => Condense (CondenseAsShow a) where+ condense = show++{-------------------------------------------------------------------------------+ Instances for standard types+-------------------------------------------------------------------------------}++instance Condense Void where+ condense = absurd++instance Condense Text where+ condense = unpack++deriving via CondenseAsShow Bool instance Condense Bool+deriving via CondenseAsShow Int instance Condense Int+deriving via CondenseAsShow Int64 instance Condense Int64+deriving via CondenseAsShow Word instance Condense Word+deriving via CondenseAsShow Word32 instance Condense Word32+deriving via CondenseAsShow Word64 instance Condense Word64+deriving via CondenseAsShow Natural instance Condense Natural++instance Condense Rational where+ condense = printf "%.8f" . (fromRational :: Rational -> Double)++instance Condense1 [] where+ liftCondense f as = "[" ++ intercalate "," (map f as) ++ "]"++instance Condense1 Set where+ liftCondense f = liftCondense f . Set.toList++instance Condense a => Condense [a] where+ condense = condense1++instance Condense a => Condense (Maybe a) where+ condense (Just a) = "Just " ++ condense a+ condense Nothing = "Nothing"++instance Condense a => Condense (Set a) where+ condense = condense1++instance (Condense a, Condense b) => Condense (a, b) where+ condense (a, b) = "(" ++ intercalate "," [condense a, condense b] ++ ")"++instance (Condense a, Condense b, Condense c) => Condense (a, b, c) where+ condense (a, b, c) = "(" ++ intercalate "," [condense a, condense b, condense c] ++ ")"++instance (Condense a, Condense b, Condense c, Condense d) => Condense (a, b, c, d) where+ condense (a, b, c, d) = "(" ++ intercalate "," [condense a, condense b, condense c, condense d] ++ ")"++instance (Condense a, Condense b, Condense c, Condense d, Condense e) => Condense (a, b, c, d, e) where+ condense (a, b, c, d, e) = "(" ++ intercalate "," [condense a, condense b, condense c, condense d, condense e] ++ ")"++instance (Condense k, Condense a) => Condense (Map k a) where+ condense = condense . Map.toList++instance Condense BS.Strict.ByteString where+ condense bs = show bs ++ "<" ++ show (BS.Strict.length bs) ++ "b>"++instance Condense BS.Lazy.ByteString where+ condense bs = show bs ++ "<" ++ show (BS.Lazy.length bs) ++ "b>"
+ src/System/FS/IO.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- | 'IO' implementation of the 'HasFS' interface.+module System.FS.IO (+ HandleIO+ , ioHasFS+ ) where++import Control.Concurrent.MVar+import qualified Control.Exception as E+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Primitive (PrimMonad (..))+import qualified Data.ByteString.Unsafe as BS+import Data.Primitive (withMutableByteArrayContents)+import qualified Data.Set as Set+import qualified Foreign+import GHC.Stack+import qualified System.Directory as Dir+import System.FS.API+#if defined(mingw32_HOST_OS)+import qualified System.FS.IO.Windows as F+#else+-- treat every other distribution like it is (Ubuntu) Linux+import qualified System.FS.IO.Unix as F+#endif+import qualified System.FS.IO.Handle as H++{-------------------------------------------------------------------------------+ I/O implementation of HasFS+-------------------------------------------------------------------------------}++-- | File handlers for the IO instance for HasFS+--+-- We store the path the handle points to for better error messages+type HandleIO = F.FHandle++-- | 'IO' implementation of the 'HasFS' interface using the /real/ file system.+--+-- The concrete implementation depends on the OS distribution, but behaviour+-- should be similar across distributions.+ioHasFS :: (MonadIO m, PrimState IO ~ PrimState m) => MountPoint -> HasFS m HandleIO+ioHasFS mount = HasFS {+ -- TODO(adn) Might be useful to implement this properly by reading all+ -- the stuff available at the 'MountPoint'.+ dumpState = return "<dumpState@IO>"+ , hOpen = \fp openMode -> liftIO $ do+ let path = root fp+ osHandle <- rethrowFsError fp $+ F.open path openMode+ hVar <- newMVar $ Just osHandle+ return $ Handle (H.HandleOS path hVar) fp+ , hClose = \(Handle h fp) -> liftIO $ rethrowFsError fp $+ F.close h+ , hIsOpen = liftIO . H.isOpenHandleOS . handleRaw+ , hSeek = \(Handle h fp) mode o -> liftIO $ rethrowFsError fp $+ F.seek h mode o+ , hGetSome = \(Handle h fp) n -> liftIO $ rethrowFsError fp $+ F.read h n+ , hGetSomeAt = \(Handle h fp) n o -> liftIO $ rethrowFsError fp $+ F.pread h n (unAbsOffset o)+ , hTruncate = \(Handle h fp) sz -> liftIO $ rethrowFsError fp $+ F.truncate h sz+ , hGetSize = \(Handle h fp) -> liftIO $ rethrowFsError fp $+ F.getSize h+ , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do+ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->+ fromIntegral <$> F.write h (Foreign.castPtr ptr) (fromIntegral len)+ , createDirectory = \fp -> liftIO $ rethrowFsError fp $+ Dir.createDirectory (root fp)+ , listDirectory = \fp -> liftIO $ rethrowFsError fp $+ Set.fromList <$> Dir.listDirectory (root fp)+ , doesDirectoryExist= \fp -> liftIO $ rethrowFsError fp $+ Dir.doesDirectoryExist (root fp)+ , doesFileExist = \fp -> liftIO $ rethrowFsError fp $+ Dir.doesFileExist (root fp)+ , createDirectoryIfMissing = \createParent fp -> liftIO $ rethrowFsError fp $+ Dir.createDirectoryIfMissing createParent (root fp)+ , removeDirectoryRecursive = \fp -> liftIO $ rethrowFsError fp $+ Dir.removeDirectoryRecursive (root fp)+ , removeFile = \fp -> liftIO $ rethrowFsError fp $+ Dir.removeFile (root fp)+ , renameFile = \fp1 fp2 -> liftIO $ rethrowFsError fp1 $+ Dir.renameFile (root fp1) (root fp2)+ , mkFsErrorPath = fsToFsErrorPath mount+ , unsafeToFilePath = pure . root+ , hGetBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $+ withMutableByteArrayContents buf $ \ptr ->+ F.readBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c+ , hGetBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $+ withMutableByteArrayContents buf $ \ptr ->+ F.preadBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)+ , hPutBufSome = \(Handle h fp) buf bufOff c -> liftIO $ rethrowFsError fp $+ withMutableByteArrayContents buf $ \ptr ->+ F.writeBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c+ , hPutBufSomeAt = \(Handle h fp) buf bufOff c off -> liftIO $ rethrowFsError fp $+ withMutableByteArrayContents buf $ \ptr ->+ F.pwriteBuf h (ptr `Foreign.plusPtr` unBufferOffset bufOff) c (fromIntegral $ unAbsOffset off)+ }+ where+ root :: FsPath -> FilePath+ root = fsToFilePath mount++ rethrowFsError :: HasCallStack => FsPath -> IO a -> IO a+ rethrowFsError fp action = do+ res <- E.try action+ case res of+ Left err -> handleError err+ Right a -> return a+ where+ handleError :: HasCallStack => IOError -> IO a+ handleError ioErr = E.throwIO $ ioToFsError errorPath ioErr++ errorPath :: FsErrorPath+ errorPath = fsToFsErrorPath mount fp
+ src/System/FS/IO/Handle.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE LambdaCase #-}++-- | This module is mainly meant to be used for the 'IO' implementation of+-- 'System.FS.API.HasFS'.+module System.FS.IO.Handle (+ HandleOS (..)+ , closeHandleOS+ , isHandleClosedException+ , isOpenHandleOS+ , withOpenHandle+ ) where++import Control.Concurrent.MVar+import Control.Exception hiding (handle)+import Data.Maybe (isJust)+import System.IO.Error as IO++-- | File handlers for the IO instance for HasFS.+-- This is parametric on the os.+--+-- The 'FilePath' is used to improve error messages.+-- The 'MVar' is used to implement 'close'.+-- osHandle is Fd for unix and HANDLE for Windows.+data HandleOS osHandle = HandleOS {+ filePath :: FilePath+ , handle :: MVar (Maybe osHandle)+ }++instance Eq (HandleOS a) where+ h1 == h2 = handle h1 == handle h2++instance Show (HandleOS a) where+ show h = "<Handle " ++ filePath h ++ ">"++isOpenHandleOS :: HandleOS osHandle -> IO Bool+isOpenHandleOS = fmap isJust . readMVar . handle++-- | This is a no-op when the handle is already closed.+closeHandleOS :: HandleOS osHandle -> (osHandle -> IO ()) -> IO ()+closeHandleOS (HandleOS _ hVar) close =+ modifyMVar hVar $ \case+ Nothing -> return (Nothing, ())+ Just h -> close h >> return (Nothing, ())++{-------------------------------------------------------------------------------+ Exceptions+-------------------------------------------------------------------------------}++-- | This is meant to be used for the implementation of individual file system commands.+-- Using it for larger scopes woud not be correct, since we would not notice if the+-- handle is closed.+withOpenHandle :: String -> HandleOS osHandle -> (osHandle -> IO a) -> IO a+withOpenHandle label (HandleOS fp hVar) k =+ withMVar hVar $ \case+ Nothing -> throwIO (handleClosedException fp label)+ Just fd -> k fd++handleClosedException :: FilePath -> String -> IOException+handleClosedException fp label =+ flip IO.ioeSetErrorType IO.illegalOperationErrorType+ $ flip IO.ioeSetFileName fp+ $ userError (label ++ ": FHandle closed")++{-------------------------------------------------------------------------------+ Internal auxiliary+-------------------------------------------------------------------------------}++isHandleClosedException :: IOException -> Bool+isHandleClosedException ioErr =+ IO.isUserErrorType (IO.ioeGetErrorType ioErr)
+ test/Main.hs view
@@ -0,0 +1,11 @@+module Main (main) where++import qualified Test.System.FS.API.FsPath+import qualified Test.System.FS.IO+import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "fs-api-test" [+ Test.System.FS.API.FsPath.tests+ , Test.System.FS.IO.tests+ ]
+ test/Test/System/FS/API/FsPath.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.System.FS.API.FsPath (tests) where++import Data.Text (Text)+import qualified Data.Text as Text+import Prelude hiding (read)+import qualified System.FilePath as FilePath+import qualified System.FS.API as FS+import Test.Tasty+import qualified Test.Tasty.QuickCheck as QC+import Test.Tasty.QuickCheck++tests :: TestTree+tests = testGroup "Test.System.FS.API.FsPath" [+ testProperty "prop_combineCommutes" prop_combineCommutes+ , testProperty "prop_addExtensionCommutes" prop_addExtensionCommutes+ ]++-- | Orphan instance that generates a __non-empty__ text!+instance Arbitrary Text where+ arbitrary = Text.pack <$> QC.listOf (QC.elements validChars) `suchThat` (not . null)+ shrink x = [ x''' | let x' = Text.unpack x+ , x'' <- shrink x'+ , not (null x'')+ , let x''' = Text.pack x'' ]++-- | We pick a small subset of characters to use in directory/file names, so+-- that we don't break the invariant of 'FsPath'.+validChars :: [Char]+validChars = concat [['a'..'z'], ['A'..'Z'], ['0'..'9']]++-- | Commutativity property for 'FS.</>' and 'FilePath.</>'.+--+-- TODO: commutativity might not be the right name for this type of property.+--+-- @+-- \x y -> toFilePath (x </> y) == toFilePath x </> toFilePath y+-- @+--+-- The first argument is used to create a mount point, which makes the property+-- more useful because we are testing more cases. Also, for 'FS.fsToFilePath' to+-- work, we need at least the empty mountpoint.+prop_combineCommutes :: [Text] -> [Text] -> [Text] -> Property+prop_combineCommutes mnt path1 path2 =+ QC.classify (FilePath.isValid rhs) "Valid file path"+ $ lhs === rhs+ .&&. FilePath.makeValid lhs === FilePath.makeValid rhs+ where+ mnt' = filePathFromList mnt+ mnt'' = FS.MountPoint mnt'+ fsp = FS.fsPathFromList path1 FS.</> FS.fsPathFromList path2+ lhs = FS.fsToFilePath mnt'' fsp+ rhs = mnt' FilePath.</> filePathFromList path1 FilePath.</> filePathFromList path2++-- | Commutativity property for 'FS.<.>' and 'FilePath.<.>'.+--+-- TODO: commutativity might not be the right name for this type of property.+--+-- @+-- \path ext -> toFilePath (path <.> ext) == toFilePath path <.> ext+-- @+--+-- The first argument is used to create a mount point, which makes the property+-- more useful because we are testing more cases. Also, for 'FS.fsToFilePath' to+-- work, we need at least the empty mountpoint.+prop_addExtensionCommutes :: [Text] -> [Text] -> String -> Property+prop_addExtensionCommutes mnt path ext =+ QC.classify (FilePath.isValid rhs) "Valid file path"+ $ QC.classify (case ext of '.':_ -> True; _ -> False)+ "Extension to add starts with an extension separator (.)"+ $ lhs === rhs+ .&&. FilePath.makeValid lhs === FilePath.makeValid rhs+ where+ mnt' = filePathFromList mnt+ mnt'' = FS.MountPoint mnt'+ fsp = FS.fsPathFromList path FS.<.> ext+ lhs = FS.fsToFilePath mnt'' fsp+ rhs = mnt' FilePath.</> filePathFromList path FilePath.<.> ext++-- | Build a 'FilePath' by 'FilePath.combine'ing the directory/file names.+filePathFromList :: [Text] -> FilePath+filePathFromList [] = []+filePathFromList xs = foldr (\y ys -> Text.unpack y FilePath.</> ys) (Text.unpack (last xs)) (init xs)
+ test/Test/System/FS/IO.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Test.System.FS.IO (tests) where++import Control.Monad.Primitive+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short.Internal as SBS+import Data.Primitive.ByteArray+import Prelude hiding (read)+import qualified System.FS.API as FS+import qualified System.FS.IO as IO+import System.IO.Temp+import System.Posix.Types (ByteCount)+import Test.Tasty+import Test.Tasty.QuickCheck++tests :: TestTree+tests = testGroup "Test.System.FS.IO" [+ testProperty "prop_roundtrip_hPutGetBufSome"+ prop_roundtrip_hPutGetBufSome+ , testProperty "prop_roundtrip_hPutGetBufSomeAt"+ prop_roundtrip_hPutGetBufSomeAt+ , testProperty "prop_roundtrip_hPutGetBufExactly"+ prop_roundtrip_hPutGetBufExactly+ , testProperty "prop_roundtrip_hPutGetBufExactlyAt"+ prop_roundtrip_hPutGetBufExactlyAt+ ]++instance Arbitrary ByteString where+ arbitrary = BS.pack <$> arbitrary+ shrink = fmap BS.pack . shrink . BS.unpack++instance Arbitrary FS.AbsOffset where+ arbitrary = FS.AbsOffset . getSmall <$> arbitrary+ shrink (FS.AbsOffset x) = FS.AbsOffset <$> shrink x++fromByteString :: PrimMonad m => ByteString -> m (MutableByteArray (PrimState m))+fromByteString bs = thawByteArray (ByteArray ba) 0 (SBS.length sbs)+ where !sbs@(SBS.SBS ba) = SBS.toShort bs++toByteString :: PrimMonad m => Int -> MutableByteArray (PrimState m) -> m ByteString+toByteString n mba = freezeByteArray mba 0 n >>= \(ByteArray ba) -> pure (SBS.fromShort $ SBS.SBS ba)++-- | A write-then-read roundtrip test for buffered I\/O in 'IO'.+--+-- This does not test what happens if we try to write/read more bytes than fits+-- in the buffer, because the behaviour is then undefined.+prop_roundtrip_hPutGetBufSome ::+ ByteString+ -> Small ByteCount -- ^ Prefix length+ -> Property+prop_roundtrip_hPutGetBufSome bs (Small c) =+ BS.length bs >= fromIntegral c ==>+ ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSome" $ \dirPath -> do+ let hfs = IO.ioHasFS (FS.MountPoint dirPath)++ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ putBuf <- fromByteString bs+ m <- FS.hPutBufSome hfs h putBuf 0 c+ let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c)+ FS.hSeek hfs h FS.AbsoluteSeek 0+ getBuf <- newPinnedByteArray (fromIntegral m)+ o <- FS.hGetBufSome hfs h getBuf 0 m+ let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m)+ bs' <- toByteString (fromIntegral o) getBuf+ let cmpTest = counterexample "(prefix of) input and output bytestring do not match"+ $ BS.take (fromIntegral o) bs === bs'+ pure (writeTest .&&. readTest .&&. cmpTest)++-- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a specified offset.+prop_roundtrip_hPutGetBufSomeAt ::+ ByteString+ -> Small ByteCount -- ^ Prefix length+ -> FS.AbsOffset+ -> Property+prop_roundtrip_hPutGetBufSomeAt bs (Small c) off =+ BS.length bs >= fromIntegral c ==>+ ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufSomeAt" $ \dirPath -> do+ let hfs = IO.ioHasFS (FS.MountPoint dirPath)++ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ putBuf <- fromByteString bs+ m <- FS.hPutBufSomeAt hfs h putBuf 0 c off+ let writeTest = counterexample "wrote too many bytes" ((if c > 0 then 1 .<= m else property True) .&&. m .<= c)+ getBuf <- newPinnedByteArray (fromIntegral m)+ o <- FS.hGetBufSomeAt hfs h getBuf 0 m off+ let readTest = counterexample "read too many bytes" ((if c > 0 then 1 .<= o else property True) .&&. o .<= m)+ bs' <- toByteString (fromIntegral o) getBuf+ let cmpTest = counterexample "(prefix of) input and output bytestring do not match"+ $ BS.take (fromIntegral o) bs === bs'+ pure (writeTest .&&. readTest .&&. cmpTest)++-- | Like 'prop_roundtrip_hPutGetBufSome', but ensuring that all bytes are+-- written/read.+prop_roundtrip_hPutGetBufExactly ::+ ByteString+ -> Small ByteCount -- ^ Prefix length+ -> Property+prop_roundtrip_hPutGetBufExactly bs (Small c) =+ BS.length bs >= fromIntegral c ==>+ ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactly" $ \dirPath -> do+ let hfs = IO.ioHasFS (FS.MountPoint dirPath)++ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ putBuf <- fromByteString bs+ m <- FS.hPutBufExactly hfs h putBuf 0 c+ let writeTest = counterexample "wrote too few bytes" (m === c)+ FS.hSeek hfs h FS.AbsoluteSeek 0+ getBuf <- newPinnedByteArray (fromIntegral c)+ o <- FS.hGetBufExactly hfs h getBuf 0 c+ let readTest = counterexample "read too few byes" (o === c)+ bs' <- toByteString (fromIntegral c) getBuf+ let cmpTest = counterexample "input and output bytestring do not match"+ $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs'+ pure (writeTest .&&. readTest .&&. cmpTest)++-- | Like 'prop_roundtrip_hPutGetBufSome', but reading and writing at a+-- specified offset, and ensuring that all bytes are written/read.+prop_roundtrip_hPutGetBufExactlyAt ::+ ByteString+ -> Small ByteCount -- ^ Prefix length+ -> FS.AbsOffset+ -> Property+prop_roundtrip_hPutGetBufExactlyAt bs (Small c) off =+ BS.length bs >= fromIntegral c ==>+ ioProperty $ withSystemTempDirectory "prop_roundtrip_hPutGetBufExactlyAt" $ \dirPath -> do+ let hfs = IO.ioHasFS (FS.MountPoint dirPath)++ FS.withFile hfs (FS.mkFsPath ["temp"]) (FS.WriteMode FS.MustBeNew) $ \h -> do+ putBuf <- fromByteString bs+ m <- FS.hPutBufExactlyAt hfs h putBuf 0 c off+ let writeTest = counterexample "wrote too few bytes" (m === c)+ getBuf <- newPinnedByteArray (fromIntegral c)+ o <- FS.hGetBufExactlyAt hfs h getBuf 0 c off+ let readTest = counterexample "read too few byes" (o === c)+ bs' <- toByteString (fromIntegral c) getBuf+ let cmpTest = counterexample "input and output bytestring do not match"+ $ BS.take (fromIntegral c) bs === BS.take (fromIntegral c) bs'+ pure (writeTest .&&. readTest .&&. cmpTest)++infix 4 .<=++(.<=) :: (Ord a, Show a) => a -> a -> Property+x .<= y = counterexample (show x ++ interpret res ++ show y) res+ where+ res = x <= y+ interpret True = " <= "+ interpret False = " > "