{-# LANGUAGE CPP #-}
module Git.Tree.Working where

import           Control.Applicative
-- import           Control.Concurrent.Async.Lifted
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO(..))
import           Control.Monad.IO.Unlift
-- import           Control.Monad.Trans.Control
import qualified Data.ByteString as B (readFile)
import qualified Data.ByteString.Char8 as B8
import           Data.Foldable (foldl')
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as Map
import           Data.Maybe
import           Data.Tagged
import           Data.Time
import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import           Git hiding (Options)
import           Prelude hiding (log)
import           UnliftIO.Async
import           System.FilePath.Posix
#ifndef mingw32_HOST_OS
import           System.Posix.Files
#else
import           System.PosixCompat.Files
#endif

data FileEntry m = FileEntry
    { FileEntry m -> UTCTime
fileModTime  :: UTCTime
    , FileEntry m -> BlobOid m
fileBlobOid  :: BlobOid m
    , FileEntry m -> BlobKind
fileBlobKind :: BlobKind
    , FileEntry m -> BlobOid m
fileChecksum :: BlobOid m
    }

type FileTree m = HashMap TreeFilePath (FileEntry m)

readFileTree :: (MonadGit r m, MonadUnliftIO m)
             => RefName
             -> FilePath
             -> Bool
             -> m (FileTree r)
readFileTree :: RefName -> FilePath -> Bool -> m (FileTree r)
readFileTree RefName
ref FilePath
wdir Bool
getHash = do
    Maybe (Oid r)
h <- RefName -> m (Maybe (Oid r))
forall r (m :: * -> *).
MonadGit r m =>
RefName -> m (Maybe (Oid r))
resolveReference RefName
ref
    case Maybe (Oid r)
h of
        Maybe (Oid r)
Nothing -> FileTree r -> m (FileTree r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileTree r
forall k v. HashMap k v
Map.empty
        Just Oid r
h' -> do
            Tree r
tr <- Tagged (Tree r) (Oid r) -> m (Tree r)
forall r (m :: * -> *). MonadGit r m => TreeOid r -> m (Tree r)
lookupTree (Tagged (Tree r) (Oid r) -> m (Tree r))
-> (Commit r -> Tagged (Tree r) (Oid r)) -> Commit r -> m (Tree r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Commit r -> Tagged (Tree r) (Oid r)
forall r. Commit r -> TreeOid r
commitTree (Commit r -> m (Tree r)) -> m (Commit r) -> m (Tree r)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CommitOid r -> m (Commit r)
forall r (m :: * -> *). MonadGit r m => CommitOid r -> m (Commit r)
lookupCommit (Oid r -> CommitOid r
forall k (s :: k) b. b -> Tagged s b
Tagged Oid r
h')
            Tree r -> FilePath -> Bool -> m (FileTree r)
forall r (m :: * -> *).
(MonadGit r m, MonadUnliftIO m) =>
Tree r -> FilePath -> Bool -> m (FileTree r)
readFileTree' Tree r
tr FilePath
wdir Bool
getHash

readFileTree' :: (MonadGit r m, MonadUnliftIO m)
              => Tree r -> FilePath -> Bool
              -> m (FileTree r)
readFileTree' :: Tree r -> FilePath -> Bool -> m (FileTree r)
readFileTree' Tree r
tr FilePath
wdir Bool
getHash = do
    [(ByteString, Tagged r (Oid r), BlobKind)]
blobs <- Tree r -> m [(ByteString, Tagged r (Oid r), BlobKind)]
forall r (m :: * -> *).
MonadGit r m =>
Tree r -> m [(ByteString, BlobOid r, BlobKind)]
treeBlobEntries Tree r
tr
    [(ByteString, Maybe (FileEntry r))]
stats <- ((ByteString, Tagged r (Oid r), BlobKind)
 -> m (ByteString, Maybe (FileEntry r)))
-> [(ByteString, Tagged r (Oid r), BlobKind)]
-> m [(ByteString, Maybe (FileEntry r))]
forall (m :: * -> *) (t :: * -> *) a b.
(MonadUnliftIO m, Traversable t) =>
(a -> m b) -> t a -> m (t b)
mapConcurrently (ByteString, Tagged r (Oid r), BlobKind)
-> m (ByteString, Maybe (FileEntry r))
go [(ByteString, Tagged r (Oid r), BlobKind)]
blobs
    FileTree r -> m (FileTree r)
forall (m :: * -> *) a. Monad m => a -> m a
return (FileTree r -> m (FileTree r)) -> FileTree r -> m (FileTree r)
forall a b. (a -> b) -> a -> b
$ (FileTree r -> (ByteString, Maybe (FileEntry r)) -> FileTree r)
-> FileTree r -> [(ByteString, Maybe (FileEntry r))] -> FileTree r
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FileTree r
m (!ByteString
fp,!Maybe (FileEntry r)
fent) -> FileTree r
-> (FileEntry r -> FileTree r) -> Maybe (FileEntry r) -> FileTree r
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FileTree r
m ((FileEntry r -> FileTree r -> FileTree r)
-> FileTree r -> FileEntry r -> FileTree r
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ByteString -> FileEntry r -> FileTree r -> FileTree r
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert ByteString
fp) FileTree r
m) Maybe (FileEntry r)
fent)
        FileTree r
forall k v. HashMap k v
Map.empty [(ByteString, Maybe (FileEntry r))]
stats
  where
    go :: (ByteString, Tagged r (Oid r), BlobKind)
-> m (ByteString, Maybe (FileEntry r))
go (!ByteString
fp,!Tagged r (Oid r)
oid,!BlobKind
kind) = do
        Maybe (FileEntry r)
fent <- FilePath
-> Bool
-> FilePath
-> Tagged r (Oid r)
-> BlobKind
-> m (Maybe (FileEntry r))
forall (m :: * -> *) r.
(MonadIO m, MonadGit r m) =>
FilePath
-> Bool
-> FilePath
-> BlobOid r
-> BlobKind
-> m (Maybe (FileEntry r))
readModTime FilePath
wdir Bool
getHash (ByteString -> FilePath
B8.unpack ByteString
fp) Tagged r (Oid r)
oid BlobKind
kind
        Maybe (FileEntry r)
fent Maybe (FileEntry r)
-> m (ByteString, Maybe (FileEntry r))
-> m (ByteString, Maybe (FileEntry r))
`seq` (ByteString, Maybe (FileEntry r))
-> m (ByteString, Maybe (FileEntry r))
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
fp,Maybe (FileEntry r)
fent)

readModTime :: (MonadIO m, MonadGit r m)
            => FilePath
            -> Bool
            -> FilePath
            -> BlobOid r
            -> BlobKind
            -> m (Maybe (FileEntry r))
readModTime :: FilePath
-> Bool
-> FilePath
-> BlobOid r
-> BlobKind
-> m (Maybe (FileEntry r))
readModTime FilePath
wdir Bool
getHash FilePath
fp BlobOid r
oid BlobKind
kind = do
    let path :: FilePath
path = FilePath
wdir FilePath -> FilePath -> FilePath
</> FilePath
fp
    -- debug' $ pack $ "Checking file: " ++ path
    Either SomeException FileStatus
estatus <- IO (Either SomeException FileStatus)
-> m (Either SomeException FileStatus)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SomeException FileStatus)
 -> m (Either SomeException FileStatus))
