Add functions for setting file times with high resolution

3 files changed, 236 insertions, 4 deletions

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
@@ -380,6 +394,105 @@ getFdStatus (Fd fd) = do
   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()
 
 -- | Acts as 'setOwnerAndGroup' but uses a file descriptor instead of a