{-# LANGUAGE CPP #-}
module Git.Working where
import Conduit
import Control.Applicative
import Control.Monad.Catch
import Data.Semigroup
import Data.Text as T
import Git.Blob
import Git.Types
import System.Directory
import System.FilePath
#if !mingw32_HOST_OS
import System.Posix.Files
#endif
checkoutFiles :: (MonadGit r m, MonadResource m)
=> FilePath
-> Tree r
-> (TreeFilePath -> Either String FilePath)
-> Bool
-> m ()
checkoutFiles :: FilePath
-> Tree r
-> (TreeFilePath -> Either FilePath FilePath)
-> Bool
-> m ()
checkoutFiles FilePath
destPath Tree r
tree TreeFilePath -> Either FilePath FilePath
decode Bool
cloneSubmodules =
ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ Tree r -> ConduitT () (TreeFilePath, TreeEntry r) m ()
forall r (m :: * -> *) i.
MonadGit r m =>
Tree r -> ConduitT i (TreeFilePath, TreeEntry r) m ()
sourceTreeEntries Tree r
tree ConduitT () (TreeFilePath, TreeEntry r) m ()
-> ConduitM (TreeFilePath, TreeEntry r) Void m ()
-> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (((TreeFilePath, TreeEntry r) -> m ())
-> ConduitM (TreeFilePath, TreeEntry r) Void m ()
forall (m :: * -> *) a o.
Monad m =>
(a -> m ()) -> ConduitT a o m ()
mapM_C (((TreeFilePath, TreeEntry r) -> m ())
-> ConduitM (TreeFilePath, TreeEntry r) Void m ())
-> ((TreeFilePath, TreeEntry r) -> m ())
-> ConduitM (TreeFilePath, TreeEntry r) Void m ()
forall a b. (a -> b) -> a -> b
$ \(TreeFilePath
path, TreeEntry r
entry) ->
case (FilePath
destPath FilePath -> FilePath -> FilePath
</>) (FilePath -> FilePath)
-> Either FilePath FilePath -> Either FilePath FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreeFilePath -> Either FilePath FilePath
decode TreeFilePath
path of
Left FilePath
e -> TreeFilePath -> FilePath -> m ()
forall (m :: * -> *) a a.
(MonadThrow m, Show a) =>
a -> FilePath -> m a
decodeError TreeFilePath
path FilePath
e
Right FilePath
fullPath -> do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
fullPath)
case TreeEntry r
entry of
TreeEntry {} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
BlobEntry BlobOid r
oid BlobKind
kind -> BlobOid r -> BlobKind -> FilePath -> m ()
checkoutBlob BlobOid r
oid BlobKind
kind FilePath
fullPath
CommitEntry CommitOid r
oid
| Bool
cloneSubmodules -> CommitOid r -> FilePath -> m ()
forall a. a
cloneSubmodule CommitOid r
oid FilePath
fullPath
| Bool
otherwise -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
createDirectory FilePath
fullPath)
where
decodeError :: a -> FilePath -> m a
decodeError a
path FilePath
e = GitException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (GitException -> m a) -> GitException -> m a
forall a b. (a -> b) -> a -> b
$ Text -> GitException
PathEncodingError (Text -> GitException) -> Text -> GitException
forall a b. (a -> b) -> a -> b
$
Text
"Could not decode path " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (a -> FilePath
forall a. Show a => a -> FilePath
show a
path) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
e
checkoutBlob :: BlobOid r -> BlobKind -> FilePath -> m ()
checkoutBlob BlobOid r
oid BlobKind
kind FilePath
fullPath = do
Blob BlobOid r
_ BlobContents m
contents <- BlobOid r -> m (Blob r m)
forall r (m :: * -> *). MonadGit r m => BlobOid r -> m (Blob r m)
lookupBlob BlobOid r
oid
case BlobKind
kind of
#if !mingw32_HOST_OS
BlobKind
SymlinkBlob -> do
TreeFilePath
target <- BlobContents m -> m TreeFilePath
forall r (m :: * -> *).
MonadGit r m =>
BlobContents m -> m TreeFilePath
blobContentsToByteString BlobContents m
contents
case TreeFilePath -> Either FilePath FilePath
decode TreeFilePath
target of
Left FilePath
e -> TreeFilePath -> FilePath -> m ()
forall (m :: * -> *) a a.
(MonadThrow m, Show a) =>
a -> FilePath -> m a
decodeError TreeFilePath
target FilePath
e
Right FilePath
targetPath ->
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createSymbolicLink FilePath
targetPath FilePath
fullPath
#endif
BlobKind
_ -> do
FilePath -> BlobContents m -> m ()
forall r (m :: * -> *).
(MonadGit r m, MonadIO m, MonadResource m) =>
FilePath -> BlobContents m -> m ()
writeBlob FilePath
fullPath BlobContents m
contents
cloneSubmodule :: a
cloneSubmodule =
FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"jww (2013-12-29): Cloning submodule is not yet implemented"