diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index a078dda..2b7b7b6 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -2,6 +2,10 @@ ## ?.?.?.? -- ????-??-?? +### Breaking + +* Add a new `MustExist` option to `AllowExisting`. + ### Non-breaking * Make the orphan `Condense` instance for `System.IO.SeekMode` into a non-orphan @@ -11,6 +15,10 @@ ### Patch * Make it build with `ghc-9.12`. +* Bugfix: opening a file in read mode now expects the file to exist already. + This was already the semantics when using `hOpen` from the `ioHasFS` instance, + but it was not reflected in the `allowExisting` function. `allowExisting + Readmode` now returns `MustExist` instead of `AllowExisting`. ## 0.3.0.1 -- 2024-10-02 diff --git a/fs-api/src-unix/System/FS/IO/Unix.hs b/fs-api/src-unix/System/FS/IO/Unix.hs index bdd842e..efbd671 100644 --- a/fs-api/src-unix/System/FS/IO/Unix.hs +++ b/fs-api/src-unix/System/FS/IO/Unix.hs @@ -73,19 +73,16 @@ open fp openMode = Posix.openFd fp posixOpenMode fileFlags AppendMode ex -> ( Posix.WriteOnly , defaultFileFlags { Posix.append = True , Posix.exclusive = isExcl ex - , Posix.creat = Just Posix.stdFileMode } + , Posix.creat = creat ex } ) ReadWriteMode ex -> ( Posix.ReadWrite , defaultFileFlags { Posix.exclusive = isExcl ex - , Posix.creat = Just Posix.stdFileMode } + , Posix.creat = creat ex } ) WriteMode ex -> ( Posix.ReadWrite , defaultFileFlags { Posix.exclusive = isExcl ex - , Posix.creat = Just Posix.stdFileMode } + , Posix.creat = creat ex } ) - - isExcl AllowExisting = False - isExcl MustBeNew = True # else open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags where @@ -95,22 +92,26 @@ open fp openMode = Posix.openFd fp posixOpenMode fileMode fileFlags , defaultFileFlags ) AppendMode ex -> ( Posix.WriteOnly - , Just Posix.stdFileMode + , creat ex , defaultFileFlags { Posix.append = True , Posix.exclusive = isExcl ex } ) ReadWriteMode ex -> ( Posix.ReadWrite - , Just Posix.stdFileMode + , creat ex , defaultFileFlags { Posix.exclusive = isExcl ex } ) WriteMode ex -> ( Posix.ReadWrite - , Just Posix.stdFileMode + , creat ex , defaultFileFlags { Posix.exclusive = isExcl ex } ) - +# endif isExcl AllowExisting = False isExcl MustBeNew = True -# endif + isExcl MustExist = False + + creat AllowExisting = Just Posix.stdFileMode + creat MustBeNew = Just Posix.stdFileMode + creat MustExist = Nothing -- | Writes the data pointed by the input 'Ptr Word8' into the input 'FHandle'. write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32 diff --git a/fs-api/src-win32/System/FS/IO/Windows.hs b/fs-api/src-win32/System/FS/IO/Windows.hs index af6677c..b91f94b 100644 --- a/fs-api/src-win32/System/FS/IO/Windows.hs +++ b/fs-api/src-win32/System/FS/IO/Windows.hs @@ -60,6 +60,7 @@ open filename openMode = do ReadWriteMode ex -> (gENERIC_READ .|. gENERIC_WRITE, createNew ex) createNew AllowExisting = oPEN_ALWAYS createNew MustBeNew = cREATE_NEW + createNew MustExist = oPEN_EXISTING write :: FHandle -> Ptr Word8 -> Int64 -> IO Word32 write fh data' bytes = withOpenHandle "write" fh $ \h -> diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs index bf9a65d..ccc44f7 100644 --- a/fs-api/src/System/FS/API/Types.hs +++ b/fs-api/src/System/FS/API/Types.hs @@ -70,6 +70,15 @@ import System.FS.Condense -------------------------------------------------------------------------------} -- | How to 'System.FS.API.hOpen' a new file. +-- +-- Each mode of file operation has an associated 'AllowExisting' parameter which +-- specifies the semantics of how to handle the existence or non-existence of +-- the file. +-- +-- /Notably however/, opening a file in read mode with the @ReadMode@ value +-- /implicitly/ has the associated 'AllowExisting' value of 'MustExist'. This is +-- because opening a non-existing file in 'ReadMode' provides access to exactly +-- 0 bytes of data and is hence a useless operation. data OpenMode = ReadMode | WriteMode AllowExisting @@ -83,13 +92,19 @@ data 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 + -- ^ The file must not yet exist. If it does, an error -- ('FsResourceAlreadyExist') is thrown. + | MustExist + -- ^ The file must already exist. If it does not, an error + -- ('FsResourceDoesNotExist') is thrown. + -- + -- /Note:/ If opening a file in 'ReadMode', then the file must exist + -- or an exception is thrown. deriving (Eq, Show) allowExisting :: OpenMode -> AllowExisting allowExisting openMode = case openMode of - ReadMode -> AllowExisting + ReadMode -> MustExist WriteMode ex -> ex AppendMode ex -> ex ReadWriteMode ex -> ex @@ -453,6 +468,7 @@ ioToFsErrorType ioErr = case Errno <$> GHC.ioe_errno ioErr of instance Condense AllowExisting where condense AllowExisting = "" condense MustBeNew = "!" + condense MustExist = "+" instance Condense OpenMode where condense ReadMode = "r" diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md index ccb873d..08b5287 100644 --- a/fs-sim/CHANGELOG.md +++ b/fs-sim/CHANGELOG.md @@ -32,6 +32,8 @@ ### Patch * Make it build with `ghc-9.12`. +* Support the new `MustExist` option for `AllowExisting` that was added in + `fs-api`. ## 0.3.1.0 -- 2024-12-10 diff --git a/fs-sim/src/System/FS/Sim/FsTree.hs b/fs-sim/src/System/FS/Sim/FsTree.hs index 1872c3c..aa06bb4 100644 --- a/fs-sim/src/System/FS/Sim/FsTree.hs +++ b/fs-sim/src/System/FS/Sim/FsTree.hs @@ -231,14 +231,23 @@ getDir fp = Specific file system functions -------------------------------------------------------------------------------} --- | Open a file: create it if necessary or throw an error if it existed --- already wile we were supposed to create it from scratch (when passed --- 'MustBeNew'). +-- | Open a file: create it if necessary or throw an error if either: +-- 1. It existed already while we were supposed to create it from scratch +-- (when passed 'MustBeNew'). +-- 2. It did not already exists when we expected to (when passed 'MustExist'). openFile :: Monoid a => FsPath -> AllowExisting -> FsTree a -> Either FsTreeError (FsTree a) -openFile fp ex = alterFile fp Left (Right mempty) $ \a -> case ex of - AllowExisting -> Right a - MustBeNew -> Left (FsExists fp) +openFile fp ex = alterFile fp Left caseDoesNotExist caseAlreadyExist + where + caseAlreadyExist a = case ex of + AllowExisting -> Right a + MustBeNew -> Left (FsExists fp) + MustExist -> Right a + + caseDoesNotExist = case ex of + AllowExisting -> Right mempty + MustBeNew -> Right mempty + MustExist -> Left (FsMissing fp (pathLast fp :| [])) -- | Replace the contents of the specified file (which must exist) replace :: FsPath -> a -> FsTree a -> Either FsTreeError (FsTree a) diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 8b0ab99..2b3b991 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -65,7 +65,7 @@ module System.FS.Sim.MockFS ( , hPutBufSomeAt ) where -import Control.Monad (forM, forM_, unless, void, when) +import Control.Monad (forM, forM_, unless, when) import Control.Monad.Except (MonadError, throwError) import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.State.Strict (MonadState, get, gets, put) @@ -491,8 +491,6 @@ hOpen fp openMode = do , fsErrorStack = prettyCallStack , fsLimitation = True } - when (openMode == ReadMode) $ void $ - checkFsTree $ FS.getFile fp (mockFiles fs) files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) return $ newHandle (fs { mockFiles = files' }) (OpenHandle fp (filePtr openMode)) diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index b41f796..cc0e810 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -676,7 +676,7 @@ generator Model{..} = oneof $ concat [ (rf, wf) = if fileExists then (10,3) else (1,3) genAllowExisting :: Gen AllowExisting - genAllowExisting = elements [AllowExisting, MustBeNew] + genAllowExisting = elements [AllowExisting, MustBeNew, MustExist] genSeekMode :: Gen SeekMode genSeekMode = elements [ @@ -1004,84 +1004,107 @@ data Tag = -- > Get .. | TagPutTruncateGet - -- Close a handle 2 times + -- | Close a handle 2 times -- -- > h <- Open .. -- > close h -- > close h | TagClosedTwice - -- Open an existing file with ReadMode and then with WriteMode + -- | Open an existing file with ReadMode and then with WriteMode -- -- > open fp ReadMode -- > open fp Write | TagOpenReadThenWrite - -- Open 2 Readers of a file. + -- | Open 2 Readers of a file. -- -- > open fp ReadMode -- > open fp ReadMode | TagOpenReadThenRead - -- ListDir on a non empty dirextory. + -- | ListDir on a non empty dirextory. -- -- > CreateDirIfMissing True a/b -- > ListDirectory a | TagCreateDirWithParentsThenListDirNotNull - -- Read from an AppendMode file + -- | Read from an AppendMode file -- -- > h <- Open fp AppendMode -- > Read h .. | TagReadInvalid - -- Write to a read only file + -- | Write to a read only file -- -- > h <- Open fp ReadMode -- > Put h .. | TagWriteInvalid - -- Put Seek and Get + -- | Put Seek and Get -- -- > Put .. -- > Seek .. -- > Get .. | TagPutSeekGet - -- Put Seek (negative) and Get + -- | Put Seek (negative) and Get -- -- > Put .. -- > Seek .. (negative) -- > Get .. | TagPutSeekNegGet - -- Open with MustBeNew (O_EXCL flag), but the file already existed. + -- | Open with MustBeNew (O_EXCL flag), but the file already existed. -- -- > h <- Open fp (AppendMode _) -- > Close h -- > Open fp (AppendMode MustBeNew) | TagExclusiveFail + -- | Open a file in read mode successfully + -- + -- > h <- Open fp (WriteMode _) + -- > Close h + -- > h <- Open fp ReadMode + | TagReadModeMustExist + + -- | Open a file in read mode, but it fails because the file does not exist. + -- + -- > h <- Open fp ReadMode + | TagReadModeMustExistFail + + -- | Open a file in non-read mode with 'MustExist' successfully. + -- + -- > h <- Open fp (_ MustBeNew) + -- > Close h + -- > h <- Open fp (_ MustExist) + | TagFileMustExist + + -- | Open a file in non-read mode with 'MustExist', but it fails because the + -- files does not exist. + -- + -- > h <- Open fp (_ MustExist) + | TagFileMustExistFail - -- Reading returns an empty bytestring when EOF + -- | Reading returns an empty bytestring when EOF -- -- > h <- open fp ReadMode -- > Get h 1 == "" | TagReadEOF - - -- GetAt + -- | GetAt -- -- > GetAt ... | TagPread - -- Roundtrip for I/O with user-supplied buffers + -- | Roundtrip for I/O with user-supplied buffers -- -- > PutBuf h bs c -- > GetBuf h c (==bs) | TagPutGetBuf - -- Roundtrip for I/O with user-supplied buffers + -- | Roundtrip for I/O with user-supplied buffers -- -- > PutBufAt h bs c o -- > GetBufAt h c o (==bs) @@ -1136,6 +1159,10 @@ tag = C.classify [ , tagPutSeekGet Set.empty Set.empty , tagPutSeekNegGet Set.empty Set.empty , tagExclusiveFail + , tagReadModeMustExist + , tagReadModeMustExistFail + , tagFileMustExist + , tagFileMustExistFail , tagReadEOF , tagPread , tagPutGetBuf Set.empty @@ -1481,6 +1508,39 @@ tag = C.classify [ Left TagExclusiveFail _otherwise -> Right tagExclusiveFail + tagReadModeMustExist :: EventPred + tagReadModeMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Right (RHandle _))) -> Left TagReadModeMustExist + _otherwise -> Right tagReadModeMustExist + + tagReadModeMustExistFail :: EventPred + tagReadModeMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ ReadMode, Resp (Left fsError)) + | fsErrorType fsError == FsResourceDoesNotExist -> + Left TagReadModeMustExistFail + _otherwise -> Right tagReadModeMustExistFail + + tagFileMustExist :: EventPred + tagFileMustExist = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Right (WHandle _ _))) + | MustExist <- allowExisting mode + , mode /= ReadMode + -> Left TagFileMustExist + _otherwise -> Right tagFileMustExist + + tagFileMustExistFail :: EventPred + tagFileMustExistFail = C.predicate $ \ev -> + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Left fsError)) + | MustExist <- allowExisting mode + , mode /= ReadMode + , fsErrorType fsError == FsResourceDoesNotExist -> + Left TagFileMustExistFail + _otherwise -> Right tagFileMustExistFail + tagReadEOF :: EventPred tagReadEOF = successful $ \ev suc -> case (eventMockCmd ev, suc) of