{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Distribution.Compat.Time
       ( ModTime(..) -- Needed for testing
       , getModTime, getFileAge, getCurTime
       , posixSecondsToModTime
       , calibrateMtimeChangeDelay )
       where

import Prelude ()
import Distribution.Compat.Prelude

import System.Directory ( getModificationTime )

import Distribution.Simple.Utils ( withTempDirectory )
import Distribution.Verbosity ( silent )

import System.FilePath

import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )
import Data.Time             ( diffUTCTime, getCurrentTime )
import Data.Time.Clock.POSIX ( posixDayLength )


#if defined mingw32_HOST_OS

import qualified Prelude
import Data.Bits          ((.|.), unsafeShiftL)
#if MIN_VERSION_base(4,7,0)
import Data.Bits          (finiteBitSize)
#else
import Data.Bits          (bitSize)
#endif

import Foreign            ( allocaBytes, peekByteOff )
import System.IO.Error    ( mkIOError, doesNotExistErrorType )
import System.Win32.Types ( BOOL, DWORD, LPCTSTR, LPVOID, withTString )

#else

import System.Posix.Files ( FileStatus, getFileStatus )

#if MIN_VERSION_unix(2,6,0)
import System.Posix.Files ( modificationTimeHiRes )
#else
import System.Posix.Files ( modificationTime )
#endif

#endif

-- | An opaque type representing a file's modification time, represented
-- internally as a 64-bit unsigned integer in the Windows UTC format.
newtype ModTime = ModTime Word64
                deriving (Get ModTime
[ModTime] -> Put
ModTime -> Put
(ModTime -> Put)
-> Get ModTime -> ([ModTime] -> Put) -> Binary ModTime
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [ModTime] -> Put
$cputList :: [ModTime] -> Put
get :: Get ModTime
$cget :: Get ModTime
put :: ModTime -> Put
$cput :: ModTime -> Put
Binary, ModTime
ModTime -> ModTime -> Bounded ModTime
forall a. a -> a -> Bounded a
maxBound :: ModTime
$cmaxBound :: ModTime
minBound :: ModTime
$cminBound :: ModTime
Bounded, ModTime -> ModTime -> Bool
(ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> Bool) -> Eq ModTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModTime -> ModTime -> Bool
$c/= :: ModTime -> ModTime -> Bool
== :: ModTime -> ModTime -> Bool
$c== :: ModTime -> ModTime -> Bool
Eq, Eq ModTime
Eq ModTime
-> (ModTime -> ModTime -> Ordering)
-> (ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> ModTime)
-> (ModTime -> ModTime -> ModTime)
-> Ord ModTime
ModTime -> ModTime -> Bool
ModTime -> ModTime -> Ordering
ModTime -> ModTime -> ModTime
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModTime -> ModTime -> ModTime
$cmin :: ModTime -> ModTime -> ModTime
max :: ModTime -> ModTime -> ModTime
$cmax :: ModTime -> ModTime -> ModTime
>= :: ModTime -> ModTime -> Bool
$c>= :: ModTime -> ModTime -> Bool
> :: ModTime -> ModTime -> Bool
$c> :: ModTime -> ModTime -> Bool
<= :: ModTime -> ModTime -> Bool
$c<= :: ModTime -> ModTime -> Bool
< :: ModTime -> ModTime -> Bool
$c< :: ModTime -> ModTime -> Bool
compare :: ModTime -> ModTime -> Ordering
$ccompare :: ModTime -> ModTime -> Ordering
$cp1Ord :: Eq ModTime
Ord)

instance Show ModTime where
  show :: ModTime -> String
show (ModTime Word64
x) = Word64 -> String
forall a. Show a => a -> String
show Word64
x

instance Read ModTime where
  readsPrec :: Int -> ReadS ModTime
