{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}

module Development.Shake.Internal.FileInfo(
    noFileHash, isNoFileHash,
    FileSize, ModTime, FileHash,
    getFileHash, getFileInfo
    ) where

#ifndef MIN_VERSION_unix
#define MIN_VERSION_unix(a,b,c) 0
#endif

#ifndef MIN_VERSION_time
#define MIN_VERSION_time(a,b,c) 0
#endif


import Data.Hashable
import Control.Exception.Extra
import Development.Shake.Classes
import Development.Shake.Internal.FileName
import qualified Data.ByteString.Lazy.Internal as LBS (defaultChunkSize)
import Data.List.Extra
import Data.Word
import Numeric
import System.IO
import Foreign

#if defined(PORTABLE)
import System.IO.Error
import System.Directory
import Data.Time

#elif defined(mingw32_HOST_OS)
import Development.Shake.Internal.Errors
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Foreign.C.String
import Data.Char

#else

#if MIN_VERSION_time(1,9,1)
import Data.Time.Clock
import Data.Fixed
#endif

import Development.Shake.Internal.Errors
import GHC.IO.Exception
import System.IO.Error
import System.Posix.Files.ByteString
#endif

-- A piece of file information, where 0 and 1 are special (see fileInfo* functions)
newtype FileInfo a = FileInfo Word32
    deriving (Typeable,Int -> FileInfo a -> Int
FileInfo a -> Int
(Int -> FileInfo a -> Int)
-> (FileInfo a -> Int) -> Hashable (FileInfo a)
forall a. Int -> FileInfo a -> Int
forall a. FileInfo a -> Int
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: FileInfo a -> Int
$chash :: forall a. FileInfo a -> Int
hashWithSalt :: Int -> FileInfo a -> Int
$chashWithSalt :: forall a. Int -> FileInfo a -> Int
Hashable,Get (FileInfo a)
[FileInfo a] -> Put
FileInfo a -> Put
(FileInfo a -> Put)
-> Get (FileInfo a) -> ([FileInfo a] -> Put) -> Binary (FileInfo a)
forall a. Get (FileInfo a)
forall a. [FileInfo a] -> Put
forall a. FileInfo a -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [FileInfo a] -> Put
$cputList :: forall a. [FileInfo a] -> Put
get :: Get (FileInfo a)
$cget :: forall a. Get (FileInfo a)
put :: FileInfo a -> Put
$cput :: forall a. FileInfo a -> Put
Binary,Ptr b -> Int -> IO (FileInfo a)
Ptr b -> Int -> FileInfo a -> IO ()
Ptr (FileInfo a) -> IO (FileInfo a)
Ptr (FileInfo a) -> Int -> IO (FileInfo a)
Ptr (FileInfo a) -> Int -> FileInfo a -> IO ()
Ptr (FileInfo a) -> FileInfo a -> IO ()
FileInfo a -> Int
(FileInfo a -> Int)
-> (FileInfo a -> Int)
-> (Ptr (FileInfo a) -> Int -> IO (FileInfo a))
-> (Ptr (FileInfo a) -> Int -> FileInfo a -> IO ())
-> (forall b. Ptr b -> Int -> IO (FileInfo a))
-> (forall b. Ptr b -> Int -> FileInfo a -> IO ())
-> (Ptr (FileInfo a) -> IO (FileInfo a))
-> (Ptr (FileInfo a) -> FileInfo a -> IO ())
-> Storable (FileInfo a)
forall b. Ptr b -> Int -> IO (FileInfo a)
forall b. Ptr b -> Int -> FileInfo a -> IO ()
forall a. Ptr (FileInfo a) -> IO (FileInfo a)
forall a. Ptr (FileInfo a) -> Int -> IO (FileInfo a)
forall a. Ptr (FileInfo a) -> Int -> FileInfo a -> IO ()
forall a. Ptr (FileInfo a) -> FileInfo a -> IO ()
forall a. FileInfo a -> Int
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
forall a b. Ptr b -> Int -> IO (FileInfo a)
forall a b. Ptr b -> Int -> FileInfo a -> IO ()
poke :: Ptr (FileInfo a) -> FileInfo a -> IO ()
$cpoke :: forall a. Ptr (FileInfo a) -> FileInfo a -> IO ()
peek :: Ptr (FileInfo a) -> IO (FileInfo a)
$cpeek :: forall a. Ptr (FileInfo a) -> IO (FileInfo a)
pokeByteOff :: Ptr b -> Int -> FileInfo a -> IO ()
$cpokeByteOff :: forall a b. Ptr b -> Int -> FileInfo a -> IO ()
peekByteOff :: Ptr b -> Int -> IO (FileInfo a)
$cpeekByteOff :: forall a b. Ptr b -> Int -> IO (FileInfo a)
pokeElemOff :: Ptr (FileInfo a) -> Int -> FileInfo a -> IO ()
$cpokeElemOff :: forall a. Ptr (FileInfo a) -> Int -> FileInfo a -> IO ()
peekElemOff :: Ptr (FileInfo a) -> Int -> IO (FileInfo a)
$cpeekElemOff :: forall a. Ptr (FileInfo a) -> Int -> IO (FileInfo a)
alignment :: FileInfo a -> Int
$calignment :: forall a. FileInfo a -> Int
sizeOf :: FileInfo a -> Int
$csizeOf :: forall a. FileInfo a -> Int
Storable,FileInfo a -> ()
(FileInfo a -> ()) -> NFData (FileInfo a)
forall a. FileInfo a -> ()
forall a. (a -> ()) -> NFData a
rnf :: FileInfo a -> ()
$crnf :: forall a. FileInfo a -> ()
NFData)

