From 62e07b8a423a78556e2f5d86d1affe7cca4c8896 Mon Sep 17 00:00:00 2001 From: Marios Titas Date: Sun, 12 Aug 2012 15:46:22 -0400 Subject: Add functions for setting file times with high resolution --- System/Posix/Files.hsc | 63 ++++++++++++++++++++- System/Posix/Files/ByteString.hsc | 64 ++++++++++++++++++++- System/Posix/Files/Common.hsc | 113 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 236 insertions(+), 4 deletions(-) (limited to 'System') diff --git a/System/Posix/Files.hsc b/System/Posix/Files.hsc index cb9663c..6849a9b 100644 --- a/System/Posix/Files.hsc +++ b/System/Posix/Files.hsc @@ -81,7 +81,9 @@ module System.Posix.Files ( #endif -- * Changing file timestamps - setFileTimes, touchFile, + setFileTimes, setFileTimesHiRes, + setFdTimesHiRes, setSymbolicLinkTimesHiRes, + touchFile, touchFd, touchSymbolicLink, -- * Setting file sizes setFileSize, setFdSize, @@ -120,6 +122,8 @@ peekFilePathLen :: CStringLen -> IO FilePath peekFilePathLen = peekCStringLen #endif +import Data.Time.Clock.POSIX + -- ----------------------------------------------------------------------------- -- chmod() @@ -343,7 +347,7 @@ foreign import ccall unsafe "lchown" #endif -- ----------------------------------------------------------------------------- --- utime() +-- Setting file times -- | @setFileTimes path atime mtime@ sets the access and modification times -- associated with file @path@ to @atime@ and @mtime@, respectively. @@ -357,6 +361,46 @@ setFileTimes name atime mtime = do (#poke struct utimbuf, modtime) p mtime throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p) +-- | Like 'setFileTimes' but timestamps can have sub-second resolution. +-- +-- Note: calls @utimensat@ or @utimes@. +setFileTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () +#ifdef HAVE_UTIMENSAT +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times 0 +#else +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times) +#endif + +-- | Like 'setFileTimesHiRes' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @utimensat@ or @lutimes@. +setSymbolicLinkTimesHiRes :: FilePath -> POSIXTime -> POSIXTime -> IO () +#if HAVE_UTIMENSAT +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW) +#elif HAVE_LUTIMES +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_lutimes s times +#else +setSymbolicLinkTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + -- | @touchFile path@ sets the access and modification times associated with -- file @path@ to the current time. -- @@ -366,6 +410,21 @@ touchFile name = do withFilePath name $ \s -> throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) +-- | Like 'touchFile' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @lutimes@. +touchSymbolicLink :: FilePath -> IO () +#if HAVE_LUTIMES +touchSymbolicLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr) +#else +touchSymbolicLink = + error "touchSymbolicLink: not available on this platform" +#endif + -- ----------------------------------------------------------------------------- -- Setting file sizes diff --git a/System/Posix/Files/ByteString.hsc b/System/Posix/Files/ByteString.hsc index cb183ff..d641fb9 100644 --- a/System/Posix/Files/ByteString.hsc +++ b/System/Posix/Files/ByteString.hsc @@ -79,7 +79,9 @@ module System.Posix.Files.ByteString ( #endif -- * Changing file timestamps - setFileTimes, touchFile, + setFileTimes, setFileTimesHiRes, + setFdTimesHiRes, setSymbolicLinkTimesHiRes, + touchFile, touchFd, touchSymbolicLink, -- * Setting file sizes setFileSize, setFdSize, @@ -102,6 +104,8 @@ import Foreign.C hiding ( import System.Posix.Files.Common import System.Posix.ByteString.FilePath +import Data.Time.Clock.POSIX + -- ----------------------------------------------------------------------------- -- chmod() @@ -116,6 +120,7 @@ setFileMode name m = withFilePath name $ \s -> do throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) + -- ----------------------------------------------------------------------------- -- access() @@ -325,7 +330,7 @@ foreign import ccall unsafe "lchown" #endif -- ----------------------------------------------------------------------------- --- utime() +-- Setting file times -- | @setFileTimes path atime mtime@ sets the access and modification times -- associated with file @path@ to @atime@ and @mtime@, respectively. @@ -339,6 +344,46 @@ setFileTimes name atime mtime = do (#poke struct utimbuf, modtime) p mtime throwErrnoPathIfMinus1_ "setFileTimes" name (c_utime s p) +-- | Like 'setFileTimes' but timestamps can have sub-second resolution. +-- +-- Note: calls @utimensat@ or @utimes@. +setFileTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO () +#ifdef HAVE_UTIMENSAT +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times 0 +#else +setFileTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setFileTimesHiRes" name (c_utimes s times) +#endif + +-- | Like 'setFileTimesHiRes' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @utimensat@ or @lutimes@. +setSymbolicLinkTimesHiRes :: RawFilePath -> POSIXTime -> POSIXTime -> IO () +#if HAVE_UTIMENSAT +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_utimensat (#const AT_FDCWD) s times (#const AT_SYMLINK_NOFOLLOW) +#elif HAVE_LUTIMES +setSymbolicLinkTimesHiRes name atime mtime = + withFilePath name $ \s -> + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoPathIfMinus1_ "setSymbolicLinkTimesHiRes" name $ + c_lutimes s times +#else +setSymbolicLinkTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + -- | @touchFile path@ sets the access and modification times associated with -- file @path@ to the current time. -- @@ -348,6 +393,21 @@ touchFile name = do withFilePath name $ \s -> throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) +-- | Like 'touchFile' but does not follow symbolic links. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @lutimes@. +touchSymbolicLink :: RawFilePath -> IO () +#if HAVE_LUTIMES +touchSymbolicLink name = + withFilePath name $ \s -> + throwErrnoPathIfMinus1_ "touchSymbolicLink" name (c_lutimes s nullPtr) +#else +touchSymbolicLink = + error "touchSymbolicLink: not available on this platform" +#endif + -- ----------------------------------------------------------------------------- -- Setting file sizes diff --git a/System/Posix/Files/Common.hsc b/System/Posix/Files/Common.hsc index cdbd07f..ad52030 100644 --- a/System/Posix/Files/Common.hsc +++ b/System/Posix/Files/Common.hsc @@ -55,6 +55,7 @@ module System.Posix.Files.Common ( specialDeviceID, fileSize, accessTime, modificationTime, statusChangeTime, accessTimeHiRes, modificationTimeHiRes, statusChangeTimeHiRes, + setFdTimesHiRes, touchFd, isBlockDevice, isCharacterDevice, isNamedPipe, isRegularFile, isDirectory, isSymbolicLink, isSocket, @@ -66,6 +67,19 @@ module System.Posix.Files.Common ( -- * Find system-specific limits for a file PathVar(..), getFdPathVar, pathVarConst, + + -- * Low level types and functions +#ifdef HAVE_UTIMENSAT + CTimeSpec(..), + toCTimeSpec, + c_utimensat, +#endif + CTimeVal(..), + toCTimeVal, + c_utimes, +#ifdef HAVE_LUTIMES + c_lutimes, +#endif ) where import System.Posix.Error @@ -379,6 +393,105 @@ getFdStatus (Fd fd) = do throwErrnoIfMinus1_ "getFdStatus" (c_fstat fd p) return (FileStatus fp) +-- ----------------------------------------------------------------------------- +-- Setting file times + +#if HAVE_UTIMENSAT || HAVE_FUTIMENS +data CTimeSpec = CTimeSpec EpochTime CLong + +instance Storable CTimeSpec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CInt) + poke p (CTimeSpec sec nsec) = do + (#poke struct timespec, tv_sec ) p sec + (#poke struct timespec, tv_nsec) p nsec + peek p = do + sec <- #{peek struct timespec, tv_sec } p + nsec <- #{peek struct timespec, tv_nsec} p + return $ CTimeSpec sec nsec + +toCTimeSpec :: POSIXTime -> CTimeSpec +toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^9 * frac) + where + (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') + (sec', frac') = properFraction $ toRational t +#endif + +#ifdef HAVE_UTIMENSAT +foreign import ccall unsafe "utimensat" + c_utimensat :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt +#endif + +#if HAVE_FUTIMENS +foreign import ccall unsafe "futimens" + c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt +#endif + +data CTimeVal = CTimeVal CLong CLong + +instance Storable CTimeVal where + sizeOf _ = #size struct timeval + alignment _ = alignment (undefined :: CInt) + poke p (CTimeVal sec usec) = do + (#poke struct timeval, tv_sec ) p sec + (#poke struct timeval, tv_usec) p usec + peek p = do + sec <- #{peek struct timeval, tv_sec } p + usec <- #{peek struct timeval, tv_usec} p + return $ CTimeVal sec usec + +toCTimeVal :: POSIXTime -> CTimeVal +toCTimeVal t = CTimeVal sec (truncate $ 10^6 * frac) + where + (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') + (sec', frac') = properFraction $ toRational t + +foreign import ccall unsafe "utimes" + c_utimes :: CString -> Ptr CTimeVal -> IO CInt + +#ifdef HAVE_LUTIMES +foreign import ccall unsafe "lutimes" + c_lutimes :: CString -> Ptr CTimeVal -> IO CInt +#endif + +#if HAVE_FUTIMES +foreign import ccall unsafe "futimes" + c_futimes :: CInt -> Ptr CTimeVal -> IO CInt +#endif + +-- | Like 'setFileTimesHiRes' but uses a file descriptor instead of a path. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @futimens@ or @futimes@. +setFdTimesHiRes :: Fd -> POSIXTime -> POSIXTime -> IO () +#if HAVE_FUTIMENS +setFdTimesHiRes (Fd fd) atime mtime = + withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> + throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) +#elif HAVE_FUTIMES +setFdTimesHiRes (Fd fd) atime mtime = + withArray [toCTimeVal atime, toCTimeVal mtime] $ \times -> + throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimes fd times) +#else +setFdTimesHiRes = + error "setSymbolicLinkTimesHiRes: not available on this platform" +#endif + +-- | Like 'touchFile' but uses a file descriptor instead of a path. +-- This operation is not supported on all platforms. On these platforms, +-- this function will raise an exception. +-- +-- Note: calls @futimes@. +touchFd :: Fd -> IO () +#if HAVE_FUTIMES +touchFd (Fd fd) = + throwErrnoIfMinus1_ "touchFd" (c_futimes fd nullPtr) +#else +touchFd = + error "touchFd: not available on this platform" +#endif + -- ----------------------------------------------------------------------------- -- fchown() -- cgit v1.2.3