From c5ffc9c1b4f42e6574f1177804fd5c0cf34e5e50 Mon Sep 17 00:00:00 2001 From: Recursion Ninja Date: Fri, 13 Dec 2024 11:52:37 -0500 Subject: [PATCH] Adding 'MustExist' constructor to assert a file is assumed to exist --- fs-api/src-unix/System/FS/IO/Unix.hs | 23 +++++++++--------- fs-api/src-win32/System/FS/IO/Windows.hs | 1 + fs-api/src/System/FS/API/Types.hs | 6 ++++- fs-sim/src/System/FS/Sim/FsTree.hs | 19 ++++++++++----- fs-sim/src/System/FS/Sim/MockFS.hs | 8 +++++-- fs-sim/test/Test/System/FS/StateMachine.hs | 28 +++++++++++++++++++++- 6 files changed, 64 insertions(+), 21 deletions(-) diff --git a/fs-api/src-unix/System/FS/IO/Unix.hs b/fs-api/src-unix/System/FS/IO/Unix.hs index bdd842e..76dcf18 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 x , defaultFileFlags { Posix.append = True , Posix.exclusive = isExcl ex } ) ReadWriteMode ex -> ( Posix.ReadWrite - , Just Posix.stdFileMode + , creat x , defaultFileFlags { Posix.exclusive = isExcl ex } ) WriteMode ex -> ( Posix.ReadWrite - , Just Posix.stdFileMode + , creat x , 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..7a31914 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_ALWAYS 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 0ee9244..9065c63 100644 --- a/fs-api/src/System/FS/API/Types.hs +++ b/fs-api/src/System/FS/API/Types.hs @@ -85,8 +85,11 @@ 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. deriving (Eq, Show) allowExisting :: OpenMode -> AllowExisting @@ -460,6 +463,7 @@ instance Condense SeekMode where instance Condense AllowExisting where condense AllowExisting = "" condense MustBeNew = "!" + condense MustExist = "+" instance Condense OpenMode where condense ReadMode = "r" diff --git a/fs-sim/src/System/FS/Sim/FsTree.hs b/fs-sim/src/System/FS/Sim/FsTree.hs index 1872c3c..54d5803 100644 --- a/fs-sim/src/System/FS/Sim/FsTree.hs +++ b/fs-sim/src/System/FS/Sim/FsTree.hs @@ -231,14 +231,21 @@ 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 + MustBeNew -> Left (FsExists fp) + _ -> Right a + + caseDoesNotExist = case ex of + MustExist -> Left (FsMissing fp (pathLast fp :| [])) + _ -> Right mempty -- | 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..e35b829 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -479,7 +479,11 @@ hOpen fp openMode = do , fsLimitation = True } modifyMockFS $ \fs -> do - let alreadyHasWriter = + let assumedExistance (WriteMode MustExist) = True + assumedExistance (AppendMode MustExist) = True + assumedExistance (ReadWriteMode MustExist) = True + assumedExistance _ = False + alreadyHasWriter = any (\hs -> openFilePath hs == fp && isWriteHandle hs) $ openHandles fs when (openMode /= ReadMode && alreadyHasWriter) $ @@ -491,7 +495,7 @@ hOpen fp openMode = do , fsErrorStack = prettyCallStack , fsLimitation = True } - when (openMode == ReadMode) $ void $ + when (openMode == ReadMode || assumedExistance openMode) $ void $ checkFsTree $ FS.getFile fp (mockFiles fs) files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) return $ newHandle (fs { mockFiles = files' }) diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index b41f796..9e8138d 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 [ @@ -1055,6 +1055,7 @@ data Tag = -- > Get .. | TagPutSeekNegGet + -- Open with MustBeNew (O_EXCL flag), but the file already existed. -- -- > h <- Open fp (AppendMode _) @@ -1063,6 +1064,13 @@ data Tag = | TagExclusiveFail + -- Open with MustExist, but the file does not exist. + -- + -- > DoesFileExist fp + -- > h <- Open fp (AppendMode _) + | TagAssumeExists + + -- Reading returns an empty bytestring when EOF -- -- > h <- open fp ReadMode @@ -1136,6 +1144,7 @@ tag = C.classify [ , tagPutSeekGet Set.empty Set.empty , tagPutSeekNegGet Set.empty Set.empty , tagExclusiveFail +-- , tagAssumeExistsFail -- Set.empty , tagReadEOF , tagPread , tagPutGetBuf Set.empty @@ -1481,6 +1490,23 @@ tag = C.classify [ Left TagExclusiveFail _otherwise -> Right tagExclusiveFail + tagAssumeExistsFail :: EventPred + tagAssumeExistsFail = C.predicate $ \ev -> +{- + tagClosedTwice closed = successful $ \ev _suc -> + case eventMockCmd ev of + Close (Handle h _) | Set.member h closed -> Left TagClosedTwice + Close (Handle h _) -> Right $ tagClosedTwice $ Set.insert h closed + _otherwise -> Right $ tagClosedTwice closed + (DoesFileExist _, Bool False) -> Left TagDoesFileExistKO +-} + case (eventMockCmd ev, eventMockResp ev) of + (Open _ mode, Resp (Left fsError)) + | MustExist <- allowExisting mode + , fsErrorType fsError == FsResourceDoesNotExist -> + Left TagAssumeExists + _otherwise -> Right tagAssumeExistsFail + tagReadEOF :: EventPred tagReadEOF = successful $ \ev suc -> case (eventMockCmd ev, suc) of