readsPrec Int
p String
str = ((Word64, String) -> (ModTime, String))
-> [(Word64, String)] -> [(ModTime, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Word64 -> ModTime) -> (Word64, String) -> (ModTime, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Word64 -> ModTime
ModTime) (Int -> ReadS Word64
forall a. Read a => Int -> ReadS a
readsPrec Int
p String
str)

-- | Return modification time of the given file. Works around the low clock
-- resolution problem that 'getModificationTime' has on GHC < 7.8.
--
-- This is a modified version of the code originally written for Shake by Neil
-- Mitchell. See module Development.Shake.FileInfo.
getModTime :: FilePath -> NoCallStackIO ModTime

#if defined mingw32_HOST_OS

-- Directly against the Win32 API.
getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
  res <- getFileAttributesEx path info
  if not res
    then do
      let err = mkIOError doesNotExistErrorType
                "Distribution.Compat.Time.getModTime"
                Nothing (Just path)
      ioError err
    else do
      dwLow  <- peekByteOff info
                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime
      dwHigh <- peekByteOff info
                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime
#if MIN_VERSION_base(4,7,0)
      let qwTime =
            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)
            .|. (fromIntegral (dwLow :: DWORD))
#else
      let qwTime =
            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh)
            .|. (fromIntegral (dwLow :: DWORD))
#endif
      return $! ModTime (qwTime :: Word64)

#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif

foreign import CALLCONV "windows.h GetFileAttributesExW"
  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL

getFileAttributesEx :: String -> LPVOID -> NoCallStackIO BOOL
getFileAttributesEx path lpFileInformation =
  withTString path $ \c_path ->
      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation

getFileExInfoStandard :: Int32
getFileExInfoStandard = 0

size_WIN32_FILE_ATTRIBUTE_DATA :: Int
size_WIN32_FILE_ATTRIBUTE_DATA = 36

index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20

index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int
index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24

#else

-- Directly against the unix library.
getModTime :: String -> NoCallStackIO ModTime
getModTime String
path = do
    FileStatus
st <- String -> IO FileStatus
getFileStatus String
path
    ModTime -> NoCallStackIO ModTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ModTime -> NoCallStackIO ModTime)
-> ModTime -> NoCallStackIO ModTime
forall a b. (a -> b) -> a -> b
$! (FileStatus -> ModTime
extractFileTime FileStatus
st)

extractFileTime :: FileStatus -> ModTime
extractFileTime :: FileStatus -> ModTime
extractFileTime FileStatus
x = POSIXTime -> ModTime
posixTimeToModTime (FileStatus -> POSIXTime
modificationTimeHiRes FileStatus
x)

#endif

windowsTick, secToUnixEpoch :: Word64
windowsTick :: Word64
windowsTick    = Word64
10000000
secToUnixEpoch :: Word64
secToUnixEpoch = Word64
11644473600

-- | Convert POSIX seconds to ModTime.
posixSecondsToModTime :: Int64 -> ModTime
posixSecondsToModTime :: Int64 -> ModTime
posixSecondsToModTime Int64
s =
  Word64 -> ModTime
ModTime (Word64 -> ModTime) -> Word64 -> ModTime
forall a b. (a -> b) -> a -> b
$ ((Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
s :: Word64) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
secToUnixEpoch) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
windowsTick

-- | Convert 'POSIXTime' to 'ModTime'.
posixTimeToModTime :: POSIXTime -> ModTime
posixTimeToModTime :: POSIXTime -> ModTime
posixTimeToModTime POSIXTime
p = Word64 -> ModTime
ModTime (Word64 -> ModTime) -> Word64 -> ModTime
forall a b. (a -> b) -> a -> b
$ (POSIXTime -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (POSIXTime -> Word64) -> POSIXTime -> Word64
forall a b. (a -> b) -> a -> b
$ POSIXTime
p POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1e7) -- 100 ns precision
                       Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
secToUnixEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
windowsTick)

-- | Return age of given file in days.
getFileAge :: FilePath -> NoCallStackIO Double
getFileAge :: String -> NoCallStackIO Double
getFileAge String
file = do
  UTCTime
t0 <- String -> IO UTCTime
getModificationTime String
file
  UTCTime
