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

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

import Control.Exception.Extra
import Development.Shake.Classes
import Development.Shake.Internal.Errors
import Development.Shake.Internal.FileName
import qualified Data.ByteString.Lazy as LBS
import Data.Char
import Data.Word
import Numeric
import System.IO
import Foreign

#if defined(PORTABLE)
import System.IO.Error
import System.Directory
import Data.Time
#if __GLASGOW_HASKELL__ < 706
import System.Time
#endif

#elif defined(mingw32_HOST_OS)
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Foreign.C.Types
import Foreign.C.String

#else
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)

fileInfoNoHash :: FileInfo FileInfoHash
fileInfoNoHash :: FileInfo FileInfoHash
fileInfoNoHash = Word32 -> FileInfo FileInfoHash
forall a. Word32 -> FileInfo a
FileInfo 1   -- Equal to nothing

fileInfo :: Word32 -> FileInfo a
fileInfo :: Word32 -> FileInfo a
fileInfo a :: 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
- 2 then Word32
a else Word32
a Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ 2

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

instance Eq (FileInfo a) where
    FileInfo a :: Word32
a == :: FileInfo a -> FileInfo a -> Bool
== FileInfo b :: Word32
b
        | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
|| Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Bool
True
        | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 1 Bool -> Bool -> Bool
|| Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (FileInfo FileInfoHash)
getFileHash x :: FileName
x = String
-> IOMode
-> (Handle -> IO (FileInfo FileInfoHash))
-> IO (FileInfo FileInfoHash)
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (FileName -> String
fileNameToString FileName
x) IOMode
ReadMode ((Handle -> IO (FileInfo FileInfoHash))
 -> IO (FileInfo FileInfoHash))
-> (Handle -> IO (FileInfo FileInfoHash))
-> IO (FileInfo FileInfoHash)
forall a b. (a -> b) -> a -> b
$ \h :: Handle
h -> do
    ByteString
s <- Handle -> IO ByteString
LBS.hGetContents Handle
h
    let res :: FileInfo a
res = 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 -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
s
    FileInfo Any -> IO (FileInfo Any)
forall a. a -> IO a
evaluate FileInfo Any
forall a. FileInfo a
res
    FileInfo FileInfoHash -> IO (FileInfo FileInfoHash)
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo FileInfoHash
forall a. FileInfo a
res

-- 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 x :: Word32
x y :: 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 (m :: * -> *) a. Monad m => a -> m a
return (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)


getFileInfo :: FileName -> IO (Maybe (ModTime, FileSize))

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

-- deal with difference in return type of getModificationTime between directory versions
class ExtractFileTime a where extractFileTime :: a -> Word32
#if __GLASGOW_HASKELL__ < 706
instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fromIntegral t
#endif
instance ExtractFileTime UTCTime where extractFileTime = floor . fromRational . toRational . utctDayTime


#elif defined(mingw32_HOST_OS)
-- Directly against the Win32 API, twice as fast as the portable version
getFileInfo x = BS.useAsCString (fileNameToByteString x) $ \file ->
    alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do
        res <- c_GetFileAttributesExA file 0 fad
        code <- peekFileAttributes fad
        let peek = do
                code <- peekFileAttributes fad
                if testBit code 4 then
                    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 return Nothing
         else
            return Nothing

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

foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: Ptr CChar  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool
foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: Ptr CWchar -> 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 :: FileName -> IO (Maybe (ModTime, FileSize))
getFileInfo x :: 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 (m :: * -> *) a. Monad m => a -> m a
return 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 FileStatus -> Bool
isDirectory FileStatus
s then
        String -> IO (Maybe (ModTime, FileSize))
forall a. String -> IO a
errorDirectoryNotFile (String -> IO (Maybe (ModTime, FileSize)))
-> String -> IO (Maybe (ModTime, FileSize))
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' e :: 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
#ifndef MIN_VERSION_unix
#define MIN_VERSION_unix(a,b,c) 0
#endif
#if MIN_VERSION_unix(2,6,0)
extractFileTime :: FileStatus -> Word32
extractFileTime x :: FileStatus
x = POSIXTime -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (POSIXTime -> Word32) -> POSIXTime -> Word32
forall a b. (a -> b) -> a -> b
$ FileStatus -> POSIXTime
modificationTimeHiRes FileStatus
x POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* 1e4 -- precision of 0.1ms
#else
extractFileTime x = fromIntegral $ fromEnum $ modificationTime x
#endif

#endif