diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/fs-api.cabal b/fs-api.cabal new file mode 100644 --- /dev/null +++ b/fs-api.cabal @@ -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 diff --git a/src-unix/System/FS/IO/Unix.hs b/src-unix/System/FS/IO/Unix.hs new file mode 100644 --- /dev/null +++ b/src-unix/System/FS/IO/Unix.hs @@ -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 diff --git a/src-win32/System/FS/IO/Windows.hs b/src-win32/System/FS/IO/Windows.hs new file mode 100644 --- /dev/null +++ b/src-win32/System/FS/IO/Windows.hs @@ -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 diff --git a/src/System/FS/API.hs b/src/System/FS/API.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/API.hs @@ -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` () diff --git a/src/System/FS/API/Lazy.hs b/src/System/FS/API/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/API/Lazy.hs @@ -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 diff --git a/src/System/FS/API/Strict.hs b/src/System/FS/API/Strict.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/API/Strict.hs @@ -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' diff --git a/src/System/FS/API/Types.hs b/src/System/FS/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/API/Types.hs @@ -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) = "") 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 diff --git a/src/System/FS/CRC.hs b/src/System/FS/CRC.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/CRC.hs @@ -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) diff --git a/src/System/FS/CallStack.hs b/src/System/FS/CallStack.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/CallStack.hs @@ -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 diff --git a/src/System/FS/Condense.hs b/src/System/FS/Condense.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/Condense.hs @@ -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>" diff --git a/src/System/FS/IO.hs b/src/System/FS/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/IO.hs @@ -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 "" + , 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 diff --git a/src/System/FS/IO/Handle.hs b/src/System/FS/IO/Handle.hs new file mode 100644 --- /dev/null +++ b/src/System/FS/IO/Handle.hs @@ -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 = "" + +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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Test/System/FS/API/FsPath.hs b/test/Test/System/FS/API/FsPath.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/API/FsPath.hs @@ -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) diff --git a/test/Test/System/FS/IO.hs b/test/Test/System/FS/IO.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/FS/IO.hs @@ -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 = " > "