t1 <- IO UTCTime
getCurrentTime
  Double -> NoCallStackIO Double
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> NoCallStackIO Double) -> Double -> NoCallStackIO Double
forall a b. (a -> b) -> a -> b
$ POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime
t1 UTCTime -> UTCTime -> POSIXTime
`diffUTCTime` UTCTime
t0) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac POSIXTime
posixDayLength

-- | Return the current time as 'ModTime'.
getCurTime :: NoCallStackIO ModTime
getCurTime :: NoCallStackIO ModTime
getCurTime = POSIXTime -> ModTime
posixTimeToModTime (POSIXTime -> ModTime) -> IO POSIXTime -> NoCallStackIO ModTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO POSIXTime
getPOSIXTime -- Uses 'gettimeofday'.

-- | Based on code written by Neil Mitchell for Shake. See
-- 'sleepFileTimeCalibrate' in 'Test.Type'.  Returns a pair
-- of microsecond values: first, the maximum delay seen, and the
-- recommended delay to use before testing for file modification change.
-- The returned delay is never smaller
-- than 10 ms, but never larger than 1 second.
calibrateMtimeChangeDelay :: IO (Int, Int)
calibrateMtimeChangeDelay :: IO (Int, Int)
calibrateMtimeChangeDelay =
  Verbosity
-> String -> String -> (String -> IO (Int, Int)) -> IO (Int, Int)
forall a. Verbosity -> String -> String -> (String -> IO a) -> IO a
withTempDirectory Verbosity
silent String
"." String
"calibration-" ((String -> IO (Int, Int)) -> IO (Int, Int))
-> (String -> IO (Int, Int)) -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
    let fileName :: String
fileName = String
dir String -> ShowS
</> String
"probe"
    [Int]
mtimes <- [Int] -> (Int -> IO Int) -> IO [Int]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int
1..Int
25] ((Int -> IO Int) -> IO [Int]) -> (Int -> IO Int) -> IO [Int]
forall a b. (a -> b) -> a -> b
$ \(Int
i::Int) -> IO () -> IO Int
time (IO () -> IO Int) -> IO () -> IO Int
forall a b. (a -> b) -> a -> b
$ do
      String -> String -> IO ()
writeFile String
fileName (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i
      ModTime
t0 <- String -> NoCallStackIO ModTime
getModTime String
fileName
      let spin :: t -> IO ()
spin t
j = do
            String -> String -> IO ()
writeFile String
fileName (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int, t) -> String
forall a. Show a => a -> String
show (Int
i,t
j)
            ModTime
t1 <- String -> NoCallStackIO ModTime
getModTime String
fileName
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModTime
t0 ModTime -> ModTime -> Bool
forall a. Ord a => a -> a -> Bool
< ModTime
t1) (t -> IO ()
spin (t -> IO ()) -> t -> IO ()
forall a b. (a -> b) -> a -> b
$ t
j t -> t -> t
forall a. Num a => a -> a -> a
+ t
1)
      Int -> IO ()
forall t. (Show t, Num t) => t -> IO ()
spin (Int
0::Int)
    let mtimeChange :: Int
mtimeChange  = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
mtimes
        mtimeChange' :: Int
mtimeChange' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1000000 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
10000 Int
mtimeChange) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
mtimeChange, Int
mtimeChange')
  where
    time :: IO () -> IO Int
    time :: IO () -> IO Int
time IO ()
act = do
      UTCTime
t0 <- IO UTCTime
getCurrentTime
      IO ()
IO ()
act
      UTCTime
t1 <- IO UTCTime
getCurrentTime
      Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> (POSIXTime -> Int) -> POSIXTime -> IO Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (POSIXTime -> IO Int) -> POSIXTime -> IO Int
forall a b. (a -> b) -> a -> b
$! (UTCTime
t1 UTCTime -> UTCTime -> POSIXTime
`diffUTCTime` UTCTime
t0) POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
1e6 -- microseconds