{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing
                -fno-warn-unused-binds
                -fno-warn-orphans #-}

-- | Interface for opening and creating repositories.  Repository objects are
--   immutable, and serve only to refer to the given repository.  Any data
--   associated with the repository — such as the list of branches — is
--   queried as needed.
module Git.Libgit2
       ( MonadLg
       , LgRepo(..)
       , BlobOid()
       , Commit()
       , CommitOid()
       , Git.Oid
       , OidPtr(..)
       , mkOid
       , Tree()
       , TreeOid()
       , lgRepoPath
       , addTracingBackend
       , checkResult
       , lgBuildPackIndex
       , lgFactory
       , lgForEachObject
       , lgExcTrap
       , lgBuildPackFile
       , lgReadFromPack
       , lgOpenPackFile
       , lgClosePackFile
       , lgWithPackFile
       , lgCopyPackFile
       , lgDiffContentsWithTree
       , lgWrap
       , oidToSha
       , shaToCOid
       , shaToOid
       , openLgRepository
       , runLgRepository
       , lgDebug
       , lgWarn
       ) where

import           Bindings.Libgit2
import           Conduit
import           Control.Applicative
import           Control.Concurrent (threadDelay)
import           Control.Concurrent.Async.Lifted
import           Control.Concurrent.STM
--import           Control.Exception.Lifted
import           Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
import           Control.Monad.Catch
import           Control.Monad.Loops
import           Control.Monad.Reader.Class
import           Control.Monad.Trans.Control
import           Control.Monad.Trans.Reader (ReaderT, runReaderT)
import           Control.Monad.Trans.Resource
import           Data.Bits ((.|.), (.&.))
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as BU
import           Data.Conduit.Async
import           Data.Foldable
import           Data.IORef
import           Data.List as L
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import           Data.Tagged
import           Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.ICU.Convert as U
import           Data.Traversable
import           Foreign.C.String
import           Foreign.C.Types
import qualified Foreign.Concurrent as FC
import           Foreign.ForeignPtr
import qualified Foreign.ForeignPtr.Unsafe as FU
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
#ifdef missing_calloc
import           Foreign.Marshal.MissingAlloc
#endif
import           Foreign.Marshal.Utils
import           Foreign.Ptr
import           Foreign.Storable
import qualified Git
import           Git.Libgit2.Internal
import           Git.Libgit2.Types
import           Language.Haskell.TH.Syntax (Loc(..))

import           Prelude hiding (mapM, mapM_, sequence, catch)
import           System.Directory
import           System.FilePath.Posix
import           System.IO (openBinaryTempFile, hClose)
import qualified System.IO.Unsafe as SU
import           Unsafe.Coerce

lgDebug :: MonadIO m => String -> m ()
lgDebug = liftIO . putStrLn . ("[DEBUG] " ++)

lgWarn :: MonadIO m => String -> m ()
lgWarn = liftIO . putStrLn . ("[WARN] " ++)

withFilePath :: Git.RawFilePath -> (CString -> IO a) -> IO a
withFilePath = B.useAsCString

peekFilePath :: CString -> IO Git.RawFilePath
peekFilePath = B.packCString

type Oid = OidPtr

data OidPtr = OidPtr
    { getOid    :: ForeignPtr C'git_oid
    , getOidLen :: Int           -- the number of digits, not bytes
    }

instance Git.IsOid OidPtr where
    renderOid = lgRenderOid

mkOid :: ForeignPtr C'git_oid -> OidPtr
mkOid fptr = OidPtr fptr 40

lgParseOidIO :: Text -> Int -> IO (Maybe Oid)
lgParseOidIO str len = do
    oid <- liftIO mallocForeignPtr
    r <- liftIO $ withCString (unpack str) $ \cstr ->
        withForeignPtr oid $ \ptr ->
            if len == 40
            then c'git_oid_fromstr ptr cstr
            else c'git_oid_fromstrn ptr cstr (fromIntegral len)
    return $ if r < 0
             then Nothing
             else Just (OidPtr oid len)

lgParseOid :: MonadLg m => Text -> m Oid
lgParseOid str
  | len > 40 = throwM (Git.OidParseFailed str)
  | otherwise = do
      moid <- liftIO $ lgParseOidIO str len
      case moid of
          Nothing  -> throwM (Git.OidParseFailed str)
          Just oid -> return oid
  where
    len = T.length str

lgRenderOid :: Oid -> Text
lgRenderOid = pack . show

instance Show OidPtr where
    show OidPtr {..} = SU.unsafePerformIO $
        withForeignPtr getOid (`oidToStr` getOidLen)

instance Ord OidPtr where
    (getOid -> coid1) `compare` (getOid -> coid2) =
        SU.unsafePerformIO $
        withForeignPtr coid1 $ \coid1Ptr ->
        withForeignPtr coid2 $ fmap (`compare` 0) . c'git_oid_cmp coid1Ptr

instance Eq OidPtr where
    oid1 == oid2 = oid1 `compare` oid2 == EQ

instance (Applicative m, MonadExcept m,
          MonadBaseControl IO m, MonadIO m)
         => Git.MonadGit LgRepo (ReaderT LgRepo m) where
    type Oid LgRepo = OidPtr
    data Tree LgRepo =
        LgTree { lgTreePtr :: Maybe (ForeignPtr C'git_tree) }
    data Options LgRepo = Options

    facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True }

    getRepository    = ask
    closeRepository  = return ()
    deleteRepository =
        Git.getRepository >>= liftIO . removeDirectoryRecursive . lgRepoPath

    parseOid = lgParseOid

    lookupReference   = lgLookupRef
    createReference   = lgUpdateRef
    updateReference   = lgUpdateRef
    deleteReference   = lgDeleteRef
    sourceReferences  = lgSourceRefs
    lookupCommit      = lgLookupCommit
    lookupTree        = lgLookupTree
    lookupBlob        = lgLookupBlob
    lookupTag         = error "Not implemented: LgRepository.lookupTag"
    readIndex         = lgReadIndex
    lookupObject      = lgLookupObject
    existsObject      = lgExistsObject
    sourceObjects     = lgSourceObjects
    newTreeBuilder    = lgNewTreeBuilder
    treeEntry         = lgTreeEntry
    treeOid           = lgTreeOid
    sourceTreeEntries = lgSourceTreeEntries
    hashContents      = lgHashContents
    createBlob        = lgWrap . lgCreateBlob
    createTag         = error "Not implemented: LgRepository.createTag"

    createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r

    diffContentsWithTree = error "Not implemented: lgDiffContentsWithTree"

    -- buildPackFile   = lgBuildPackFile
    -- buildPackIndex  = lgBuildPackIndexWrapper
    -- writePackFile   = lgWrap . lgWritePackFile

    -- remoteFetch     = lgRemoteFetch

lgExcTrap :: MonadLg m => ReaderT LgRepo m (IORef (Maybe Git.GitException))
lgExcTrap = repoExcTrap `liftM` Git.getRepository

lgWrap :: MonadLg m => ReaderT LgRepo m a -> ReaderT LgRepo m a
lgWrap f = f `catch` \e -> do
    etrap <- lgExcTrap
    mexc  <- liftIO $ readIORef etrap
    liftIO $ writeIORef etrap Nothing
    maybe (throwM (e :: SomeException)) throwM mexc

lgHashContents :: MonadLg m
               => Git.BlobContents (ReaderT LgRepo m)
               -> ReaderT LgRepo m BlobOid
lgHashContents b = do
    ptr <- liftIO mallocForeignPtr
    r   <- Git.blobContentsToByteString b >>= \bs ->
        liftIO $ withForeignPtr ptr $ \oidPtr ->
            BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->
                c'git_odb_hash oidPtr (castPtr cstr) (fromIntegral len)
                    c'GIT_OBJ_BLOB
    when (r < 0) $ lgThrow Git.BlobCreateFailed
    return $ Tagged (mkOid ptr)

-- | Create a new blob in the 'Repository', with 'ByteString' as its contents.
--
--   Note that since empty blobs cannot exist in Git, no means is provided for
--   creating one; if the given string is 'empty', it is an error.
lgCreateBlob :: MonadLg m
             => Git.BlobContents (ReaderT LgRepo m)
             -> ReaderT LgRepo m BlobOid
lgCreateBlob b = do
    repo <- Git.getRepository
    ptr  <- liftIO mallocForeignPtr -- freed automatically if GC'd
    r <- case b of
        Git.BlobString bs         -> createBlob repo ptr bs
        Git.BlobStringLazy bs     ->
            createBlob repo ptr (B.concat (BL.toChunks bs))
        Git.BlobStream src        -> readFromSource repo ptr src
        Git.BlobSizedStream src _ -> readFromSource repo ptr src
    when (r < 0) $ lgThrow Git.BlobCreateFailed
    return $ Tagged (mkOid ptr)

  where
    createBlob repo ptr bs = liftIO $ withForeignPtr ptr $ \coid' ->
        withForeignPtr (repoObj repo) $ \repoPtr ->
        BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->
            c'git_blob_create_frombuffer coid' repoPtr
                (castPtr cstr) (fromIntegral len)

    readFromSource repo ptr src =
        src $$ drainTo 2 $ \queue ->
            liftIO $ withForeignPtr ptr $ \coid' ->
            withForeignPtr (repoObj repo) $ \repoPtr ->
            bracket
                (mk'git_blob_chunk_cb (chunk_cb queue))
                freeHaskellFunPtr
                (\cb -> c'git_blob_create_fromchunks coid' repoPtr
                            nullPtr cb nullPtr)

    chunk_cb :: TBQueue (Maybe ByteString)
             -> CString          -- ^ content
             -> CSize            -- ^ max_length
             -> Ptr ()           -- ^ payload
             -> IO CInt
    chunk_cb queue content (fromIntegral -> maxLength) _payload = do
        (bs, len) <- atomically $ do
            mval <- readTBQueue queue
            let len = case mval of Nothing -> 0; Just val -> B.length val
            case mval of
                Nothing -> return (B.empty, 0)
                Just val
                    | len <= maxLength -> return (val, len)
                    | otherwise -> do
                        let (b, b') = B.splitAt maxLength val
                        unGetTBQueue queue (Just b')
                        return (b, maxLength)
        BU.unsafeUseAsCString bs $ flip (copyBytes content) len
        return $ fromIntegral len

lgObjToBlob :: MonadLg m
            => BlobOid
            -> ForeignPtr C'git_blob
            -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m))
lgObjToBlob oid fptr = do
    bs <- liftIO $ withForeignPtr fptr $ \ptr -> do
        size <- c'git_blob_rawsize ptr
        buf  <- c'git_blob_rawcontent ptr
        B.packCStringLen (castPtr buf, fromIntegral size)
    return $ Git.Blob oid $ Git.BlobString bs

lgLookupBlob :: MonadLg m
             => BlobOid
             -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m))
lgLookupBlob oid =
    lookupObject' (getOid (untag oid)) (getOidLen (untag oid))
        c'git_blob_lookup c'git_blob_lookup_prefix
        $ \boid obj _ -> lgObjToBlob (Tagged (mkOid boid)) obj

lgTreeEntry :: MonadLg m
            => Tree -> Git.TreeFilePath -> ReaderT LgRepo m (Maybe TreeEntry)
lgTreeEntry (LgTree Nothing) _ = return Nothing
lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr ->
    withFilePath fp $ \pathStr ->
        withForeignPtr tree $ \treePtr -> do
            r <- c'git_tree_entry_bypath entryPtr treePtr pathStr
            if r < 0
                then return Nothing
                else Just <$> (entryToTreeEntry =<< peek entryPtr)

lgTreeOid :: MonadLg m => Tree -> ReaderT LgRepo m TreeOid
lgTreeOid (LgTree Nothing) =
    liftIO $ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40
lgTreeOid (LgTree (Just tree)) = liftIO $ do
    toid  <- withForeignPtr tree c'git_tree_id
    ftoid <- coidPtrToOid toid
    return $ Tagged (mkOid ftoid)

gatherFrom' :: (MonadIO m, MonadBaseControl IO m, MonadExcept m)
           => Int                -- ^ Size of the queue to create
           -> (TBQueue o -> m ()) -- ^ Action that generates output values
           -> Producer m o
gatherFrom' size scatter = do
    chan   <- liftIO $ newTBQueueIO size
    worker <- lift $ async (scatter chan)
    lift . restoreM =<< gather worker chan
  where
    gather worker chan = do
        (xs, mres) <- liftIO $ atomically $ do
            xs <- whileM (not <$> isEmptyTBQueue chan) (readTBQueue chan)
            (xs,) <$> pollSTM worker
        liftIO $ threadDelay 1
        mapM_ yield xs
        case mres of
            Just (Left e)  -> throwM (e :: SomeException)
            Just (Right r) -> return r
            Nothing        -> gather worker chan

lgSourceTreeEntries
    :: MonadLg m
    => Tree
    -> Producer (ReaderT LgRepo m) (Git.TreeFilePath, TreeEntry)
lgSourceTreeEntries (LgTree Nothing) = return ()
lgSourceTreeEntries (LgTree (Just tree)) = gatherFrom' 16 $ \queue -> do
    liftIO $ withForeignPtr tree $ \tr -> do
        r <- bracket
                (mk'git_treewalk_cb (callback queue))
                freeHaskellFunPtr
                (\callback ->
                  c'git_tree_walk tr c'GIT_TREEWALK_PRE callback nullPtr)
        when (r < 0) $ lgThrow Git.TreeWalkFailed
  where
    callback queue root te _payload = do
        fp    <- peekFilePath root
        cname <- c'git_tree_entry_name te
        name  <- (fp <>) <$> peekFilePath cname
        entry <- entryToTreeEntry te
        atomically $
            writeTBQueue queue $ name `seq` entry `seq` (name,entry)
        return 0

lgMakeBuilder :: MonadLg m
              => ForeignPtr C'git_treebuilder -> TreeBuilder (ReaderT LgRepo m)
lgMakeBuilder builder = Git.TreeBuilder
    { Git.mtbBaseTreeOid    = Nothing
    , Git.mtbPendingUpdates = mempty
    , Git.mtbNewBuilder     = lgNewTreeBuilder
    , Git.mtbWriteContents  = \tb -> (,) <$> pure (Git.BuilderUnchanged tb)
                                         <*> lgWriteBuilder builder
    , Git.mtbLookupEntry    = lgLookupBuilderEntry builder
    , Git.mtbEntryCount     = lgBuilderEntryCount builder
    , Git.mtbPutEntry       = \tb name ent ->
        Git.BuilderUnchanged tb <$ lgPutEntry builder name ent
    , Git.mtbDropEntry      = \tb name ->
        Git.BuilderUnchanged tb <$ lgDropEntry builder name
    }

-- | Create a new, empty tree.
--
--   Since empty trees cannot exist in Git, attempting to write out an empty
--   tree is a no-op.
lgNewTreeBuilder :: MonadLg m
                 => Maybe Tree
                 -> ReaderT LgRepo m (TreeBuilder (ReaderT LgRepo m))
lgNewTreeBuilder mtree = do
    mfptr <- liftIO $ alloca $ \pptr -> do
        r <- case mtree of
            Nothing -> c'git_treebuilder_create pptr nullPtr
            Just (LgTree Nothing) ->
                c'git_treebuilder_create pptr nullPtr
            Just (LgTree (Just tree)) ->
                withForeignPtr tree $ \treePtr ->
                    c'git_treebuilder_create pptr treePtr
        if r < 0
            then return Nothing
            else do
                builder <- peek pptr
                fptr <- FC.newForeignPtr builder
                            (c'git_treebuilder_free builder)
                return $ Just fptr
    case mfptr of
        Nothing ->
            throwM (Git.TreeCreateFailed "Failed to create new tree builder")
        Just fptr -> do
            toid <- mapM Git.treeOid mtree
            return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid }

lgPutEntry :: MonadLg m
           => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry
           -> ReaderT LgRepo m ()
lgPutEntry builder key (treeEntryToOid -> (oid, mode)) = do
    r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid ->
        withForeignPtr builder $ \ptr ->
        withFilePath key $ \name ->
            c'git_treebuilder_insert nullPtr ptr name coid
                (fromIntegral mode)
    when (r2 < 0) $ throwM (Git.TreeBuilderInsertFailed key)

treeEntryToOid :: TreeEntry -> (Oid, CUInt)
treeEntryToOid (Git.BlobEntry oid kind) =
    (untag oid, case kind of
          Git.PlainBlob      -> 0o100644
          Git.ExecutableBlob -> 0o100755
          Git.SymlinkBlob    -> 0o120000)
treeEntryToOid (Git.CommitEntry coid) =
    (untag coid, 0o160000)
treeEntryToOid (Git.TreeEntry toid) =
    (untag toid, 0o040000)

lgDropEntry :: MonadLg m
            => ForeignPtr C'git_treebuilder -> Git.TreeFilePath
            -> ReaderT LgRepo m ()
lgDropEntry builder key =
    void $ liftIO $ withForeignPtr builder $ \ptr ->
        withFilePath key $ c'git_treebuilder_remove ptr

lgLookupBuilderEntry :: MonadLg m
                     => ForeignPtr C'git_treebuilder
                     -> Git.TreeFilePath
                     -> ReaderT LgRepo m (Maybe TreeEntry)
lgLookupBuilderEntry builderPtr name = do
    entry <- liftIO $ withForeignPtr builderPtr $ \builder ->
        withFilePath name $ c'git_treebuilder_get builder
    if entry == nullPtr
        then return Nothing
        else Just <$> liftIO (entryToTreeEntry entry)

lgBuilderEntryCount :: MonadLg m
                    => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m Int
lgBuilderEntryCount tb =
    fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount)

lgTreeEntryCount :: MonadLg m => Tree -> ReaderT LgRepo m Int
lgTreeEntryCount (LgTree Nothing) = return 0
lgTreeEntryCount (LgTree (Just tree)) =
    fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount)

