{-# LANGUAGE CPP #-}
module Git.Tree.Working where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.IO.Unlift
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
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