Merge pull request #97 from input-output-hk/jdral/must-exist

Adding `MustExist` constructor to assert a file is assumed to exist

Author: jorisdral

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
 

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

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 ->

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"

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
 

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)

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))

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