noFileHash :: FileHash
noFileHash :: FileHash
noFileHash = Word32 -> FileHash
forall a. Word32 -> FileInfo a
FileInfo Word32
1   -- Equal to nothing

isNoFileHash :: FileHash -> Bool
isNoFileHash :: FileHash -> Bool
isNoFileHash (FileInfo Word32
i) = Word32
i Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1

fileInfo :: Word32 -> FileInfo a
fileInfo :: Word32 -> FileInfo a
fileInfo Word32
a = Word32 -> FileInfo a
forall a. Word32 -> FileInfo a
FileInfo (Word32 -> FileInfo a) -> Word32 -> FileInfo a
forall a b. (a -> b) -> a -> b
$ if Word32
a Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
forall a. Bounded a => a
maxBound Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
2 then Word32
a else Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2

instance Show (FileInfo a) where
    show :: FileInfo a -> String
show (FileInfo Word32
x)
        | Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 = String
"EQ"
        | Word32
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 = String
"NEQ"
        | Bool
otherwise = String
"0x" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
upper (Word32 -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex (Word32
xWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
2) String
"")

instance Eq (FileInfo a) where
    FileInfo Word32
a == :: FileInfo a -> FileInfo a -> Bool
== FileInfo Word32
b
        | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 Bool -> Bool -> Bool
|| Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 = Bool
True
        | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 Bool -> Bool -> Bool
|| Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
1 = Bool
False
        | Bool
otherwise = Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
b

data FileInfoHash; type FileHash = FileInfo FileInfoHash
data FileInfoMod ; type ModTime  = FileInfo FileInfoMod
data FileInfoSize; type FileSize = FileInfo FileInfoSize


getFileHash :: FileName -> IO FileHash
getFileHash :: FileName -> IO FileHash
getFileHash FileName
x = String -> IOMode -> (Handle -> IO FileHash) -> IO FileHash
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (FileName -> String
fileNameToString FileName
x) IOMode
ReadMode ((Handle -> IO FileHash) -> IO FileHash)
-> (Handle -> IO FileHash) -> IO FileHash
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
    Int -> (Ptr Any -> IO FileHash) -> IO FileHash
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
LBS.defaultChunkSize ((Ptr Any -> IO FileHash) -> IO FileHash)
-> (Ptr Any -> IO FileHash) -> IO FileHash
forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr ->
        Handle -> Ptr Any -> Int -> IO FileHash