lgWriteBuilder :: MonadLg m
               => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m TreeOid
lgWriteBuilder tb = do
    repo <- Git.getRepository
    (r3,coid) <- liftIO $ do
        coid <- mallocForeignPtr
        withForeignPtr coid $ \coid' ->
            withForeignPtr tb $ \builder ->
            withForeignPtr (repoObj repo) $ \repoPtr -> do
                r3 <- c'git_treebuilder_write coid' repoPtr builder
                return (r3,coid)
    when (r3 < 0) $ lgThrow Git.TreeBuilderWriteFailed
    return $ Tagged (mkOid coid)

lgCloneBuilder :: MonadLg m
               => ForeignPtr C'git_treebuilder
               -> ReaderT LgRepo m (ForeignPtr C'git_treebuilder)
lgCloneBuilder fptr =
    liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do
        r <- c'git_treebuilder_create pptr nullPtr
        when (r < 0) $
            throwM (Git.BackendError "Could not create new treebuilder")
        builder' <- peek pptr
        bracket
            (mk'git_treebuilder_filter_cb (callback builder'))
            freeHaskellFunPtr
            (flip (c'git_treebuilder_filter builder) nullPtr)
        FC.newForeignPtr builder' (c'git_treebuilder_free builder')
  where
    callback builder te _ = do
        cname <- c'git_tree_entry_name te
        coid  <- c'git_tree_entry_id te
        fmode <- c'git_tree_entry_filemode te
        r <- c'git_treebuilder_insert
            nullPtr
            builder
            cname
            coid
            fmode
        when (r < 0) $
            throwM (Git.BackendError "Could not insert entry in treebuilder")
        return 0

lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree
lgLookupTree (untag -> oid)
    | show oid == unpack Git.emptyTreeId = return $ LgTree Nothing
    | otherwise = do
        fptr <- lookupObject' (getOid oid) (getOidLen oid)
            c'git_tree_lookup c'git_tree_lookup_prefix $
                \_ obj _ -> return obj
        return $ LgTree (Just fptr)

entryToTreeEntry :: Ptr C'git_tree_entry -> IO TreeEntry
entryToTreeEntry entry = do
    coid <- c'git_tree_entry_id entry
    oid  <- coidPtrToOid coid
    typ  <- c'git_tree_entry_type entry
    case () of
        () | typ == c'GIT_OBJ_BLOB ->
             do mode <- c'git_tree_entry_filemode entry
                Git.BlobEntry (Tagged (mkOid oid)) <$>
                    case mode of
                        0o100644 -> return Git.PlainBlob
                        0o100755 -> return Git.ExecutableBlob
                        0o120000 -> return Git.SymlinkBlob
                        _        -> throwM $ Git.BackendError $
                            "Unknown blob mode: " <> T.pack (show mode)
           | typ == c'GIT_OBJ_TREE ->
             return $ Git.TreeEntry (Tagged (mkOid oid))
           | typ == c'GIT_OBJ_COMMIT ->
             return $ Git.CommitEntry (Tagged (mkOid oid))
           | otherwise -> error "Unexpected"

lgObjToCommit :: CommitOid -> Ptr C'git_commit -> IO Commit
lgObjToCommit oid c = do
    enc    <- c'git_commit_message_encoding c
    encs   <- if enc == nullPtr
              then return "UTF-8"
              else peekCString enc
    conv   <- U.open encs (Just False)

    msg    <- c'git_commit_message c   >>= B.packCString
    auth   <- c'git_commit_author c    >>= packSignature conv
    comm   <- c'git_commit_committer c >>= packSignature conv
    toid   <- c'git_commit_tree_id c
    toid'  <- coidPtrToOid toid

    pn     <- c'git_commit_parentcount c
    poids  <- zipWithM ($)
                 (replicate (fromIntegral (toInteger pn))
                  (c'git_commit_parent_id c))
                 [0..pn]
    poids' <- mapM (\x -> Tagged . mkOid <$> coidPtrToOid x) poids

    return Git.Commit
        {
        -- Git.commitInfo      = Base (Just (Tagged (Oid coid))) (Just obj)
        -- ,
          Git.commitOid       = oid
        , Git.commitTree      = Tagged (mkOid toid')
        , Git.commitParents   = poids'
        , Git.commitAuthor    = auth
        , Git.commitCommitter = comm
        , Git.commitLog       = U.toUnicode conv msg
        , Git.commitEncoding  = "utf-8"
        }

lgLookupCommit :: MonadLg m => CommitOid -> ReaderT LgRepo m Commit
lgLookupCommit oid =
  lookupObject' (getOid (untag oid)) (getOidLen (untag oid))
      c'git_commit_lookup c'git_commit_lookup_prefix
      $ \coid obj _ -> liftIO $ withForeignPtr obj $
          lgObjToCommit (Tagged (mkOid coid))

lgReadIndex :: MonadLg m => Git.TreeT LgRepo (ReaderT LgRepo m) ()
lgReadIndex = do
  repo <- lift Git.getRepository
  xs <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->
    alloca $ \indexPp -> do
      r <- c'git_repository_index indexPp repoPtr
      idx <- if r < 0
             then lgThrow Git.BackendError
             else peek indexPp
      cnt <- c'git_index_entrycount idx
      fmap Prelude.concat $ forM [0..pred cnt] $ \i -> do
        entryPtr <- c'git_index_get_byindex idx i
        entry <- peek entryPtr
        let oid   = c'git_index_entry'oid entry
            mode  = c'git_index_entry'mode entry
            path  = c'git_index_entry'path entry
            flags = c'git_index_entry'flags entry
        if 0 /= flags .&. 2 -- c'GIT_IDXENTRY_REMOVE
            then return []
            else do
                oid'  <- new oid
                foid' <- newForeignPtr_ oid'
                path' <- peekFilePath path
                return
                    [(path',
                      if 0 /= mode .&. 16384 -- check if directory
                      then Git.TreeEntry (Tagged (mkOid foid'))
                      else Git.BlobEntry (Tagged (mkOid foid')) $
                           if (0 /= mode .&. 64 -- check if owner executable
                              )
                           then Git.ExecutableBlob
                           else Git.PlainBlob
                                -- jww (2014-04-05): Handle CommitEntry
                     )]
  forM_ xs $ uncurry Git.putEntry

data ObjectPtr = BlobPtr (ForeignPtr C'git_blob)
               | TreePtr (ForeignPtr C'git_commit)
               | CommitPtr (ForeignPtr C'git_commit)
               | TagPtr (ForeignPtr C'git_tag)

lgLookupObject :: MonadLg m
               => Oid
               -> ReaderT LgRepo m (Git.Object LgRepo (ReaderT LgRepo m))
lgLookupObject oid = do
    (oid', typ, fptr) <-
        lookupObject' (getOid oid) (getOidLen oid)
            (\x y z   -> c'git_object_lookup x y z c'GIT_OBJ_ANY)
            (\x y z l -> c'git_object_lookup_prefix x y z l c'GIT_OBJ_ANY)
            $ \coid fptr y -> do
                typ <- liftIO $ c'git_object_type y
                return (mkOid coid, typ, fptr)
    case () of
        () | typ == c'GIT_OBJ_BLOB   ->
                Git.BlobObj <$> lgObjToBlob (Tagged oid') (castForeignPtr fptr)
           | typ == c'GIT_OBJ_TREE   ->
                -- A ForeignPtr C'git_object is bit-wise equivalent to a
                -- ForeignPtr C'git_tree.
                return $ Git.TreeObj (LgTree (Just (unsafeCoerce fptr)))
           | typ == c'GIT_OBJ_COMMIT ->
                Git.CommitObj <$>
                liftIO (withForeignPtr fptr $ \y ->
                         lgObjToCommit (Tagged oid') (castPtr y))
           | typ == c'GIT_OBJ_TAG -> error "jww (2013-07-08): NYI"
           | otherwise -> error $ "Unknown object type: " ++ show typ

lgExistsObject :: MonadLg m => Oid -> ReaderT LgRepo m Bool
lgExistsObject oid = do
    repo <- Git.getRepository
    result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->
        alloca $ \pptr -> do
            r <- c'git_repository_odb pptr repoPtr
            if r < 0
                then return Nothing
                else
                -- jww (2013-02-28): Need to guard against exceptions so that
                -- ptr doesn't leak.
                withForeignPtr (getOid oid) $ \coid -> do
                    ptr <- peek pptr
                    r1 <- c'git_odb_exists ptr coid 0
                    c'git_odb_free ptr
                    return (Just (r1 == 0))
    maybe (throwM Git.RepositoryInvalid) return result

lgForEachObject :: Ptr C'git_odb
                -> (Ptr C'git_oid -> Ptr () -> IO CInt)
                -> Ptr ()
                -> IO CInt
lgForEachObject odbPtr f payload =
    bracket
        (mk'git_odb_foreach_cb f)
        freeHaskellFunPtr
        (flip (c'git_odb_foreach odbPtr) payload)

lgSourceObjects :: MonadLg m
                => Maybe CommitOid -> CommitOid -> Bool
                -> Producer (ReaderT LgRepo m) ObjectOid
lgSourceObjects mhave need alsoTrees = do
    repo   <- lift Git.getRepository
    walker <- liftIO $ alloca $ \pptr -> do
        r <- withForeignPtr (repoObj repo) $ \repoPtr ->
                c'git_revwalk_new pptr repoPtr
        when (r < 0) $
            throwM (Git.BackendError "Could not create revwalker")
        ptr <- peek pptr
        FC.newForeignPtr ptr (c'git_revwalk_free ptr)

    c <- lift $ lgLookupCommit need
    let oid = untag (Git.commitOid c)

    liftIO $ withForeignPtr (getOid oid) $ \coid -> do
        r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid
        when (r2 < 0) $
            throwM (Git.BackendError $ "Could not push oid "
                         <> pack (show oid) <> " onto revwalker")

    case mhave of
        Nothing   -> return ()
        Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do
            r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid
            when (r2 < 0) $
                throwM (Git.BackendError $ "Could not hide commit "
                             <> pack (show (untag have)) <> " from revwalker")

    liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting
        (fromIntegral ((1 :: Int) .|. (4 :: Int)))

    coidPtr <- liftIO mallocForeignPtr
    whileM_ ((==) <$> pure 0
                  <*> liftIO (withForeignPtr walker $ \walker' ->
                              withForeignPtr coidPtr $ \coidPtr' ->
                                  c'git_revwalk_next coidPtr' walker')) $ do
        oidPtr <- liftIO $ withForeignPtr coidPtr coidPtrToOid
        do
            let coid = Tagged (mkOid oidPtr)
            yield $ Git.CommitObjOid coid
            when alsoTrees $ do
                c <- lift $ lgLookupCommit coid
                yield $ Git.TreeObjOid (Git.commitTree c)

-- | Write out a commit to its repository.  If it has already been written,
--   nothing will happen.
lgCreateCommit :: MonadLg m
               => [CommitOid]
               -> TreeOid
               -> Git.Signature
               -> Git.Signature
               -> Git.CommitMessage
               -> Maybe Git.RefName
               -> ReaderT LgRepo m Commit
lgCreateCommit pptrs tree author committer logText ref = do
    repo <- Git.getRepository
    let toid  = getOid . untag $ tree
    coid <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do
        coid <- mallocForeignPtr
        conv <- U.open "utf-8" (Just True)
        withForeignPtr coid $ \coid' ->
            withForeignPtr toid $ \toid' ->
            withForeignPtrs (map (getOid . untag) pptrs) $ \pptrs' ->
            B.useAsCString (U.fromUnicode conv logText) $ \message ->
            withRef ref $ \update_ref ->
            withSignature conv author $ \author' ->
            withSignature conv committer $ \committer' ->
            withEncStr "utf-8" $ \_ {-message_encoding-} -> do
                parents' <- newArray pptrs'
                r <- c'git_commit_create_oid coid' repoPtr
                     update_ref author' committer'
                     nullPtr message toid'
                     (fromIntegral (L.length pptrs)) parents'
                when (r < 0) $ throwM Git.CommitCreateFailed
                return coid

    return Git.Commit
        {
        --   Git.commitInfo      = Base (Just (Tagged (Oid coid))) Nothing
        -- ,
          Git.commitOid       = Tagged (mkOid coid)
        , Git.commitTree      = tree
        , Git.commitParents   = pptrs
        , Git.commitAuthor    = author
        , Git.commitCommitter = committer
        , Git.commitLog       = logText
        , Git.commitEncoding  = "utf-8"
        }

  where
    withRef Nothing     = flip ($) nullPtr
    withRef (Just name) = B.useAsCString (T.encodeUtf8 name)

    withEncStr ""  = flip ($) nullPtr
    withEncStr enc = withCString enc

withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withForeignPtrs fos io = do
    r <- io (map FU.unsafeForeignPtrToPtr fos)
    mapM_ touchForeignPtr fos
    return r

lgLookupRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe RefTarget)
lgLookupRef name = do
    repo <- Git.getRepository
    liftIO $ alloca $ \ptr -> do
        r <- withForeignPtr (repoObj repo) $ \repoPtr ->
              withCString (unpack name) $ \namePtr ->
                c'git_reference_lookup ptr repoPtr namePtr
        if r < 0
            then return Nothing
            else do
            ref  <- peek ptr
            typ  <- c'git_reference_type ref
            targ <- if typ == c'GIT_REF_OID
                    then do oidPtr <- c'git_reference_target ref
                            Git.RefObj . mkOid
                                <$> coidPtrToOid oidPtr
                    else do targName <- c'git_reference_symbolic_target ref
                            Git.RefSymbolic . T.decodeUtf8
                                <$> B.packCString targName
            c'git_reference_free ref
            return (Just targ)

lgUpdateRef :: MonadLg m
            => Git.RefName -> Git.RefTarget LgRepo -> ReaderT LgRepo m ()
lgUpdateRef name refTarg = do
    repo <- Git.getRepository
    r <- liftIO $ alloca $ \ptr ->
        withForeignPtr (repoObj repo) $ \repoPtr ->
        withCString (unpack name) $ \namePtr ->
            case refTarg of
                Git.RefObj oid ->
                    withForeignPtr (getOid oid) $ \coidPtr ->
                        c'git_reference_create ptr repoPtr namePtr
                                               coidPtr (fromBool True)

                Git.RefSymbolic symName ->
                    withCString (unpack symName) $ \symPtr ->
                        c'git_reference_symbolic_create ptr repoPtr namePtr
                                                        symPtr (fromBool True)
    when (r < 0) $ lgThrow Git.ReferenceCreateFailed

-- int git_reference_name_to_oid(git_oid *out, git_repository *repo,
--   const char *name)

lgResolveRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe CommitOid)
lgResolveRef name = do
    repo <- Git.getRepository
    oid <- liftIO $ alloca $ \ptr ->
        withCString (unpack name) $ \namePtr ->
        withForeignPtr (repoObj repo) $ \repoPtr -> do
            r <- c'git_reference_name_to_id ptr repoPtr namePtr
            if r < 0
                then return Nothing
                else Just <$> coidPtrToOid ptr
    return $ Tagged . mkOid <$> oid

-- int git_reference_rename(git_reference *ref, const char *new_name,
--   int force)

--renameRef = c'git_reference_rename

lgDeleteRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m ()
lgDeleteRef name = do
    repo <- Git.getRepository
    r <- liftIO $ alloca $ \ptr ->
        withCString (unpack name) $ \namePtr ->
        withForeignPtr (repoObj repo) $ \repoPtr -> do
            r <- c'git_reference_lookup ptr repoPtr namePtr
            if r < 0
                then return r
                else do
                ref <- peek ptr
                c'git_reference_delete ref
    when (r < 0) $ throwM (Git.ReferenceDeleteFailed name)

-- int git_reference_packall(git_repository *repo)

--packallRefs = c'git_reference_packall

data ListFlags = ListFlags { listFlagInvalid  :: Bool
                           , listFlagOid      :: Bool
                           , listFlagSymbolic :: Bool
                           , listFlagPacked   :: Bool
                           , listFlagHasPeel  :: Bool }
               deriving (Show, Eq)

allRefsFlag :: ListFlags
allRefsFlag = ListFlags { listFlagInvalid  = False
                        , listFlagOid      = True
                        , listFlagSymbolic = True
                        , listFlagPacked   = True
                        , listFlagHasPeel  = False }

-- symbolicRefsFlag :: ListFlags
-- symbolicRefsFlag = ListFlags { listFlagInvalid  = False
--                              , listFlagOid      = False
--                              , listFlagSymbolic = True
--                              , listFlagPacked   = False
--                              , listFlagHasPeel  = False }

-- oidRefsFlag :: ListFlags
-- oidRefsFlag = ListFlags { listFlagInvalid  = False
--                         , listFlagOid      = True
--                         , listFlagSymbolic = False
--                         , listFlagPacked   = True
--                         , listFlagHasPeel  = False }

-- looseOidRefsFlag :: ListFlags
-- looseOidRefsFlag = ListFlags { listFlagInvalid  = False
--                              , listFlagOid      = True
--                              , listFlagSymbolic = False
--                              , listFlagPacked   = False
--                              , listFlagHasPeel  = False }

gitStrArray2List :: Ptr C'git_strarray -> IO [Text]
gitStrArray2List gitStrs = do
  count <- fromIntegral <$> peek (p'git_strarray'count gitStrs)
  strings <- peek $ p'git_strarray'strings gitStrs

  r0 <- Foreign.Marshal.Array.peekArray count strings
  r1 <- sequence $ fmap peekCString r0
  return $ fmap pack r1

flagsToInt :: ListFlags -> CUInt
flagsToInt flags = (if listFlagOid flags      then 1 else 0)
                 + (if listFlagSymbolic flags then 2 else 0)
                 + (if listFlagPacked flags   then 4 else 0)
                 + (if listFlagHasPeel flags  then 8 else 0)

lgSourceRefs :: MonadLg m => Producer (ReaderT LgRepo m) Git.RefName
lgSourceRefs =
    gatherFrom' 16 $ \queue -> do
        repo <- Git.getRepository
        r <- liftIO $ bracket
            (mk'git_reference_foreach_cb (callback queue))
            freeHaskellFunPtr
            (\callback -> withForeignPtr (repoObj repo) $ \repoPtr ->
                  c'git_reference_foreach repoPtr
                      (flagsToInt allRefsFlag) callback nullPtr)
        when (r < 0) $ lgThrow Git.ReferenceListingFailed
  where
    callback :: TBQueue Text
             -> CString
             -> Ptr ()
             -> IO CInt
    callback queue cname _payload = do
        name <- peekCString cname
        atomically $ writeTBQueue queue (pack name)
        return 0

-- foreachRefCallback :: CString -> Ptr () -> IO CInt
-- foreachRefCallback name payload = do
--   (callback,results) <- deRefStablePtr =<< peek (castPtr payload)
--   nameStr <- peekCString name
--   result <- callback (pack nameStr)
--   modifyIORef results (\xs -> result:xs)
--   return 0

-- foreign export ccall "foreachRefCallback"
--   foreachRefCallback :: CString -> Ptr () -> IO CInt
-- foreign import ccall "&foreachRefCallback"
--   foreachRefCallbackPtr :: FunPtr (CString -> Ptr () -> IO CInt)

-- lgMapRefs :: (Text -> LgRepository a) -> LgRepository [a]
-- lgMapRefs cb = do
--     repo <- Git.getRepository
--     liftIO $ do
--         withForeignPtr (repoObj repo) $ \repoPtr -> do
--             ioRef <- newIORef []
--             bracket
--                 (newStablePtr (cb,ioRef))
--                 freeStablePtr
--                 (\ptr -> with ptr $ \pptr -> do
--                       _ <- c'git_reference_foreach
--                            repoPtr (flagsToInt allRefsFlag)
--                            foreachRefCallbackPtr (castPtr pptr)
--                       readIORef ioRef)

-- mapAllRefs :: (Text -> LgRepository a) -> LgRepository [a]
-- mapAllRefs repo = mapRefs repo allRefsFlag
-- mapOidRefs :: (Text -> LgRepository a) -> LgRepository [a]
-- mapOidRefs repo = mapRefs repo oidRefsFlag
-- mapLooseOidRefs :: (Text -> LgRepository a) -> LgRepository [a]
-- mapLooseOidRefs repo = mapRefs repo looseOidRefsFlag
-- mapSymbolicRefs :: (Text -> LgRepository a) -> LgRepository [a]
-- mapSymbolicRefs repo = mapRefs repo symbolicRefsFlag

-- int git_reference_is_packed(git_reference *ref)

--refIsPacked = c'git_reference_is_packed

-- int git_reference_reload(git_reference *ref)

--reloadRef = c'git_reference_reload

-- int git_reference_cmp(git_reference *ref1, git_reference *ref2)

--compareRef = c'git_reference_cmp

lgThrow :: (MonadIO m, MonadExcept m, Exception e) => (Text -> e) -> m a
lgThrow f = do
    errStr <- liftIO $ do
        errPtr <- c'giterr_last
        if errPtr == nullPtr
            then return ""
            else do
                err <- peek errPtr
                peekCString (c'git_error'message err)
    throwM (f (pack errStr))

-- withLgTempRepo :: MonadLg m => ReaderT LgRepo m a -> m a
-- withLgTempRepo f = withTempDir $ \dir -> do
--     repo <- liftIO (removeTree dir) >> openLgRepository
--         defaultRepositoryOptions
--             { repoPath       = F.encodeString dir
--             , repoIsBare     = True
--             , repoAutoCreate = True
--             }
--     runProjectLgRepository $ f `finally` closeRepository

lgDiffContentsWithTree
    :: MonadLg m
    => Source (ReaderT LgRepo m)
        (Either Git.TreeFilePath (Either Git.SHA ByteString))
    -> Tree
    -> Producer (ReaderT LgRepo m) ByteString
lgDiffContentsWithTree _contents (LgTree Nothing) =
    liftIO $ throwM $
        Git.DiffTreeToIndexFailed "Cannot diff against an empty tree"

lgDiffContentsWithTree contents tree = do
    repo <- lift Git.getRepository
    gatherFrom' 16 $ generateDiff repo
  where
    -- generateDiff :: MonadLg m => LgRepo -> TBQueue ByteString -> m ()
    generateDiff repo chan = do
        entries   <- M.fromList <$> Git.listTreeEntries tree
        paths     <- liftIO $ newIORef []
        (src, ()) <- contents $$+ return ()

        handleEntries entries paths src
        contentsPaths <- liftIO $ readIORef paths

        forM_ (sort (M.keys entries) \\ sort contentsPaths) $ \path ->
            -- File was removed
            case entries M.! path of
                Git.BlobEntry oid _   -> do
                    let boid = getOid (untag oid)
                    diffBlob path Nothing (Just boid)

                -- jww (2013-11-24): NYI
                Git.CommitEntry _coid -> return ()
                Git.TreeEntry _toid   -> return ()
      where
        -- handleEntries :: M.Map Git.TreeFilePath TreeEntry
        --               -> IORef [Git.TreeFilePath]
        --               -> ResumableSource m (Either Git.TreeFilePath
        --                                     (Either Git.SHA ByteString))
        --               -> m ()
        handleEntries entries paths src = do
            (src', mres) <- src $$++ do
                mpath <- await
                case mpath of
                    Nothing   -> return Nothing
                    Just path -> Just <$> handlePath path
            case mres of
                Nothing -> return ()
                Just (path, content) -> do
                    liftIO $ modifyIORef paths (path:)
                    case M.lookup path entries of
                        Nothing ->
                            -- File is newly added
                            diffBlob path (Just content) Nothing

                        Just entry -> case entry of
                            -- File has been changed
                            Git.BlobEntry oid _   -> do
                                let boid = getOid (untag oid)
                                diffBlob path (Just content) (Just boid)

                            -- jww (2013-11-24): NYI
                            Git.CommitEntry _coid -> return ()
                            Git.TreeEntry _toid   -> return ()
                    handleEntries entries paths src'

        -- handlePath :: Either Git.TreeFilePath (Either Git.SHA ByteString)
        --            -> Consumer (Either Git.TreeFilePath
        --                         (Either Git.SHA ByteString)) m
        --                   (Git.TreeFilePath, Either Git.SHA ByteString)
        handlePath (Right _) =
            lift $ throwM $ Git.DiffTreeToIndexFailed
                "Received a Right value when a Left RawFilePath was expected"
        handlePath (Left path) = do
            mcontent <- await
            case mcontent of
                Nothing ->
                    lift $ throwM $ Git.DiffTreeToIndexFailed $
                        "Content not provided for " <> T.pack (show path)
                Just x -> handleContent path x

        -- handleContent :: Git.TreeFilePath
        --               -> Either Git.TreeFilePath (Either Git.SHA ByteString)
        --               -> Consumer (Either Git.TreeFilePath
        --                            (Either Git.SHA ByteString)) m
        --                   (Git.TreeFilePath, Either Git.SHA ByteString)
        handleContent _path (Left _) =
            lift $ throwM $ Git.DiffTreeToIndexFailed
                "Received a Left value when a Right ByteString was expected"
        handleContent path (Right content) = return (path, content)

        -- diffBlob :: MonadExcept m
        --          => Git.TreeFilePath
        --          -> Maybe (Either Git.SHA ByteString)
        --          -> Maybe (ForeignPtr C'git_oid)
        --          -> m ()
        diffBlob path mcontent mboid = do
            r <- liftIO $ runResourceT $ do
                fileHeader <- liftIO $ newIORef Nothing

                let f = flip allocate freeHaskellFunPtr
                (_, fcb) <- f $ mk'git_diff_file_cb (file_cb fileHeader)
                (_, hcb) <- f $ mk'git_diff_hunk_cb (hunk_cb fileHeader)
                (_, pcb) <- f $ mk'git_diff_data_cb print_cb

                let db b o = diffBlobs fcb hcb pcb b o
                    dbb b  = diffBlobToBuffer fcb hcb pcb b
                case mboid of
                    Nothing   -> liftIO $ dbb nullPtr
                    Just boid -> withBlob boid $ \blobp ->
                        case mcontent of
                            Just (Left sha) -> do
                                boid2 <- liftIO $ shaToCOid sha
                                if boid == boid2
                                    then withBlob boid2 $
                                        liftIO . db blobp
                                    else return 0
                            _ -> liftIO $ dbb blobp
            when (r < 0) $ lgThrow Git.DiffBlobFailed
          where
            withBlob :: ForeignPtr C'git_oid
                     -> (Ptr C'git_blob -> ResourceT IO CInt)
                     -> ResourceT IO CInt
            withBlob boid f = do
                (_, eblobp) <- flip allocate freeBlob $
                    alloca $ \blobpp ->
                    withForeignPtr boid $ \boidPtr ->
                    withForeignPtr (repoObj repo) $ \repoPtr -> do
                        r <- c'git_blob_lookup blobpp repoPtr boidPtr
                        if r < 0
                            then return $ Left r
                            else Right <$> peek blobpp
                case eblobp of
                    Left r      -> return r
                    Right blobp -> f blobp
              where
                freeBlob (Left _)      = return ()
                freeBlob (Right blobp) = c'git_blob_free blobp

            -- diffBlobToBuffer :: fcb -> hcb -> pcb -> Ptr C'git_blob -> IO CInt
            diffBlobToBuffer fcb hcb pcb blobp = do
                let diff s l =
                        c'git_diff_blob_to_buffer blobp s (fromIntegral l)
                            nullPtr fcb hcb pcb nullPtr
                case mcontent of
                    Just (Right c) -> BU.unsafeUseAsCStringLen c $ uncurry diff
                    _              -> diff nullPtr 0

            -- diffBlobs :: fcb -> hcb -> pcb -> Ptr C'git_blob -> Ptr C'git_blob
            --           -> IO CInt
            diffBlobs fcb hcb pcb blobp otherp =
                c'git_diff_blobs blobp otherp nullPtr fcb hcb pcb nullPtr

            isBinary :: C'git_diff_delta -> Bool
            isBinary delta =
                c'git_diff_delta'flags delta .&. c'GIT_DIFF_FLAG_BINARY /= 0

            file_cb :: IORef (Maybe ByteString)
                    -> Ptr C'git_diff_delta
                    -> CFloat
                    -> Ptr ()
                    -> IO CInt
            file_cb fh deltap _progress _payload = do
                delta <- peek deltap
                writeIORef fh $ Just $
                    if isBinary delta
                    then "Binary files a/" <> path <> " and b/" <> path
                        <> " differ\n"
                    else "--- a/" <> path <> "\n" <> "+++ b/" <> path <> "\n"
                return 0

            hunk_cb :: IORef (Maybe ByteString)
                    -> Ptr C'git_diff_delta
                    -> Ptr C'git_diff_range
                    -> CString
                    -> CSize
                    -> Ptr ()
                    -> IO CInt
            hunk_cb fh deltap _rangep header headerLen _payload = do
                delta <- peek deltap
                mfh <- readIORef fh
                forM_ mfh $ \h -> do
                    atomically $ writeTBQueue chan h
                    writeIORef fh Nothing
                unless (isBinary delta) $ do
                    bs <- curry B.packCStringLen header
                        (fromIntegral headerLen)
                    atomically $ writeTBQueue chan bs
                return 0

            print_cb :: Ptr C'git_diff_delta
                     -> Ptr C'git_diff_range
                     -> CChar
                     -> CString
                     -> CSize
                     -> Ptr ()
                     -> IO CInt
            print_cb deltap _range lineOrigin content contentLen _payload = do
                delta <- peek deltap
                unless (isBinary delta) $ do
                    bs <- curry B.packCStringLen content
                        (fromIntegral contentLen)
                    atomically $ writeTBQueue chan $
                        B.cons (fromIntegral lineOrigin) bs
                return 0

checkResult :: (Eq a, Num a, MonadExcept m) => a -> Text -> m ()
checkResult r why = when (r /= 0) $ throwM (Git.BackendError why)

lgBuildPackFile :: MonadLg m
                => FilePath -> [Either CommitOid TreeOid]
                -> ReaderT LgRepo m FilePath
lgBuildPackFile dir oids = do
    repo <- Git.getRepository
    liftIO $ do
        (filePath, fHandle) <- openBinaryTempFile dir "pack"
        hClose fHandle
        go repo filePath
        return filePath
  where
    go repo path = runResourceT $ do
        delKey <- register $ removeFile path

        (_,bPtrPtr) <- allocate malloc free
        (_,bPtr)    <- flip allocate c'git_packbuilder_free $
            liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do
                r <- c'git_packbuilder_new bPtrPtr repoPtr
                checkResult r "c'git_packbuilder_new failed"
                peek bPtrPtr

        forM_ oids $ \oid -> case oid of
            -- jww (2013-04-24): When libgit2 0.19 comes out, we will only
            -- need to call c'git_packbuilder_insert_commit here, as it will
            -- insert both the commit and its tree.
            Left coid ->
                actOnOid
                    (flip (c'git_packbuilder_insert bPtr) nullPtr)
                    (untag coid)
                    "c'git_packbuilder_insert failed"
            Right toid ->
                actOnOid
                    (c'git_packbuilder_insert_tree bPtr)
                    (untag toid)
                    "c'git_packbuilder_insert_tree failed"

        liftIO $ do
            r1 <- c'git_packbuilder_set_threads bPtr 0
            checkResult r1 "c'git_packbuilder_set_threads failed"

            withCString path $ \cstr -> do
                r2 <- c'git_packbuilder_write bPtr cstr
                checkResult r2 "c'git_packbuilder_write failed"

        void $ unprotect delKey

    actOnOid f oid msg =
        liftIO $ withForeignPtr (getOid oid) $ \oidPtr -> do
            r <- f oidPtr
            checkResult r msg

lift_ :: (Monad m, Functor (t m), MonadTrans t) => m a -> t m ()
lift_ = void . lift

lgBuildPackIndex :: (MonadIO m, MonadBaseControl IO m)
                 => FilePath -> BL.ByteString -> m (Text, FilePath, FilePath)
lgBuildPackIndex dir bytes = do
    sha <- go dir bytes
    return (sha, dir </> ("pack-" <> unpack sha <> ".pack"),
                 dir </> ("pack-" <> unpack sha <> ".idx"))
  where
    go dir bytes = control $ \run -> alloca $ \idxPtrPtr -> runResourceT $ do
        lift_ . run $ lgDebug "Allocate a new indexer stream"
        (_,idxPtr) <- flip allocate c'git_indexer_stream_free $
            withCString dir $ \dirStr -> do
                r <- c'git_indexer_stream_new idxPtrPtr dirStr
                         nullFunPtr nullPtr
                checkResult r "c'git_indexer_stream_new failed"
                peek idxPtrPtr

        lift_ . run $
            lgDebug $ "Add the incoming packfile data to the stream ("
                 ++ show (BL.length bytes) ++ " bytes)"
        (_,statsPtr) <- allocate calloc free
        liftIO $ forM_ (BL.toChunks bytes) $ \chunk ->
            BU.unsafeUseAsCStringLen chunk $ uncurry $ \dataPtr dataLen -> do
                r <- c'git_indexer_stream_add idxPtr (castPtr dataPtr)
                         (fromIntegral dataLen) statsPtr
                checkResult r "c'git_indexer_stream_add failed"

        lift_ . run $ lgDebug "Finalizing the stream"
        r <- liftIO $ c'git_indexer_stream_finalize idxPtr statsPtr
        checkResult r "c'git_indexer_stream_finalize failed"

        lift_ . run $
            lgDebug "Discovering the hash used to identify the pack file"
        sha <- liftIO $ oidToSha =<< c'git_indexer_stream_hash idxPtr
        lift_ . run $ lgDebug $ "The hash used is: " ++ show (Git.shaToText sha)

        lift . run $ return (Git.shaToText sha)

oidToSha :: Ptr C'git_oid -> IO Git.SHA
oidToSha oidPtr =
    Git.SHA <$> B.packCStringLen
        (castPtr oidPtr, sizeOf (undefined :: C'git_oid))

shaToCOid :: Git.SHA -> IO (ForeignPtr C'git_oid)
shaToCOid (Git.SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do
    ptr <- mallocForeignPtr
    withForeignPtr ptr $ \ptr' -> do
        c'git_oid_fromraw ptr' (castPtr bytes)
        return ptr

shaToOid :: Git.SHA -> IO OidPtr
shaToOid = fmap mkOid . shaToCOid

lgCopyPackFile :: MonadLg m => FilePath -> ReaderT LgRepo m ()
lgCopyPackFile packFile = do
    -- jww (2013-04-23): This would be much more efficient (we already have
    -- the pack file on disk, why not just copy it?), but we have no way at
    -- present of communicating with the S3 backend directly.
    -- S3.uploadPackAndIndex undefined (F.directory packFile) packSha

    -- Use the ODB backend interface to transfer the pack file, which
    -- inefficiently transfers the pack file as a strict ByteString in memory,
    -- only to be written to disk again on the other side.  However, since
    -- this algorithm knows nothing about S3 or the S3 backend, this is our
    -- only way of talking to that backend.
    --
    -- The abstract API does have a writePackFile method, but we can't use it
    -- yet because it only calls into the Libgit2 backend, which doesn't know
    -- anything about the S3 backend.  As far as Libgit2 is concerned, the S3
    -- backend is just a black box with no special properties.
    repo <- Git.getRepository
    control $ \run -> withForeignPtr (repoObj repo) $ \repoPtr ->
        alloca $ \odbPtrPtr ->
        alloca $ \statsPtr ->
        alloca $ \writepackPtrPtr -> do
            runResourceT $ go run repoPtr odbPtrPtr writepackPtrPtr statsPtr
            run $ return ()
  where
    go run repoPtr odbPtrPtr writepackPtrPtr statsPtr = do
        lift_ . run $ lgDebug "Obtaining odb for repository"
        (_,odbPtr) <- flip allocate c'git_odb_free $ do
            r <- c'git_repository_odb odbPtrPtr repoPtr
            checkResult r "c'git_repository_odb failed"
            peek odbPtrPtr

        lift_ . run $ lgDebug "Opening pack writer into odb"
        writepackPtr <- liftIO $ do
            r <- c'git_odb_write_pack writepackPtrPtr odbPtr
                nullFunPtr nullPtr
            checkResult r "c'git_odb_write_pack failed"
            peek writepackPtrPtr
        writepack <- liftIO $ peek writepackPtr

        bs <- liftIO $ B.readFile packFile
        lift_ . run $
            lgDebug $ "Writing pack file " ++ show packFile ++ " into odb"
        lift_ . run $
            lgDebug $ "Writing " ++ show (B.length bs) ++ " pack bytes into odb"
        liftIO $ BU.unsafeUseAsCStringLen bs $
            uncurry $ \dataPtr dataLen -> do
                r <- mK'git_odb_writepack_add_callback
                         (c'git_odb_writepack'add writepack)
                         writepackPtr (castPtr dataPtr)
                         (fromIntegral dataLen) statsPtr
                checkResult r "c'git_odb_writepack'add failed"

        lift_ . run $ lgDebug "Committing pack into odb"
        r <- liftIO $ mK'git_odb_writepack_commit_callback
                 (c'git_odb_writepack'commit writepack) writepackPtr
                 statsPtr
        checkResult r "c'git_odb_writepack'commit failed"

lgLoadPackFileInMemory
    :: (MonadBaseControl IO m, MonadIO m, MonadExcept m)
    => FilePath
    -> Ptr (Ptr C'git_odb_backend)
    -> Ptr (Ptr C'git_odb)
    -> m (Ptr C'git_odb)
lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr = do
    lgDebug "Create temporary, in-memory object database"
    odbPtr <- liftIO $ do
        r <- c'git_odb_new odbPtrPtr
        checkResult r "c'git_odb_new failed"
        peek odbPtrPtr

    lgDebug $ "Load pack index " ++ show idxPath ++ " into temporary odb"
    bracketOnError
        (do r <- liftIO $ withCString idxPath $ \idxPathStr ->
                c'git_odb_backend_one_pack backendPtrPtr idxPathStr
            checkResult r "c'git_odb_backend_one_pack failed"
            liftIO $ peek backendPtrPtr)
        (\backendPtr -> liftIO $ do
            backend <- peek backendPtr
            mK'git_odb_backend_free_callback
                (c'git_odb_backend'free backend) backendPtr)
        (\backendPtr -> do
            -- Associate the new backend containing our single index file with
            -- the in-memory object database
            lgDebug "Associate odb with backend"
            r <- liftIO $ c'git_odb_add_backend odbPtr backendPtr 1
            checkResult r "c'git_odb_add_backend failed")

    return odbPtr

lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m)
               => FilePath -> m (Ptr C'git_odb)
lgOpenPackFile idxPath = control $ \run ->
    alloca $ \odbPtrPtr ->
    alloca $ \backendPtrPtr -> run $
        lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr

lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m)
               => Ptr C'git_odb -> m ()
lgClosePackFile = liftIO . c'git_odb_free

lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m)
               => FilePath -> (Ptr C'git_odb -> m a) -> m a
lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile

lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadExcept m)
               => Ptr C'git_odb -> Git.SHA -> Bool
               -> m (Maybe (C'git_otype, CSize, ByteString))
lgReadFromPack odbPtr sha metadataOnly = liftIO $ do
    foid <- shaToCOid sha
    if metadataOnly
        then readMetadata odbPtr foid
        else readObject odbPtr foid
  where
    readMetadata odbPtr foid = alloca $ \sizePtr -> alloca $ \typPtr -> do
        r <- withForeignPtr foid $
             c'git_odb_read_header sizePtr typPtr odbPtr
        if r == 0
            then Just <$> ((,,) <$> peek typPtr
                                <*> peek sizePtr
                                <*> pure B.empty)
            else do
                unless (r == c'GIT_ENOTFOUND) $
                    checkResult r "c'git_odb_read_header failed"
                return Nothing

    readObject odbPtr foid = alloca $ \objectPtrPtr -> do
        r <- withForeignPtr foid $
             c'git_odb_read objectPtrPtr odbPtr
        mr <- if r == 0
              then Just <$> peek objectPtrPtr
              else do
                  unless (r == c'GIT_ENOTFOUND) $
                      checkResult r "c'git_odb_read failed"
                  return Nothing
        forM mr $ \objectPtr -> do
            typ <- c'git_odb_object_type objectPtr
            len <- c'git_odb_object_size objectPtr
            ptr <- c'git_odb_object_data objectPtr
            bytes <- curry B.packCStringLen (castPtr ptr)
                         (fromIntegral len)
            c'git_odb_object_free objectPtr
            return (typ,len,bytes)

lgRemoteFetch :: MonadLg m => Text -> Text -> ReaderT LgRepo m ()
lgRemoteFetch uri fetchSpec = do
    xferRepo <- Git.getRepository
    liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr ->
        withCString (unpack uri) $ \uriStr ->
        withCString (unpack fetchSpec) $ \fetchStr ->
            alloca $ runResourceT . go repoPtr uriStr fetchStr
  where
    go repoPtr uriStr fetchStr remotePtrPtr = do
        (_,remotePtr) <- flip allocate c'git_remote_free $ do
            r <- c'git_remote_create_inmemory remotePtrPtr repoPtr
                     fetchStr uriStr
            checkResult r "c'git_remote_create_inmemory failed"
            peek remotePtrPtr

        r1 <- liftIO $ c'git_remote_connect remotePtr c'GIT_DIRECTION_FETCH
        checkResult r1 "c'git_remote_connect failed"
        void $ register $ c'git_remote_disconnect remotePtr

        r2 <- liftIO $ c'git_remote_download remotePtr nullFunPtr nullPtr
        checkResult r2 "c'git_remote_download failed"

lgFactory :: MonadIO m
          => Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo
lgFactory = Git.RepositoryFactory
    { Git.openRepository = openLgRepository
    , Git.runRepository  = runLgRepository
    }

runLgRepository :: LgRepo -> ReaderT LgRepo m a -> m a
runLgRepository = flip runReaderT

openLgRepository :: MonadIO m => Git.RepositoryOptions -> m LgRepo
openLgRepository opts = do
    startupLgBackend
    let path = Git.repoPath opts
    p <- liftIO $ doesDirectoryExist path
    liftIO $ openRepositoryWith path $
        if not (Git.repoAutoCreate opts) || p
        then c'git_repository_open
        else \x y -> c'git_repository_init x y
                         (fromBool (Git.repoIsBare opts))
  where
    openRepositoryWith path fn = do
        fptr <- alloca $ \ptr ->
            withCString path $ \str -> do
                r <- fn ptr str
                when (r < 0) $
                    error $ "Could not open repository " ++ show path
                ptr' <- peek ptr
                FC.newForeignPtr ptr' (c'git_repository_free ptr')
        excTrap <- newIORef Nothing
        return LgRepo
            { repoOptions = opts
            , repoObj     = fptr
            , repoExcTrap = excTrap
            }

startupLgBackend :: MonadIO m => m ()
startupLgBackend = liftIO (void c'git_threads_init)

shutdownLgBackend :: MonadIO m => m ()
shutdownLgBackend = liftIO c'git_threads_shutdown

-- Libgit2.hs
