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

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

import Distribution.Compat.Prelude
import Prelude ()

import System.Directory (getModificationTime)

import Distribution.Simple.Utils (withTempDirectoryCwd)
import Distribution.Utils.Path (getSymbolicPath, sameDirectory)
import Distribution.Verbosity (silent)

import System.FilePath

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

#if defined mingw32_HOST_OS

import qualified Prelude
import Data.Bits          ((.|.), unsafeShiftL)
import Data.Bits          (finiteBitSize)

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
$cput :: ModTime -> Put
put :: ModTime -> Put
$cget :: Get ModTime
get :: Get ModTime
$cputList :: [ModTime] -> Put
putList :: [ModTime] -> Put
Binary, (forall x. ModTime -> Rep ModTime x)
-> (forall x. Rep ModTime x -> ModTime) -> Generic ModTime
forall x. Rep ModTime x -> ModTime
forall x. ModTime -> Rep ModTime x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ModTime -> Rep ModTime x
from :: forall x. ModTime -> Rep ModTime x
$cto :: forall x. Rep ModTime x -> ModTime
to :: forall x. Rep ModTime x -> ModTime
Generic, ModTime
ModTime -> ModTime -> Bounded ModTime
forall a. a -> a -> Bounded a
$cminBound :: ModTime
minBound :: ModTime
$cmaxBound :: ModTime
maxBound :: ModTime
Bounded, ModTime -> ModTime -> Bool
(ModTime -> ModTime -> Bool)
-> (ModTime -> ModTime -> Bool) -> Eq ModTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModTime -> ModTime -> Bool
== :: ModTime -> ModTime -> Bool
$c/= :: ModTime -> ModTime -> Bool
/= :: 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
$ccompare :: ModTime -> ModTime -> Ordering
compare :: ModTime -> ModTime -> Ordering
$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
>= :: ModTime -> ModTime -> Bool
$cmax :: ModTime -> ModTime -> ModTime
max :: ModTime -> ModTime -> ModTime
$cmin :: ModTime -> ModTime -> ModTime
min :: ModTime -> ModTime -> ModTime
Ord, Typeable)

instance Structured ModTime

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 b c d. (b -> c) -> (b, d) -> (c, d)
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 -> IO 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
      let qwTime =
            (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh)
            .|. (fromIntegral (dwLow :: DWORD))
      return $! ModTime (qwTime :: Word64)

{- FOURMOLU_DISABLE -}
#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 -> IO 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 -> IO ModTime
getModTime String
path = do
    st <- String -> IO FileStatus
getFileStatus String
path
    return $! (extractFileTime st)

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

#endif
{- FOURMOLU_ENABLE -}

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 :: NominalDiffTime -> ModTime
posixTimeToModTime NominalDiffTime
p =
  Word64 -> ModTime
ModTime (Word64 -> ModTime) -> Word64 -> ModTime
forall a b. (a -> b) -> a -> b
$
    NominalDiffTime -> Word64
forall b. Integral b => NominalDiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (NominalDiffTime
p NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
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 -> IO Double
getFileAge :: String -> IO Double
getFileAge String
file = do
  t0 <- String -> IO UTCTime
getModificationTime String
file
  t1 <- getCurrentTime
  return $ realToFrac (t1 `diffUTCTime` t0) / realToFrac posixDayLength

-- | Return the current time as 'ModTime'.
getCurTime :: IO ModTime
getCurTime :: IO ModTime
getCurTime = NominalDiffTime -> ModTime
posixTimeToModTime (NominalDiffTime -> ModTime) -> IO NominalDiffTime -> IO ModTime
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO NominalDiffTime
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
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir (ZonkAny 1))
-> String
-> (SymbolicPath Pkg ('Dir (ZonkAny 0)) -> IO (Int, Int))
-> IO (Int, Int)
forall tmpDir1 tmpDir2 a.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir tmpDir1)
-> String
-> (SymbolicPath Pkg ('Dir tmpDir2) -> IO a)
-> IO a
withTempDirectoryCwd Verbosity
silent Maybe (SymbolicPath CWD ('Dir Pkg))
forall a. Maybe a
Nothing SymbolicPath Pkg ('Dir (ZonkAny 1))
forall (allowAbsolute :: AllowAbsolute) from to.
SymbolicPathX allowAbsolute from ('Dir to)
sameDirectory String
"calibration-" ((SymbolicPath Pkg ('Dir (ZonkAny 0)) -> IO (Int, Int))
 -> IO (Int, Int))
-> (SymbolicPath Pkg ('Dir (ZonkAny 0)) -> IO (Int, Int))
-> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ \SymbolicPath Pkg ('Dir (ZonkAny 0))
dir -> do
    let fileName :: String
fileName = SymbolicPath Pkg ('Dir (ZonkAny 0)) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir (ZonkAny 0))
dir String -> ShowS
</> String
"probe"
    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
      t0 <- String -> IO ModTime
getModTime String
fileName
      let spin a
j = do
            String -> String -> IO ()
writeFile String
fileName (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ (Int, a) -> String
forall a. Show a => a -> String
show (Int
i, a
j)
            t1 <- String -> IO ModTime
getModTime String
fileName
            unless (t0 < t1) (spin $ j + 1)
      spin (0 :: Int)
    let mtimeChange = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
mtimes
        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
    return (mtimeChange, mtimeChange')
  where
    time :: IO () -> IO Int
    time :: IO () -> IO Int
time IO ()
act = do
      t0 <- IO UTCTime
getCurrentTime
      act
      t1 <- getCurrentTime
      return . ceiling $! (t1 `diffUTCTime` t0) * 1e6 -- microseconds