forall a a. Handle -> Ptr a -> Int -> IO (FileInfo a)
go Handle
h Ptr Any
ptr (() -> Int
forall a. Hashable a => a -> Int
hash ())
    where
        go :: Handle -> Ptr a -> Int -> IO (FileInfo a)
go Handle
h Ptr a
ptr Int
salt = do
            Int
n <- Handle -> Ptr a -> Int -> IO Int
forall a. Handle -> Ptr a -> Int -> IO Int
hGetBufSome Handle
h Ptr a
ptr Int
LBS.defaultChunkSize
            if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then
                FileInfo a -> IO (FileInfo a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FileInfo a -> IO (FileInfo a)) -> FileInfo a -> IO (FileInfo a)
forall a b. (a -> b) -> a -> b
$! Word32 -> FileInfo a
forall a. Word32 -> FileInfo a
fileInfo (Word32 -> FileInfo a) -> Word32 -> FileInfo a
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
salt
            else
                Handle -> Ptr a -> Int -> IO (FileInfo a)
go Handle
h Ptr a
ptr (Int -> IO (FileInfo a)) -> IO Int -> IO (FileInfo a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr a -> Int -> Int -> IO Int
forall a. Ptr a -> Int -> Int -> IO Int
hashPtrWithSalt Ptr a
ptr Int
n Int
salt



-- If the result isn't strict then we are referencing a much bigger structure,
-- and it causes a space leak I don't really understand on Linux when running
-- the 'tar' test, followed by the 'benchmark' test.
-- See this blog post: https://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html
result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))
result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))
result Word32
x Word32
y = do
    ModTime
x <- ModTime -> IO ModTime
forall a. a -> IO a
evaluate (ModTime -> IO ModTime) -> ModTime -> IO ModTime
forall a b. (a -> b) -> a -> b
$ Word32 -> ModTime
forall a. Word32 -> FileInfo a
fileInfo Word32
x
    FileSize
y <- FileSize -> IO FileSize
forall a. a -> IO a
evaluate (FileSize -> IO FileSize) -> FileSize -> IO FileSize
forall a b. (a -> b) -> a -> b
$ Word32 -> FileSize
forall a. Word32 -> FileInfo a
fileInfo Word32
y
    Maybe (ModTime, FileSize) -> IO (Maybe (ModTime, FileSize))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ModTime, FileSize) -> IO (Maybe (ModTime, FileSize)))
-> Maybe (ModTime, FileSize) -> IO (Maybe (ModTime, FileSize))
forall a b. (a -> b) -> a -> b
$ (ModTime, FileSize) -> Maybe (ModTime, FileSize)
forall a. a -> Maybe a
Just (ModTime
x, FileSize
y)


-- | True = allow directory, False = disallow
getFileInfo :: Bool -> FileName -> IO (Maybe (ModTime, FileSize))

#if defined(PORTABLE)
-- Portable fallback
getFileInfo allowDir x = handleBool isDoesNotExistError (const $ pure Nothing) $ do
    let file = fileNameToString x
    time <- getModificationTime file
    size <- withFile file ReadMode hFileSize
    result (extractFileTime time) (fromIntegral size)

extractFileTime :: UTCTime -> Word32
extractFileTime = floor . fromRational . toRational . utctDayTime


#elif defined(mingw32_HOST_OS)
-- Directly against the Win32 API, twice as fast as the portable version
getFileInfo allowDir x = BS.useAsCString (fileNameToByteString x) $ \file ->
    alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do
        res <- c_GetFileAttributesExA file 0 fad
        let peek = do
                code <- peekFileAttributes fad
                if not allowDir && testBit code 4 then
                    throwIO $ errorDirectoryNotFile $ fileNameToString x
                 else
                    join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad)
        if res then
            peek
         else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do
            res <- c_GetFileAttributesExW file 0 fad
            if res then peek else pure Nothing
         else
            pure Nothing

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

foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: CString  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool
foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: CWString -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool

data WIN32_FILE_ATTRIBUTE_DATA

alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a
alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act
    where size_WIN32_FILE_ATTRIBUTE_DATA = 36

peekFileAttributes :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32
peekFileAttributes p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes
    where index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes = 0

peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32
peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime
    where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20

peekFileSizeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32
peekFileSizeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow
    where index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow = 32


#else
-- Unix version
getFileInfo :: Bool -> FileName -> IO (Maybe (ModTime, FileSize))
getFileInfo Bool
allowDir FileName
x = (IOError -> Bool)
-> (IOError -> IO (Maybe (ModTime, FileSize)))
-> IO (Maybe (ModTime, FileSize))
-> IO (Maybe (ModTime, FileSize))
forall e a.
Exception e =>
(e -> Bool) -> (e -> IO a) -> IO a -> IO a
handleBool IOError -> Bool
isDoesNotExistError' (IO (Maybe (ModTime, FileSize))
-> IOError -> IO (Maybe (ModTime, FileSize))
forall a b. a -> b -> a
const (IO (Maybe (ModTime, FileSize))
 -> IOError -> IO (Maybe (ModTime, FileSize)))
-> IO (Maybe (ModTime, FileSize))
-> IOError
-> IO (Maybe (ModTime, FileSize))
forall a b. (a -> b) -> a -> b
$ Maybe (ModTime, FileSize) -> IO (Maybe (ModTime, FileSize))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ModTime, FileSize)
forall a. Maybe a
Nothing) (IO (Maybe (ModTime, FileSize)) -> IO (Maybe (ModTime, FileSize)))
-> IO (Maybe (ModTime, FileSize)) -> IO (Maybe (ModTime, FileSize))
forall a b. (a -> b) -> a -> b
$ do
    FileStatus
s <- RawFilePath -> IO FileStatus
getFileStatus (RawFilePath -> IO FileStatus) -> RawFilePath -> IO FileStatus
forall a b. (a -> b) -> a -> b
$ FileName -> RawFilePath
fileNameToByteString FileName
x
    if Bool -> Bool
not Bool
allowDir Bool -> Bool -> Bool
&& FileStatus -> Bool
isDirectory FileStatus
s then
        SomeException -> IO (Maybe (ModTime, FileSize))
forall (m :: * -> *) a. MonadIO m => SomeException -> m a
throwM (SomeException -> IO (Maybe (ModTime, FileSize)))
-> SomeException -> IO (Maybe (ModTime, FileSize))
forall a b. (a -> b) -> a -> b
$ String -> SomeException
errorDirectoryNotFile (String -> SomeException) -> String -> SomeException
forall a b. (a -> b) -> a -> b
$ FileName -> String
fileNameToString FileName
x
     else
        Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))
result (FileStatus -> Word32
extractFileTime FileStatus
s) (FileOffset -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileOffset -> Word32) -> FileOffset -> Word32
forall a b. (a -> b) -> a -> b
$ FileStatus -> FileOffset
fileSize FileStatus
s)
    where
        isDoesNotExistError' :: IOError -> Bool
isDoesNotExistError' IOError
e =
            IOError -> Bool
isDoesNotExistError IOError
e Bool -> Bool -> Bool
|| IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InappropriateType

extractFileTime :: FileStatus -> Word32
#if MIN_VERSION_unix(2,6,0)
#if MIN_VERSION_time(1,9,1)
extractFileTime :: FileStatus -> Word32
extractFileTime = Integer -> Word32
forall a. Num a => Integer -> a
fromInteger (Integer -> Word32)
-> (FileStatus -> Integer) -> FileStatus -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(MkFixed Integer
x) -> Integer
x) (Fixed E12 -> Integer)
-> (FileStatus -> Fixed E12) -> FileStatus -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> Fixed E12
nominalDiffTimeToSeconds (NominalDiffTime -> Fixed E12)
-> (FileStatus -> NominalDiffTime) -> FileStatus -> Fixed E12
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> NominalDiffTime
modificationTimeHiRes
#else
extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4
#endif
#else
extractFileTime x = fromIntegral $ fromEnum $ modificationTime x
#endif

#endif