-> IO (Either SomeException FileStatus)
-> m (Either SomeException FileStatus)
forall a b. (a -> b) -> a -> b
$ IO FileStatus -> IO (Either SomeException FileStatus)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO FileStatus -> IO (Either SomeException FileStatus))
-> IO FileStatus -> IO (Either SomeException FileStatus)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
path
    case (Either SomeException FileStatus
estatus :: Either SomeException FileStatus) of
        Right FileStatus
status | FileStatus -> Bool
isRegularFile FileStatus
status ->
            FileEntry r -> Maybe (FileEntry r)
forall a. a -> Maybe a
Just (FileEntry r -> Maybe (FileEntry r))
-> m (FileEntry r) -> m (Maybe (FileEntry r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UTCTime -> BlobOid r -> BlobKind -> BlobOid r -> FileEntry r
forall m.
UTCTime -> BlobOid m -> BlobKind -> BlobOid m -> FileEntry m
FileEntry
                          (UTCTime -> BlobOid r -> BlobKind -> BlobOid r -> FileEntry r)
-> m UTCTime
-> m (BlobOid r -> BlobKind -> BlobOid r -> FileEntry r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UTCTime -> m UTCTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (POSIXTime -> UTCTime
posixSecondsToUTCTime
                                    (EpochTime -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (FileStatus -> EpochTime
modificationTime FileStatus
status)))
                          m (BlobOid r -> BlobKind -> BlobOid r -> FileEntry r)
-> m (BlobOid r) -> m (BlobKind -> BlobOid r -> FileEntry r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlobOid r -> m (BlobOid r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobOid r
oid
                          m (BlobKind -> BlobOid r -> FileEntry r)
-> m BlobKind -> m (BlobOid r -> FileEntry r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlobKind -> m BlobKind
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlobKind
kind
                          m (BlobOid r -> FileEntry r) -> m (BlobOid r) -> m (FileEntry r)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> if Bool
getHash
                              then BlobContents m -> m (BlobOid r)
forall r (m :: * -> *).
MonadGit r m =>
BlobContents m -> m (BlobOid r)
hashContents (BlobContents m -> m (BlobOid r))
-> (ByteString -> BlobContents m) -> ByteString -> m (BlobOid r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> BlobContents m
forall (m :: * -> *). ByteString -> BlobContents m
BlobString
                                  (ByteString -> m (BlobOid r)) -> m ByteString -> m (BlobOid r)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO ByteString
B.readFile FilePath
path)
                              else BlobOid r -> m (BlobOid r)
forall (m :: * -> *) a. Monad m => a -> m a
return BlobOid r
oid)
        Either SomeException FileStatus
_ -> Maybe (FileEntry r) -> m (Maybe (FileEntry r))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (FileEntry r)
forall a. Maybe a
Nothing