Implement setModificationTime (and rewrite getModificationTime)

The unix package does not have a general setFileTimesHiRes that allowed
setting mtime separately from atime.  Therefore, we import the foreign
utimensat function in the new Internal module (hsc), which also involves
implementing struct timespec.

Fixes haskell#13.

System/Directory.hs

@@ -80,6 +80,7 @@ module System.Directory
     -- * Timestamps
 
     , getModificationTime
+    , setModificationTime
 
    ) where
 import Control.Exception ( bracket, bracketOnError )
@@ -118,7 +119,13 @@ import Foreign.C
 {-# CFILES cbits/directory.c #-}
 
 import Data.Time ( UTCTime )
-import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import Data.Time.Clock.POSIX
+  ( posixSecondsToUTCTime
+  , utcTimeToPOSIXSeconds
+#ifdef mingw32_HOST_OS
+  , POSIXTime
+#endif
+  )
 
 #ifdef __GLASGOW_HASKELL__
 
@@ -129,20 +136,29 @@ import System.Posix.Types
 import System.Posix.Internals
 import qualified System.Win32 as Win32
 #else
+#include <HsUnixConfig.h>
 import GHC.IO.Encoding
 import GHC.Foreign as GHC
 import System.Environment ( getEnv )
 import qualified System.Posix as Posix
 #endif
 
+#ifdef HAVE_UTIMENSAT
+import System.Directory.Internal
+import System.Posix.Internals ( withFilePath )
+#endif
+
 #endif /* __GLASGOW_HASKELL__ */
 
 #ifdef mingw32_HOST_OS
 win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL
+win32_fILE_SHARE_DELETE   :: Win32.ShareMode
 #if MIN_VERSION_Win32(2, 3, 1)
 win32_cSIDL_LOCAL_APPDATA = Win32.cSIDL_LOCAL_APPDATA -- only on HEAD atm
+win32_fILE_SHARE_DELETE   = Win32.fILE_SHARE_DELETE   -- added in 2.3.0.2
 #else
 win32_cSIDL_LOCAL_APPDATA = 0x001c
+win32_fILE_SHARE_DELETE   = 0x00000004
 #endif
 #endif
 
@@ -1086,45 +1102,123 @@ doesFileExist name =
 #endif
    `catchIOError` \ _ -> return False
 
-{- |The 'getModificationTime' operation returns the
-clock time at which the file or directory was last modified.
-
-The operation may fail with:
-
-* 'isPermissionError' if the user is not permitted to access
-  the modification time; or
-
-* 'isDoesNotExistError' if the file or directory does not exist.
-
-Note: This function returns a timestamp with sub-second resolution
-only if this package is compiled against @unix-2.6.0.0@ or later
-for unix systems, and @Win32-2.3.1.0@ or later for windows systems.
-Of course this also requires that the underlying file system supports
-such high resolution timestamps.
--}
+#ifdef mingw32_HOST_OS
+-- | Open the handle of an existing file or directory.
+openFileHandle :: String -> Win32.AccessMode -> IO Win32.HANDLE
+openFileHandle path mode = Win32.createFile path mode share Nothing
+                                            Win32.oPEN_EXISTING flags Nothing
+  where share =  win32_fILE_SHARE_DELETE
+             .|. Win32.fILE_SHARE_READ
+             .|. Win32.fILE_SHARE_WRITE
+        flags =  Win32.fILE_ATTRIBUTE_NORMAL
+             .|. Win32.fILE_FLAG_BACKUP_SEMANTICS -- required for directories
+#endif
 
+-- | Obtain the time at which the file or directory was last modified.
+--
+-- The operation may fail with:
+--
+-- * 'isPermissionError' if the user is not permitted to read
+--   the modification time; or
+--
+-- * 'isDoesNotExistError' if the file or directory does not exist.
+--
+-- Caveat for POSIX systems: This function returns a timestamp with sub-second
+-- resolution only if this package is compiled against @unix-2.6.0.0@ or later
+-- and the underlying filesystem supports them.
+--
 getModificationTime :: FilePath -> IO UTCTime
-getModificationTime name = do
+getModificationTime path =
+  modifyIOError (`ioeSetLocation` "getModificationTime") $
+  posixSecondsToUTCTime <$> getTime
+  where
 #ifdef mingw32_HOST_OS
-#if MIN_VERSION_Win32(2,3,1)
-  fad <- Win32.getFileAttributesExStandard name
-  let win32_epoch_adjust = 116444736000000000
-      Win32.FILETIME ft = Win32.fadLastWriteTime fad
-      mod_time = fromIntegral (ft - win32_epoch_adjust) / 10000000
+    getTime =
+      bracket (openFileHandle path Win32.gENERIC_READ)
+              Win32.closeHandle $ \ handle ->
+      alloca $ \ mtime -> do
+        Win32.failIf_ not "" (Win32.c_GetFileTime handle nullPtr nullPtr mtime)
+        windowsToPosixTime <$> peek mtime
 #else
-  mod_time <- withFileStatus "getModificationTime" name $ \stat -> do
-    mtime <- st_mtime stat
-    return $ realToFrac (mtime :: CTime)
+    getTime = convertTime <$> Posix.getFileStatus path
+# if MIN_VERSION_unix(2, 6, 0)
+    convertTime = Posix.modificationTimeHiRes
+# else
+    convertTime = realToFrac . Posix.modificationTime
+# endif
 #endif
+
+-- | Change the time at which the file or directory was last modified.
+--
+-- The operation may fail with:
+--
+-- * 'isPermissionError' if the user is not permitted to alter the
+--   modification time; or
+--
+-- * 'isDoesNotExistError' if the file or directory does not exist.
+--
+-- Some caveats for POSIX systems:
+--
+-- * Not all systems support @utimensat@, in which case the function can only
+--   emulate the behavior by reading the access time and then setting both the
+--   access and modification times together.  On systems where @utimensat@ is
+--   supported, the modification time is set atomically with nanosecond
+--   precision.
+--
+-- * If compiled against a version of @unix@ prior to @2.7.0.0@, the function
+--   would not be able to set timestamps with sub-second resolution.  In this
+--   case, there would also be loss of precision in the access time.
+--
+-- /Since: 1.2.3.0/
+--
+setModificationTime :: FilePath -> UTCTime -> IO ()
+setModificationTime path mtime =
+  modifyIOError (`ioeSetLocation` "setModificationTime") setTime
+  where
+    mtime' = utcTimeToPOSIXSeconds mtime
+#ifdef mingw32_HOST_OS
+    setTime =
+      bracket (openFileHandle path Win32.gENERIC_WRITE)
+              Win32.closeHandle $ \ handle ->
+      with (posixToWindowsTime mtime') $ \ mtime'' ->
+      Win32.failIf_ not "" (Win32.c_SetFileTime handle nullPtr nullPtr mtime'')
+#elif defined HAVE_UTIMENSAT
+    setTime =
+      withFilePath path $ \ path' ->
+      withArray [utimeOmit, toCTimeSpec mtime'] $ \ times ->
+      throwErrnoPathIfMinus1_ "" path $
+      c_utimensat c_AT_FDCWD path' times 0
 #else
-  stat <- Posix.getFileStatus name
-#if MIN_VERSION_unix(2,6,0)
-  let mod_time = Posix.modificationTimeHiRes stat
-#else
-  let mod_time = realToFrac $ Posix.modificationTime stat
+    setTime = do
+      stat <- Posix.getFileStatus path
+      setFileTimes path (accessTime stat) (convertTime mtime')
+# if MIN_VERSION_unix(2, 7, 0)
+    accessTime   = Posix.accessTimeHiRes
+    setFileTimes = Posix.setFileTimesHiRes
+    convertTime  = id
+#  else
+    accessTime   = Posix.accessTime
+    setFileTimes = Posix.setFileTimes
+    convertTime  = fromInteger . truncate
+# endif
 #endif
+
+#ifdef mingw32_HOST_OS
+-- | Difference between the Windows and POSIX epochs in units of 100ns.
+windowsPosixEpochDifference :: Num a => a
+windowsPosixEpochDifference = 116444736000000000
+
+-- | Convert from Windows time to POSIX time.
+windowsToPosixTime :: Win32.FILETIME -> POSIXTime
+windowsToPosixTime (Win32.FILETIME t) =
+  (fromIntegral t - windowsPosixEpochDifference) / 10000000
+
+-- | Convert from POSIX time to Windows time.  This is lossy as Windows time
+--   has a resolution of only 100ns.
+posixToWindowsTime :: POSIXTime -> Win32.FILETIME
+posixToWindowsTime t = Win32.FILETIME $
+  truncate (t * 10000000 + windowsPosixEpochDifference)
 #endif
-  return $ posixSecondsToUTCTime mod_time
 
 #endif /* __GLASGOW_HASKELL__ */
 

System/Directory/Internal.hsc

@@ -0,0 +1,46 @@
+module System.Directory.Internal where
+
+#ifndef mingw32_HOST_OS
+# include <HsUnixConfig.h>
+#endif
+
+#ifdef HAVE_UTIMENSAT
+# include <fcntl.h>
+# include <sys/stat.h>
+import Data.Time.Clock.POSIX (POSIXTime)
+import Foreign
+import Foreign.C
+import System.Posix.Types
+#endif
+
+#ifdef HAVE_UTIMENSAT
+
+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)
+
+c_AT_FDCWD :: Integral a => a
+c_AT_FDCWD = (#const AT_FDCWD)
+
+utimeOmit :: CTimeSpec
+utimeOmit = CTimeSpec (CTime 0) (#const UTIME_OMIT)
+
+toCTimeSpec :: POSIXTime -> CTimeSpec
+toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10 ^ (9 :: Int) * frac)
+  where
+    (sec,  frac)  = if frac' < 0 then (sec' - 1, frac' + 1) else (sec', frac')
+    (sec', frac') = properFraction (toRational t)
+
+foreign import ccall unsafe "utimensat" c_utimensat
+  :: CInt -> CString -> Ptr CTimeSpec -> CInt -> IO CInt
+
+#endif // HAVE_UTIMENSAT

changelog.md

@@ -1,11 +1,14 @@
 Changelog for the [`directory`][1] package
 ==========================================
 
-## 1.2.3.0 (May 2015)
+## 1.2.3.0 (June 2015)
 
   * Add support for XDG Base Directory Specification
     ([#6](https://github.com/haskell/directory/issues/6))
 
+  * Implement `setModificationTime` counterpart to `getModificationTime`
+    ([#13](https://github.com/haskell/directory/issues/13))
+
 ## 1.2.2.1 (Apr 2015)
 
   * Fix dependency problem on NixOS when building with tests

directory.cabal

@@ -62,6 +62,8 @@ Library
 
     exposed-modules:
         System.Directory
+    other-modules:
+        System.Directory.Internal
 
     c-sources:
         cbits/directory.c