Cabal/src/Distribution/Compat/Time.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE RankNTypes #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8
   9 module Distribution.Compat.Time
  10   ( ModTime (..) -- Needed for testing
  11   , getModTime
  12   , getFileAge
  13   , getCurTime
  14   , posixSecondsToModTime
  15   , calibrateMtimeChangeDelay
  16   )
  17 where
  18
  19 import Distribution.Compat.Prelude
  20 import Prelude ()
  21
  22 import System.Directory (getModificationTime)
  23
  24 import Distribution.Simple.Utils (withTempDirectory)
  25 import Distribution.Verbosity (silent)
  26
  27 import System.FilePath
  28
  29 import Data.Time (diffUTCTime, getCurrentTime)
  30 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)
  31
  32 #if defined mingw32_HOST_OS
  33
  34 import qualified Prelude
  35 import Data.Bits          ((.|.), unsafeShiftL)
  36 #if MIN_VERSION_base(4,7,0)
  37 import Data.Bits          (finiteBitSize)
  38 #else
  39 import Data.Bits          (bitSize)
  40 #endif
  41
  42 import Foreign            ( allocaBytes, peekByteOff )
  43 import System.IO.Error    ( mkIOError, doesNotExistErrorType )
  44 import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )
  45
  46 #else
  47
  48 import System.Posix.Files ( FileStatus, getFileStatus )
  49
  50 #if MIN_VERSION_unix(2,6,0)
  51 import System.Posix.Files ( modificationTimeHiRes )
  52 #else
  53 import System.Posix.Files ( modificationTime )
  54 #endif
  55
  56 #endif
  57
  58 -- | An opaque type representing a file's modification time, represented
  59 -- internally as a 64-bit unsigned integer in the Windows UTC format.
  60 newtype ModTime = ModTime Word64
  61   deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)
  62
  63 instance Structured ModTime
  64
  65 instance Show ModTime where
  66   show (ModTime x) = show x
  67
  68 instance Read ModTime where
  69   readsPrec p str = map (first ModTime) (readsPrec p str)
  70
  71 -- | Return modification time of the given file. Works around the low clock
  72 -- resolution problem that 'getModificationTime' has on GHC < 7.8.
  73 --
  74 -- This is a modified version of the code originally written for Shake by Neil
  75 -- Mitchell. See module Development.Shake.FileInfo.
  76 getModTime :: FilePath -> IO ModTime
  77
  78 #if defined mingw32_HOST_OS
  79
  80 -- Directly against the Win32 API.
  81 getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
  82   res <- getFileAttributesEx path info
  83   if not res
  84     then do
  85       let err = mkIOError doesNotExistErrorType
  86                 "Distribution.Compat.Time.getModTime"
  87                 Nothing (Just path)
  88       ioError err
  89     else do
  90       dwLow  <- peekByteOff info
  91                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime
  92       dwHigh <- peekByteOff info
  93                 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime
  94 #if MIN_VERSION_base(4,7,0)
  95       let qwTime =
  96             (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)
  97             .|. (fromIntegral (dwLow :: DWORD))
  98 #else
  99       let qwTime =
 100             (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)
 101             .|. (fromIntegral (dwLow :: DWORD))
 102 #endif
 103       return $! ModTime (qwTime :: Word64)
 104
 105 {- FOURMOLU_DISABLE -}
 106 #ifdef x86_64_HOST_ARCH
 107 #define CALLCONV ccall
 108 #else
 109 #define CALLCONV stdcall
 110 #endif
 111
 112 foreign import CALLCONV "windows.h GetFileAttributesExW"
 113   c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL
 114
 115 getFileAttributesEx :: String -> LPVOID -> IO BOOL
 116 getFileAttributesEx path lpFileInformation =
 117   withTString path $ \c_path ->
 118       c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation
 119
 120 getFileExInfoStandard :: Int32
 121 getFileExInfoStandard = 0
 122
 123 size_WIN32_FILE_ATTRIBUTE_DATA :: Int
 124 size_WIN32_FILE_ATTRIBUTE_DATA = 36
 125
 126 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int
 127 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20
 128
 129 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int
 130 index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24
 131
 132 #else
 133
 134 -- Directly against the unix library.
 135 getModTime path = do
 136     st <- getFileStatus path
 137     return $! (extractFileTime st)
 138
 139 extractFileTime :: FileStatus -> ModTime
 140 extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)
 141
 142 #endif
 143 {- FOURMOLU_ENABLE -}
 144
 145 windowsTick, secToUnixEpoch :: Word64
 146 windowsTick = 10000000
 147 secToUnixEpoch = 11644473600
 148
 149 -- | Convert POSIX seconds to ModTime.
 150 posixSecondsToModTime :: Int64 -> ModTime
 151 posixSecondsToModTime s =
 152   ModTime $ ((fromIntegral s :: Word64) + secToUnixEpoch) * windowsTick
 153
 154 -- | Convert 'POSIXTime' to 'ModTime'.
 155 posixTimeToModTime :: POSIXTime -> ModTime
 156 posixTimeToModTime p =
 157   ModTime $
 158     ceiling (p * 1e7) -- 100 ns precision
 159       + (secToUnixEpoch * windowsTick)
 160
 161 -- | Return age of given file in days.
 162 getFileAge :: FilePath -> IO Double
 163 getFileAge file = do
 164   t0 <- getModificationTime file
 165   t1 <- getCurrentTime
 166   return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength
 167
 168 -- | Return the current time as 'ModTime'.
 169 getCurTime :: IO ModTime
 170 getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
 171
 172 -- | Based on code written by Neil Mitchell for Shake. See
 173 -- 'sleepFileTimeCalibrate' in 'Test.Type'.  Returns a pair
 174 -- of microsecond values: first, the maximum delay seen, and the
 175 -- recommended delay to use before testing for file modification change.
 176 -- The returned delay is never smaller
 177 -- than 10 ms, but never larger than 1 second.
 178 calibrateMtimeChangeDelay :: IO (Int, Int)
 179 calibrateMtimeChangeDelay =
 180   withTempDirectory silent "." "calibration-" $ \dir -> do
 181     let fileName = dir </> "probe"
 182     mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do
 183       writeFile fileName $ show i
 184       t0 <- getModTime fileName
 185       let spin j = do
 186             writeFile fileName $ show (i, j)
 187             t1 <- getModTime fileName
 188             unless (t0 < t1) (spin $ j + 1)
 189       spin (0 :: Int)
 190     let mtimeChange = maximum mtimes
 191         mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2
 192     return (mtimeChange, mtimeChange')
 193   where
 194     time :: IO () -> IO Int
 195     time act = do
 196       t0 <- getCurrentTime
 197       act
 198       t1 <- getCurrentTime
 199       return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds