From d225d75df81cb8f6242e24218aafee13d3e1c44d Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 8 Mar 2024 13:23:08 +0100 Subject: [PATCH] Add `hTell` for requesting the absolute file offset stored in a handle --- fs-api/CHANGELOG.md | 7 ++ fs-api/src-unix/System/FS/IO/Internal.hs | 8 +- fs-api/src-win32/System/FS/IO/Internal.hs | 5 + fs-api/src/System/FS/API.hs | 10 ++ fs-api/src/System/FS/IO.hs | 2 + fs-sim/CHANGELOG.md | 17 +++ fs-sim/fs-sim.cabal | 2 +- fs-sim/src/System/FS/Sim/Error.hs | 119 +++++++++++++++++---- fs-sim/src/System/FS/Sim/MockFS.hs | 61 ++++++++--- fs-sim/src/System/FS/Sim/Pure.hs | 1 + fs-sim/src/System/FS/Sim/STM.hs | 1 + fs-sim/test/Test/System/FS/StateMachine.hs | 53 +++++++-- 12 files changed, 236 insertions(+), 50 deletions(-) diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index 61bea93..49ed426 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for fs-api +## next release -- ????-??-?? + +### Breaking + +* Add `hTell` function to `HasFS`, which returns the absolute file offset that + is stored in a file handle. + ## 0.2.0.1 -- 2023-10-30 ### Patch diff --git a/fs-api/src-unix/System/FS/IO/Internal.hs b/fs-api/src-unix/System/FS/IO/Internal.hs index 5a00ba1..9a7933f 100644 --- a/fs-api/src-unix/System/FS/IO/Internal.hs +++ b/fs-api/src-unix/System/FS/IO/Internal.hs @@ -12,6 +12,7 @@ module System.FS.IO.Internal ( , read , sameError , seek + , tell , truncate , write ) where @@ -28,7 +29,7 @@ import System.FS.API.Types (AllowExisting (..), FsError, OpenMode (..), SeekMode (..), sameFsError) import System.FS.IO.Internal.Handle import qualified System.Posix as Posix -import System.Posix (Fd) +import System.Posix (Fd (..)) import System.Posix.IO.ByteString.Ext (fdPreadBuf) type FHandle = HandleOS Fd @@ -123,6 +124,11 @@ seek :: FHandle -> SeekMode -> Int64 -> IO () seek h seekMode offset = withOpenHandle "seek" h $ \fd -> void $ Posix.fdSeek fd seekMode (fromIntegral offset) +-- | Request the absolute file offset stored in the handle +tell :: FHandle -> IO Word64 +tell h = withOpenHandle "tell" h $ \fd -> + fromIntegral <$> Posix.fdSeek fd RelativeSeek 0 + -- | Reads a given number of bytes from the input 'FHandle'. read :: FHandle -> Word64 -> IO ByteString read h bytes = withOpenHandle "read" h $ \fd -> diff --git a/fs-api/src-win32/System/FS/IO/Internal.hs b/fs-api/src-win32/System/FS/IO/Internal.hs index d0e074c..0974c98 100644 --- a/fs-api/src-win32/System/FS/IO/Internal.hs +++ b/fs-api/src-win32/System/FS/IO/Internal.hs @@ -11,6 +11,7 @@ module System.FS.IO.Internal ( , read , sameError , seek + , tell , truncate , write ) where @@ -65,6 +66,10 @@ seek :: FHandle -> SeekMode -> Int64 -> IO () seek fh seekMode size = void <$> withOpenHandle "seek" fh $ \h -> setFilePointerEx h size (fromSeekMode seekMode) +-- | Request the absolute file offset stored in the handle +tell :: FHandle -> IO Word64 +tell h = withOpenHandle "tell" h $ fmap fromIntegral . getCurrentFileOffset + fromSeekMode :: SeekMode -> FilePtrDirection fromSeekMode AbsoluteSeek = fILE_BEGIN fromSeekMode RelativeSeek = fILE_CURRENT diff --git a/fs-api/src/System/FS/API.hs b/fs-api/src/System/FS/API.hs index 806c39f..9b15a83 100644 --- a/fs-api/src/System/FS/API.hs +++ b/fs-api/src/System/FS/API.hs @@ -58,6 +58,16 @@ data HasFS m h = HasFS { -- and we don't want to emulate it's behaviour. , hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m () + -- | Return the current absolute offset into the file + -- + -- NOTE: may provide different answers on Windows than on Unix-based systems + -- in two cases, (1) when opening a existing file in append-only mode, or + -- (2) right after a file has been truncated. It seems that on Windows + -- systems, the offset is immediately up-to-date, whereas on Unix-based + -- systems the file offset may not be updated until you start writing >0 + -- bytes to the file handle. + , hTell :: HasCallStack => Handle h -> m AbsOffset + -- | Try to read @n@ bytes from a handle -- -- When at the end of the file, an empty bytestring will be returned. diff --git a/fs-api/src/System/FS/IO.hs b/fs-api/src/System/FS/IO.hs index 268c697..ada5b32 100644 --- a/fs-api/src/System/FS/IO.hs +++ b/fs-api/src/System/FS/IO.hs @@ -50,6 +50,8 @@ ioHasFS mount = HasFS { F.truncate h sz , hGetSize = \(Handle h fp) -> liftIO $ rethrowFsError fp $ F.getSize h + , hTell = \(Handle h fp) -> liftIO $ rethrowFsError fp $ + AbsOffset <$> F.tell h , hPutSome = \(Handle h fp) bs -> liftIO $ rethrowFsError fp $ do BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> fromIntegral <$> F.write h (castPtr ptr) (fromIntegral len) diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md index a5b6239..adc1dc5 100644 --- a/fs-sim/CHANGELOG.md +++ b/fs-sim/CHANGELOG.md @@ -1,5 +1,22 @@ # Revision history for fs-sim +## next release -- ????-??-?? + +### Breaking + +* Add simulation implementations (`pureHasFS`, `simHasFS` and `mkSimErrorHasFS`) + for the new `hTell` function in the `HasFS` interface. The simulation has two + known limitations regarding `hTell` because of differing behaviour between + Windows and Unix-based systems. +* Add an error stream to `Errors` for `hTell`. + +### Patch + +* `allNull` was not actually checking whether all streams in the argument + `Errors` are empty. +* The `Show Errors` instance was not printing every stream. +* The shrinker for `Errors` was not shrinking every stream. + ## 0.2.1.1 -- 2023-10-30 ### Patch diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal index 8448b49..004fd36 100644 --- a/fs-sim/fs-sim.cabal +++ b/fs-sim/fs-sim.cabal @@ -10,7 +10,7 @@ license-files: copyright: 2019-2023 Input Output Global Inc (IOG) author: IOG Engineering Team -maintainer: operations@iohk.io, Joris Dral +maintainer: operations@iohk.io, Joris Dral (joris@well-typed.com) category: Testing build-type: Simple extra-doc-files: CHANGELOG.md diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs index b3f3f9b..e3429f2 100644 --- a/fs-sim/src/System/FS/Sim/Error.hs +++ b/fs-sim/src/System/FS/Sim/Error.hs @@ -211,6 +211,7 @@ data Errors = Errors , hOpenE :: ErrorStream , hCloseE :: ErrorStream , hSeekE :: ErrorStream + , hTellE :: ErrorStream , hGetSomeE :: ErrorStreamGetSome , hGetSomeAtE :: ErrorStreamGetSome , hPutSomeE :: ErrorStreamPutSome @@ -230,28 +231,74 @@ data Errors = Errors -- | Return 'True' if all streams are empty ('null'). allNull :: Errors -> Bool -allNull Errors {..} = Stream.null dumpStateE - && Stream.null hOpenE - && Stream.null hCloseE - && Stream.null hSeekE - && Stream.null hGetSomeE - && Stream.null hGetSomeAtE - && Stream.null hPutSomeE - && Stream.null hTruncateE - && Stream.null hGetSizeE - && Stream.null createDirectoryE - && Stream.null createDirectoryIfMissingE - && Stream.null listDirectoryE - && Stream.null doesDirectoryExistE - && Stream.null doesFileExistE - && Stream.null removeFileE - && Stream.null renameFileE - +allNull errs = + Stream.null dumpStateE + && Stream.null hOpenE + && Stream.null hCloseE + && Stream.null hSeekE + && Stream.null hTellE + && Stream.null hGetSomeE + && Stream.null hGetSomeAtE + && Stream.null hPutSomeE + && Stream.null hTruncateE + && Stream.null hGetSizeE + && Stream.null createDirectoryE + && Stream.null createDirectoryIfMissingE + && Stream.null listDirectoryE + && Stream.null doesDirectoryExistE + && Stream.null doesFileExistE + && Stream.null removeDirectoryRecursiveE + && Stream.null removeFileE + && Stream.null renameFileE + where + -- a (non-record) pattern match ensures that we are not missing any fields + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = errs instance Show Errors where - show Errors {..} = + show errs = "Errors {" <> intercalate ", " streams <> "}" where + -- a (non-record) pattern match ensures that we are not missing any fields + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = errs + -- | Show a stream unless it is empty s :: Show a => String -> Stream a -> Maybe String s fld str | Stream.null str = Nothing @@ -263,6 +310,7 @@ instance Show Errors where , s "hOpenE" hOpenE , s "hCloseE" hCloseE , s "hSeekE" hSeekE + , s "hTellE" hTellE , s "hGetSomeE" hGetSomeE , s "hGetSomeAtE" hGetSomeAtE , s "hPutSomeE" hPutSomeE @@ -273,6 +321,7 @@ instance Show Errors where , s "listDirectoryE" listDirectoryE , s "doesDirectoryExistE" doesDirectoryExistE , s "doesFileExistE" doesFileExistE + , s "removeDirectyRecursiveE" removeDirectoryRecursiveE , s "removeFileE" removeFileE , s "renameFileE" renameFileE ] @@ -288,6 +337,7 @@ simpleErrors es = Errors , hOpenE = es , hCloseE = es , hSeekE = es + , hTellE = es , hGetSomeE = Left <$> es , hGetSomeAtE = Left <$> es , hPutSomeE = (Left . (, Nothing)) <$> es @@ -327,6 +377,7 @@ genErrors genPartialWrites genSubstituteWithJunk = do , FsResourceAlreadyInUse, FsResourceAlreadyExist , FsInsufficientPermissions, FsTooManyOpenFiles ] hSeekE <- streamGen 3 [ FsReachedEOF ] + hTellE <- streamGen 3 [ FsIllegalOperation ] hGetSomeE <- streamGen' 20 [ (1, return $ Left FsReachedEOF) , (3, Right <$> arbitrary) ] @@ -365,11 +416,12 @@ genErrors genPartialWrites genSubstituteWithJunk = do instance Arbitrary Errors where arbitrary = genErrors True True - shrink err@Errors {..} = filter (not . allNull) $ concat + shrink err = filter (not . allNull) $ concat [ (\s' -> err { dumpStateE = s' }) <$> Stream.shrinkStream dumpStateE , (\s' -> err { hOpenE = s' }) <$> Stream.shrinkStream hOpenE , (\s' -> err { hCloseE = s' }) <$> Stream.shrinkStream hCloseE , (\s' -> err { hSeekE = s' }) <$> Stream.shrinkStream hSeekE + , (\s' -> err { hTellE = s' }) <$> Stream.shrinkStream hTellE , (\s' -> err { hGetSomeE = s' }) <$> Stream.shrinkStream hGetSomeE , (\s' -> err { hGetSomeAtE = s' }) <$> Stream.shrinkStream hGetSomeAtE , (\s' -> err { hPutSomeE = s' }) <$> Stream.shrinkStream hPutSomeE @@ -380,9 +432,32 @@ instance Arbitrary Errors where , (\s' -> err { listDirectoryE = s' }) <$> Stream.shrinkStream listDirectoryE , (\s' -> err { doesDirectoryExistE = s' }) <$> Stream.shrinkStream doesDirectoryExistE , (\s' -> err { doesFileExistE = s' }) <$> Stream.shrinkStream doesFileExistE + , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE , (\s' -> err { removeFileE = s' }) <$> Stream.shrinkStream removeFileE , (\s' -> err { renameFileE = s' }) <$> Stream.shrinkStream renameFileE ] + where + -- a (non-record) pattern match ensures that we are not missing any fields + Errors + dumpStateE + hOpenE + hCloseE + hSeekE + hTellE + hGetSomeE + hGetSomeAtE + hPutSomeE + hTruncateE + hGetSizeE + createDirectoryE + createDirectoryIfMissingE + listDirectoryE + doesDirectoryExistE + doesFileExistE + removeDirectoryRecursiveE + removeFileE + renameFileE + = err {------------------------------------------------------------------------------- Simulate Errors monad @@ -419,6 +494,9 @@ mkSimErrorHasFS fsVar errorsVar = , hSeek = \h m n -> withErr' errorsVar h (hSeek h m n) "hSeek" hSeekE (\e es -> es { hSeekE = e }) + , hTell = \h -> + withErr' errorsVar h (hTell h) "hTell" + hTellE (\e es -> es { hTellE = e }) , hGetSome = hGetSome' errorsVar hGetSome , hGetSomeAt = hGetSomeAt' errorsVar hGetSomeAt , hPutSome = hPutSome' errorsVar hPutSome @@ -537,8 +615,7 @@ withErr' :: (MonadSTM m, MonadThrow m, HasCallStack) -> (Errors -> ErrorStream) -- ^ @getter@ -> (ErrorStream -> Errors -> Errors) -- ^ @setter@ -> m a -withErr' errorsVar handle action msg getter setter = - withErr errorsVar (handlePath handle) action msg getter setter +withErr' errorsVar handle = withErr errorsVar (handlePath handle) -- | Execute the wrapped 'hGetSome', throw an error, or simulate a partial -- read, depending on the corresponding 'ErrorStreamGetSome' (see diff --git a/fs-sim/src/System/FS/Sim/MockFS.hs b/fs-sim/src/System/FS/Sim/MockFS.hs index 58199ac..8c9c4fa 100644 --- a/fs-sim/src/System/FS/Sim/MockFS.hs +++ b/fs-sim/src/System/FS/Sim/MockFS.hs @@ -34,6 +34,7 @@ module System.FS.Sim.MockFS ( , hOpen , hPutSome , hSeek + , hTell , hTruncate -- * Operations on directories , createDirectory @@ -120,7 +121,7 @@ data OpenHandleState = OpenHandle { isWriteHandle :: OpenHandleState -> Bool isWriteHandle OpenHandle{..} = case openPtr of RW _ True _ -> True - Append -> True + Append _ -> True _ -> False -- | File pointer @@ -134,8 +135,10 @@ data FilePtr = -- | Append-only pointer -- - -- Offset is always the end of the file in append mode - | Append + -- Offset is always the end of the file in append mode, with two exceptions + -- that are explained in the note on 'System.FS.API.hTell'. In these two + -- exception cases, the offset is /ambiguous/ (i.e., 'Nothing'). + | Append !(Maybe Word64) deriving (Show, Generic) data ClosedHandleState = ClosedHandle { @@ -229,7 +232,7 @@ seekFilePtr MockFS{..} (Handle h _) seekMode o = do when (o' > fsize) $ throwError (errNegative openFilePath) let cur' = fsize - o' return $ RW r w cur' - (Append, _, _) -> + (Append _, _, _) -> throwError (errAppend openFilePath) where errPastEnd fp = FsError { @@ -465,6 +468,7 @@ hOpen fp openMode = do , fsErrorStack = prettyCallStack , fsLimitation = True } + fileExists <- doesFileExist fp modifyMockFS $ \fs -> do let alreadyHasWriter = any (\hs -> openFilePath hs == fp && isWriteHandle hs) $ @@ -482,16 +486,18 @@ hOpen fp openMode = do checkFsTree $ FS.getFile fp (mockFiles fs) files' <- checkFsTree $ FS.openFile fp ex (mockFiles fs) return $ newHandle (fs { mockFiles = files' }) - (OpenHandle fp (filePtr openMode)) + (OpenHandle fp (filePtr openMode fileExists)) where ex :: AllowExisting ex = allowExisting openMode - filePtr :: OpenMode -> FilePtr - filePtr ReadMode = RW True False 0 - filePtr (WriteMode _) = RW False True 0 - filePtr (ReadWriteMode _) = RW True True 0 - filePtr (AppendMode _) = Append + filePtr :: OpenMode -> Bool -> FilePtr + filePtr ReadMode _ = RW True False 0 + filePtr (WriteMode _ ) _ = RW False True 0 + filePtr (ReadWriteMode _ ) _ = RW True True 0 + filePtr (AppendMode aex) fileExists + | aex == AllowExisting && fileExists = Append Nothing + | otherwise = Append (Just 0) -- | Mock implementation of 'hClose' hClose :: CanSimFS m => Handle' -> m () @@ -520,6 +526,25 @@ hSeek h seekMode o = withOpenHandleRead h $ \fs hs -> do openPtr' <- seekFilePtr fs h seekMode o return ((), hs { openPtr = openPtr' }) +-- | Get the current offset stored in the file handle +hTell :: CanSimFS m => Handle' -> m AbsOffset +hTell h = withOpenHandleRead h $ \_ hs@OpenHandle{..} -> do + case openPtr of + RW _ _ off -> pure (AbsOffset off, hs) + Append offM -> do + case offM of + Nothing -> throwError (errOffsetUnkown openFilePath) + Just off -> pure (AbsOffset off, hs) + where + errOffsetUnkown fp = FsError { + fsErrorType = FsInvalidArgument + , fsErrorPath = fsToFsErrorPathUnmounted fp + , fsErrorString = "hTell: offset is ambiguous" -- See 'Append' + , fsErrorNo = Nothing + , fsErrorStack = prettyCallStack + , fsLimitation = True + } + -- | Get bytes from handle -- -- NOTE: Unlike real I/O, we disallow 'hGetSome' on a handle in append mode. @@ -532,7 +557,7 @@ hGetSome h n = unless r $ throwError (errNoReadAccess openFilePath "write") let bs = BS.take (fromIntegral n) . BS.drop (fromIntegral o) $ file return (bs, hs { openPtr = RW True w (o + fromIntegral (BS.length bs)) }) - Append -> throwError (errNoReadAccess openFilePath "append") + Append _ -> throwError (errNoReadAccess openFilePath "append") where errNoReadAccess fp mode = FsError { fsErrorType = FsInvalidArgument @@ -563,7 +588,7 @@ hGetSomeAt h n o = -- EOF, in AbsoluteSeek mode. when (o' > fsize) $ throwError (errPastEnd openFilePath) return (bs, hs) - Append -> throwError (errNoReadAccess openFilePath "append") + Append _ -> throwError (errNoReadAccess openFilePath "append") where errNoReadAccess fp mode = FsError { fsErrorType = FsInvalidArgument @@ -593,11 +618,15 @@ hPutSome h toWrite = let file' = replace o toWrite file files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) return (written, (files', hs { openPtr = RW r w (o + written) })) - Append -> do + Append o -> do file <- checkFsTree $ FS.getFile openFilePath (mockFiles fs) let file' = file <> toWrite files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) - return (written, (files', hs)) + -- only update the offset when we're writing >0 bytes to it + let o' = if BS.length toWrite == 0 + then o + else Just (fromIntegral (BS.length file')) + return (written, (files', hs { openPtr = Append o' })) where written = toEnum $ BS.length toWrite @@ -674,8 +703,8 @@ hTruncate h sz = , fsErrorStack = prettyCallStack , fsLimitation = True } - (False, Append) -> - return Append + (False, Append _) -> + return (Append Nothing) let file' = BS.take (fromIntegral sz) file files' <- checkFsTree $ FS.replace openFilePath file' (mockFiles fs) -- TODO: Don't replace the file pointer (not changed) diff --git a/fs-sim/src/System/FS/Sim/Pure.hs b/fs-sim/src/System/FS/Sim/Pure.hs index 4ccd5a8..6c26433 100644 --- a/fs-sim/src/System/FS/Sim/Pure.hs +++ b/fs-sim/src/System/FS/Sim/Pure.hs @@ -29,6 +29,7 @@ pureHasFS = HasFS { , hClose = Mock.hClose , hIsOpen = Mock.hIsOpen , hSeek = Mock.hSeek + , hTell = Mock.hTell , hGetSome = Mock.hGetSome , hGetSomeAt = Mock.hGetSomeAt , hPutSome = Mock.hPutSome diff --git a/fs-sim/src/System/FS/Sim/STM.hs b/fs-sim/src/System/FS/Sim/STM.hs index 1a9ee59..6eefe54 100644 --- a/fs-sim/src/System/FS/Sim/STM.hs +++ b/fs-sim/src/System/FS/Sim/STM.hs @@ -50,6 +50,7 @@ simHasFS var = HasFS { , hClose = sim . Mock.hClose , hIsOpen = sim . Mock.hIsOpen , hSeek = sim ..: Mock.hSeek + , hTell = sim . Mock.hTell , hGetSome = sim .: Mock.hGetSome , hGetSomeAt = sim ..: Mock.hGetSomeAt , hPutSome = sim .: Mock.hPutSome diff --git a/fs-sim/test/Test/System/FS/StateMachine.hs b/fs-sim/test/Test/System/FS/StateMachine.hs index a204f87..3f9c7f3 100644 --- a/fs-sim/test/Test/System/FS/StateMachine.hs +++ b/fs-sim/test/Test/System/FS/StateMachine.hs @@ -89,7 +89,7 @@ import qualified Test.StateMachine.Labelling as C import qualified Test.StateMachine.Sequential as QSM import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 -import Test.Tasty (TestTree, testGroup) +import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.QuickCheck import System.FS.API @@ -143,6 +143,7 @@ data Cmd fp h = | Close h | IsOpen h | Seek h SeekMode Int64 + | Tell h | Get h Word64 | GetAt h Word64 AbsOffset | Put h ByteString @@ -171,6 +172,7 @@ data Success fp h = | ByteString ByteString | Strings (Set String) | Bool Bool + | Offset AbsOffset deriving (Eq, Show, Functor, Foldable) -- | Successful semantics @@ -191,6 +193,7 @@ run hasFS@HasFS{..} = go go (IsOpen h ) = Bool <$> hIsOpen h go (Close h ) = Unit <$> hClose h go (Seek h mode sz ) = Unit <$> hSeek h mode sz + go (Tell h ) = Offset <$> hTell h -- Note: we're not using 'hGetSome', 'hGetSomeAt' and 'hPutSome' that may -- produce partial reads/writes, but wrappers around them that handle -- partial reads/writes, see #502. @@ -500,6 +503,7 @@ generator Model{..} = oneof $ concat [ fmap At $ Close <$> genHandle , fmap At $ IsOpen <$> genHandle , fmap At $ Seek <$> genHandle <*> genSeekMode <*> genOffset + , fmap At $ Tell <$> genHandle , fmap At $ Get <$> genHandle <*> (getSmall <$> arbitrary) , fmap At $ GetAt <$> genHandle <*> (getSmall <$> arbitrary) <*> arbitrary , fmap At $ Put <$> genHandle <*> (BS.pack <$> arbitrary) @@ -811,10 +815,16 @@ data Tag = -- > Put h1 | TagWrite - -- | Seek from end of a file + -- | Seek with a mode -- - -- > Seek h IO.SeekFromEnd n (n<0) - | TagSeekFromEnd + -- > Seek h ... n (n<0) + | TagSeekWithMode SeekMode + + -- | Seek an absolute offset and then tell should return the same offset + -- + -- > Seek h ... n + -- > Tell h ... + | TagSeekTellWithMode SeekMode -- | Create a directory -- @@ -959,7 +969,8 @@ tag = C.classify [ , tagWriteWriteRead Map.empty , tagOpenDirectory Set.empty , tagWrite - , tagSeekFromEnd + , tagSeekWithMode + , tagSeekTellWithMode Map.empty , tagCreateDirectory , tagDoesFileExistOK , tagDoesFileExistKO @@ -1183,11 +1194,27 @@ tag = C.classify [ Left TagWrite _otherwise -> Right tagWrite - tagSeekFromEnd :: EventPred - tagSeekFromEnd = successful $ \ev _ -> + tagSeekWithMode :: EventPred + tagSeekWithMode = successful $ \ev _ -> + case eventMockCmd ev of + Seek _ m n | (m == AbsoluteSeek && n > 0) + || (m == SeekFromEnd && n < 0) + || n /= 0 -> + Left (TagSeekWithMode m) + _otherwise -> + Right tagSeekWithMode + + tagSeekTellWithMode :: Map HandleMock SeekMode -> EventPred + tagSeekTellWithMode seek = successful $ \ev _suc -> case eventMockCmd ev of - Seek _ SeekFromEnd n | n < 0 -> Left TagSeekFromEnd - _otherwise -> Right tagSeekFromEnd + Seek (Handle h _) m n | (m == AbsoluteSeek && n > 0) + || (m == SeekFromEnd && n < 0) + || n /= 0 -> + Right $ tagSeekTellWithMode (Map.insert h m seek) + Tell (Handle h _) | Just m <- Map.lookup h seek -> + Left (TagSeekTellWithMode m) + _otherwise -> + Right $ tagSeekTellWithMode seek tagCreateDirectory :: EventPred tagCreateDirectory = successful $ \ev _ -> @@ -1438,7 +1465,7 @@ showLabelledExamples :: IO () showLabelledExamples = showLabelledExamples' Nothing 1000 (const True) prop_sequential :: FilePath -> Property -prop_sequential tmpDir = withMaxSuccess 10000 $ +prop_sequential tmpDir = QSM.forAllCommands (sm mountUnused) Nothing $ \cmds -> QC.monadicIO $ do (tstTmpDir, hist, res) <- QC.run $ withTempDirectory tmpDir "HasFS" $ \tstTmpDir -> do @@ -1453,13 +1480,16 @@ prop_sequential tmpDir = withMaxSuccess 10000 $ return (tstTmpDir, hist, res) QSM.prettyCommands (sm mountUnused) hist + $ QSM.checkCommandNames cmds $ tabulate "Tags" (map show $ tag (execCmds cmds)) $ counterexample ("Mount point: " ++ tstTmpDir) $ res === QSM.Ok tests :: FilePath -> TestTree tests tmpDir = testGroup "HasFS" [ - testProperty "q-s-m" $ prop_sequential tmpDir + localOption (QuickCheckTests 10000) + $ localOption (QuickCheckMaxSize 500) + $ testProperty "q-s-m" $ prop_sequential tmpDir ] -- | Unused mount mount @@ -1513,6 +1543,7 @@ instance (Condense fp, Condense h) => Condense (Cmd fp h) where go (Close h) = ["close", condense h] go (IsOpen h) = ["isOpen", condense h] go (Seek h mode o) = ["seek", condense h, condense mode, condense o] + go (Tell h) = ["tell", condense h] go (Get h n) = ["get", condense h, condense n] go (GetAt h n o) = ["getAt", condense h, condense n, condense o] go (Put h bs) = ["put", condense h, condense bs]