{-# 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
                        -- jww (2013-12-26): Recursively clone submodules?
                        | 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                  -- PlainBlob | ExecutableBlob
                -- jww (2013-12-26): There is no way to know what a tree's
                -- path has been encoded as.
                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"