diff --git a/Data/Git.hs b/Data/Git.hs deleted file mode 100644 --- a/Data/Git.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-| @gitlib@ is a high-level, lazy and conduit-aware type wrapper around the - libgit2 C library (). The aim is both - type-safety and convenience of use for Haskell users, combined with high - performance and minimal memory footprint by taking advantage of Haskell's - laziness and the conduit library's deterministic resource cleanup. - - For further information, as well as typical use cases, see - "Data.Git.Tutorial". --} - -module Data.Git ( - module Data.Git.Repository, - -- module Data.Git.Config, - -- module Data.Git.Tag, - -- module Data.Git.Reflog, - module Data.Git.Commit, - -- module Data.Git.Index, - module Data.Git.Blob, - module Data.Git.Error, - module Data.Git.Oid, - module Data.Git.Tree, - module Data.Git.Reference, - -- module Data.Git.Odb, - module Data.Git.Common, - module Data.Git.Object -) where - -import Data.Git.Repository --- import Data.Git.Config --- import Data.Git.Tag --- import Data.Git.Reflog -import Data.Git.Commit --- import Data.Git.Index -import Data.Git.Blob -import Data.Git.Error -import Data.Git.Oid -import Data.Git.Tree -import Data.Git.Reference --- import Data.Git.Odb -import Data.Git.Common -import Data.Git.Object diff --git a/Data/Git/Backend.hs b/Data/Git/Backend.hs deleted file mode 100644 --- a/Data/Git/Backend.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Backend - ( odbBackendAdd - - , F'git_odb_backend_read_callback - , F'git_odb_backend_read_prefix_callback - , F'git_odb_backend_readstream_callback - , F'git_odb_backend_read_header_callback - , F'git_odb_backend_write_callback - , F'git_odb_backend_writestream_callback - , F'git_odb_backend_exists_callback - , F'git_odb_backend_free_callback - ) - where - -import Data.Git.Error -import Data.Git.Internal -import qualified Prelude - -type F'git_odb_backend_read_callback = - Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend - -> Ptr C'git_oid -> IO CInt -type F'git_odb_backend_read_prefix_callback = - Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype - -> Ptr C'git_odb_backend -> Ptr C'git_oid -> CUInt -> IO CInt -type F'git_odb_backend_readstream_callback = - Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> Ptr C'git_oid - -> IO CInt -type F'git_odb_backend_read_header_callback = - Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid - -> IO CInt -type F'git_odb_backend_write_callback = - Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr () -> CSize -> C'git_otype - -> IO CInt -type F'git_odb_backend_writestream_callback = - Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> CSize - -> C'git_otype -> IO CInt -type F'git_odb_backend_exists_callback = - Ptr C'git_odb_backend -> Ptr C'git_oid -> IO CInt -type F'git_odb_backend_free_callback = Ptr C'git_odb_backend -> IO () - -odbBackendAdd :: Repository -> Ptr C'git_odb_backend -> Int - -> IO (Result Repository) -odbBackendAdd repo backend priority = - withForeignPtr (repoObj repo) $ \repoPtr -> - alloca $ \odbPtr -> do - r <- c'git_repository_odb odbPtr repoPtr - if r < 0 - then return (Left "Cannot get repository ODB") - else do - odb <- peek odbPtr - r2 <- c'git_odb_add_backend odb backend (fromIntegral priority) - if r2 < 0 - then return (Left "Cannot add backend to repository ODB") - else return (Right repo) - --- Backend.hs diff --git a/Data/Git/Backend/Trace.hs b/Data/Git/Backend/Trace.hs deleted file mode 100644 --- a/Data/Git/Backend/Trace.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LiberalTypeSynonyms #-} -{-# LANGUAGE ImpredicativeTypes #-} - -module Data.Git.Backend.Trace ( traceBackend ) where - -import Data.ByteString.Unsafe -import Data.Git.Backend -import Data.Git.Error -import Data.Git.Internal -import Data.Git.Oid -import Debug.Trace (trace) -import Prelude hiding ((.), mapM_) - -data TraceBackend = TraceBackend { traceParent :: C'git_odb_backend - , traceNext :: Ptr C'git_odb_backend } - -instance Storable TraceBackend where - sizeOf p = sizeOf (undefined :: C'git_odb_backend) + - sizeOf (undefined :: Ptr C'git_odb_backend) - alignment p = alignment (traceParent p) - peek p = do - v0 <- peekByteOff p 0 - v1 <- peekByteOff p (sizeOf (undefined :: C'git_odb_backend)) - return (TraceBackend v0 v1) - poke p (TraceBackend v0 v1) = do - pokeByteOff p 0 v0 - pokeByteOff p (sizeOf (undefined :: C'git_odb_backend)) v1 - return () - -traceBackendReadCallback :: F'git_odb_backend_read_callback -traceBackendReadCallback data_p len_p type_p be oid = do - oidStr <- oidToStr oid - putStrLn $ "Read " ++ oidStr - tb <- peek (castPtr be :: Ptr TraceBackend) - tn <- peek (traceNext tb) - (mK'git_odb_backend_read_callback (c'git_odb_backend'read tn)) - data_p len_p type_p (traceNext tb) oid - -traceBackendReadPrefixCallback :: F'git_odb_backend_read_prefix_callback -traceBackendReadPrefixCallback out_oid oid_p len_p type_p be oid len = do - oidStr <- oidToStr oid - putStrLn $ "Read Prefix " ++ oidStr ++ " " ++ show len - tb <- peek (castPtr be :: Ptr TraceBackend) - tn <- peek (traceNext tb) - (mK'git_odb_backend_read_prefix_callback (c'git_odb_backend'read_prefix tn)) - out_oid oid_p len_p type_p (traceNext tb) oid len - -traceBackendReadHeaderCallback :: F'git_odb_backend_read_header_callback -traceBackendReadHeaderCallback len_p type_p be oid = do - oidStr <- oidToStr oid - putStrLn $ "Read Header " ++ oidStr - tb <- peek (castPtr be :: Ptr TraceBackend) - tn <- peek (traceNext tb) - (mK'git_odb_backend_read_header_callback (c'git_odb_backend'read_header tn)) - len_p type_p (traceNext tb) oid - -traceBackendWriteCallback :: F'git_odb_backend_write_callback -traceBackendWriteCallback oid be obj_data len obj_type = do - r <- c'git_odb_hash oid obj_data len obj_type - case r of - 0 -> do - oidStr <- oidToStr oid - putStrLn $ "Write " ++ oidStr ++ " len " ++ show len - tb <- peek (castPtr be :: Ptr TraceBackend) - tn <- peek (traceNext tb) - (mK'git_odb_backend_write_callback (c'git_odb_backend'write tn)) - oid (traceNext tb) obj_data len obj_type - n -> return n - -traceBackendExistsCallback :: F'git_odb_backend_exists_callback -traceBackendExistsCallback be oid = do - oidStr <- oidToStr oid - putStrLn $ "Exists " ++ oidStr - tb <- peek (castPtr be :: Ptr TraceBackend) - tn <- peek (traceNext tb) - (mK'git_odb_backend_exists_callback (c'git_odb_backend'exists tn)) - (traceNext tb) oid - -traceBackendFreeCallback :: F'git_odb_backend_free_callback -traceBackendFreeCallback be = do - backend <- peek be - freeHaskellFunPtr (c'git_odb_backend'read backend) - freeHaskellFunPtr (c'git_odb_backend'read_prefix backend) - freeHaskellFunPtr (c'git_odb_backend'read_header backend) - freeHaskellFunPtr (c'git_odb_backend'write backend) - freeHaskellFunPtr (c'git_odb_backend'exists backend) - -foreign export ccall "traceBackendFreeCallback" - traceBackendFreeCallback :: F'git_odb_backend_free_callback -foreign import ccall "&traceBackendFreeCallback" - traceBackendFreeCallbackPtr :: FunPtr F'git_odb_backend_free_callback - -traceBackend :: Ptr C'git_odb_backend -> IO (Ptr C'git_odb_backend) -traceBackend be = do - readFun <- mk'git_odb_backend_read_callback traceBackendReadCallback - readPrefixFun <- - mk'git_odb_backend_read_prefix_callback traceBackendReadPrefixCallback - readHeaderFun <- - mk'git_odb_backend_read_header_callback traceBackendReadHeaderCallback - writeFun <- mk'git_odb_backend_write_callback traceBackendWriteCallback - existsFun <- mk'git_odb_backend_exists_callback traceBackendExistsCallback - - castPtr <$> new TraceBackend { - traceParent = C'git_odb_backend { - c'git_odb_backend'odb = nullPtr - , c'git_odb_backend'read = readFun - , c'git_odb_backend'read_prefix = readPrefixFun - , c'git_odb_backend'readstream = nullFunPtr - , c'git_odb_backend'read_header = readHeaderFun - , c'git_odb_backend'write = writeFun - , c'git_odb_backend'writestream = nullFunPtr - , c'git_odb_backend'exists = existsFun - , c'git_odb_backend'free = traceBackendFreeCallbackPtr } - , traceNext = be } - --- Trace.hs diff --git a/Data/Git/Blob.hs b/Data/Git/Blob.hs deleted file mode 100644 --- a/Data/Git/Blob.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternGuards #-} - -module Data.Git.Blob - ( Blob(..) - , BlobContents(..) - , ByteSource - , newBlobBase - , createBlob - , getBlobContents - , blobSourceToString - , lookupBlob - , writeBlob ) - where - -import Data.ByteString as B hiding (map) -import Data.ByteString.Unsafe -import Data.Conduit -import Data.Git.Common -import Data.Git.Error -import Data.Git.Internal -import qualified Prelude - -data BlobContents = BlobEmpty - | BlobString B.ByteString - | BlobStream ByteSource - -instance Eq BlobContents where - BlobEmpty == BlobEmpty = True - BlobString str1 == BlobString str2 = str1 == str2 - BlobStream src1 == BlobStream src2 = False - _ == _ = False - -blobSourceToString :: BlobContents -> IO (Maybe B.ByteString) -blobSourceToString BlobEmpty = return Nothing -blobSourceToString (BlobString bs) = return (Just bs) -blobSourceToString (BlobStream bs) = do str <- bs $$ await - case str of - Nothing -> return Nothing - Just str' -> return (Just str') - -data Blob = Blob { blobInfo :: Base Blob - , blobContents :: BlobContents } - deriving Eq - -instance Show Blob where - show x = case gitId (blobInfo x) of - Pending _ -> "Blob..." - Stored y -> "Blob#" ++ show y - -instance Updatable Blob where - getId = gitId . blobInfo - objectRepo = gitRepo . blobInfo - objectPtr = gitObj . blobInfo - update = writeBlob - lookupFunction = lookupBlob -#if defined(PROFILING) - loadObject' x y = - maybe (throwIO ObjectLookupFailed) return =<< loadObject x y -#endif - -newBlobBase :: Blob -> Base Blob -newBlobBase b = newBase (gitRepo (blobInfo b)) (Pending doWriteBlob) Nothing - --- | 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 give string is 'empty', it is an error. -createBlob :: Repository -> B.ByteString -> Blob -createBlob repo text - | text == B.empty = error "Cannot create an empty blob" - | otherwise = - Blob { blobInfo = newBase repo (Pending doWriteBlob) Nothing - , blobContents = BlobString text } - -lookupBlob :: Repository -> Oid -> IO (Maybe Blob) -lookupBlob repo oid = - lookupObject' repo oid c'git_blob_lookup c'git_blob_lookup_prefix $ - \coid obj _ -> - return Blob { blobInfo = newBase repo (Stored coid) (Just obj) - , blobContents = BlobEmpty } - -getBlobContents :: Blob -> IO (Blob, BlobContents) -getBlobContents b@(gitId . blobInfo -> Pending _) = return (b, blobContents b) -getBlobContents b@(gitId . blobInfo -> Stored hash) - | BlobEmpty <- contents = - case gitObj (blobInfo b) of - Just blobPtr -> - withForeignPtr blobPtr $ \ptr -> do - size <- c'git_blob_rawsize (castPtr ptr) - buf <- c'git_blob_rawcontent (castPtr ptr) - -- The lifetime of buf is tied to the lifetime of the blob object in - -- libgit2, which this Blob object controls, so we can use - -- unsafePackCStringLen to refer to its bytes. - bstr <- curry unsafePackCStringLen (castPtr buf) - (fromIntegral size) - let contents' = BlobString bstr - return (b { blobContents = contents' }, contents' ) - - Nothing -> do - b' <- lookupBlob repo (Oid hash) - case b' of - Just blobPtr' -> getBlobContents blobPtr' - Nothing -> return (b, BlobEmpty) - - | otherwise = return (b, contents) - - where repo = gitRepo (blobInfo b) - contents = blobContents b - --- | Write out a blob to its repository. If it has already been written, --- nothing will happen. -writeBlob :: Blob -> IO Blob -writeBlob b@(Blob { blobInfo = Base { gitId = Stored _ } }) = return b -writeBlob b = do hash <- doWriteBlob b - return b { blobInfo = (blobInfo b) { gitId = Stored hash } - , blobContents = BlobEmpty } - --- jww (2012-12-14): Have the write functions return Either instead -doWriteBlob :: Blob -> IO COid -doWriteBlob b = do - ptr <- mallocForeignPtr - r <- withForeignPtr (repoObj (gitRepo (blobInfo b))) - (createFromBuffer ptr) - when (r < 0) $ throwIO BlobCreateFailed - return (COid ptr) - - where - createFromBuffer ptr repoPtr = - maybe (throw BlobCreateFailed) - (createBlobFromByteString ptr repoPtr) - =<< blobSourceToString (blobContents b) - - createBlobFromByteString ptr repoPtr bs = - unsafeUseAsCStringLen bs $ - uncurry (\cstr len -> - withForeignPtr ptr $ \ptr' -> - c'git_blob_create_frombuffer - ptr' repoPtr (castPtr cstr) (fromIntegral len)) - --- Blob.hs diff --git a/Data/Git/Commit.hs b/Data/Git/Commit.hs deleted file mode 100644 --- a/Data/Git/Commit.hs +++ /dev/null @@ -1,274 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Commit - ( Commit(..) - , PinnedEntry(..) - , newCommitBase - , createCommit - , lookupCommit - , lookupRefCommit - , addCommitParent - , writeCommit - , getCommitParents - , modifyCommitTree - , removeFromCommitTree - , updateCommit - , commitHistoryFirstParent - , commitEntry - , commitEntryHistory ) - where - -import Bindings.Libgit2 -import qualified Data.ByteString as BS -import Data.ByteString.Unsafe -import Data.Git.Common -import Data.Git.Internal -import Data.Git.Reference -import Data.Git.Tree -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import qualified Data.Text.ICU.Convert as U -import qualified Foreign.Concurrent as FC -import qualified Foreign.ForeignPtr.Unsafe as FU -import Foreign.Marshal.Array -import qualified Prelude - -data Commit = Commit { commitInfo :: Base Commit - , commitAuthor :: Signature - , commitCommitter :: Signature - , commitLog :: Text - , commitEncoding :: Prelude.String - , commitTree :: ObjRef Tree - , commitParents :: [ObjRef Commit] - , commitObj :: ObjPtr C'git_commit } - -instance Show Commit where - show x = case gitId (commitInfo x) of - Pending _ -> "Commit..." - Stored y -> "Commit#" ++ show y ++ " <" ++ show (commitTree x) ++ ">" - -instance Updatable Commit where - getId x = gitId (commitInfo x) - objectRepo x = gitRepo (commitInfo x) - objectPtr x = gitObj (commitInfo x) - update = flip writeCommit Nothing - lookupFunction = lookupCommit -#if defined(PROFILING) - loadObject' x y = - maybe (throwIO ObjectLookupFailed) return =<< loadObject x y -#endif - -newCommitBase :: Commit -> Base Commit -newCommitBase t = - newBase (gitRepo (commitInfo t)) - (Pending (flip doWriteCommit Nothing >=> return . snd)) Nothing - --- | Create a new, empty commit. --- --- Since empty commits cannot exist in Git, attempting to write out an empty --- commit is a no-op. -createCommit :: Repository -> Signature -> Commit -createCommit repo sig = - Commit { commitInfo = - newBase repo (Pending (flip doWriteCommit Nothing >=> return . snd)) - Nothing - , commitAuthor = sig - , commitCommitter = sig - , commitTree = ObjRef (createTree repo) - , commitParents = [] - , commitLog = T.empty - , commitEncoding = "" - , commitObj = Nothing } - -lookupCommit :: Repository -> Oid -> IO (Maybe Commit) -lookupCommit repo oid = - lookupObject' repo oid c'git_commit_lookup c'git_commit_lookup_prefix $ - \coid obj _ -> - withForeignPtr obj $ \cobj -> do - let c = castPtr cobj - - 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 >>= BS.packCString - auth <- c'git_commit_author c >>= packSignature conv - comm <- c'git_commit_committer c >>= packSignature conv - toid <- c'git_commit_tree_oid c >>= wrapOidPtr - - pn <- c'git_commit_parentcount c - poids <- traverse wrapOidPtr - =<< sequence - (zipWith ($) (replicate (fromIntegral (toInteger pn)) - (c'git_commit_parent_oid c)) - [0..pn]) - - return Commit { commitInfo = newBase repo (Stored coid) (Just obj) - , commitAuthor = auth - , commitCommitter = comm - , commitTree = toid - , commitParents = poids - , commitLog = U.toUnicode conv msg - , commitEncoding = encs - , commitObj = Just $ unsafeCoerce obj } - -lookupRefCommit :: Repository -> Text -> IO (Maybe Commit) -lookupRefCommit repo ref = do - oid <- resolveRef repo ref - maybe (return Nothing) (lookupCommit repo) oid - -addCommitParent :: Commit -> Commit -> Commit -addCommitParent co p = co { commitParents = commitParents co ++ [ObjRef p] } - --- | Write out a commit to its repository. If it has already been written, --- nothing will happen. -writeCommit :: Commit -> Maybe Text -> IO Commit -writeCommit c@(Commit { commitInfo = Base { gitId = Stored _ } }) _ = - return c -writeCommit c ref = fst <$> doWriteCommit c ref - -withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b -withForeignPtrs fos io - = do r <- io (map FU.unsafeForeignPtrToPtr fos) - mapM touchForeignPtr fos - return r - -doWriteCommit :: Commit -> Maybe Text -> IO (Commit, COid) -doWriteCommit c ref = do - coid <- withForeignPtr (repoObj (gitRepo (commitInfo c))) $ \repoPtr -> do - coid <- mallocForeignPtr - withForeignPtr coid $ \coid' -> do - conv <- U.open (commitEncoding c) (Just True) - BS.useAsCString (U.fromUnicode conv (commitLog c)) $ \message -> - withRef ref $ \update_ref -> - withSignature conv (commitAuthor c) $ \author -> - withSignature conv (commitCommitter c) $ \committer -> - withEncStr (commitEncoding c) $ \message_encoding -> - withGitTree (commitTree c) c $ \commit_tree -> do - parentPtrs <- getCommitParentPtrs c - withForeignPtrs parentPtrs $ \pptrs -> do - parents <- newArray pptrs - r <- c'git_commit_create coid' repoPtr - update_ref author committer - message_encoding message commit_tree - (fromIntegral (length (commitParents c))) - parents - when (r < 0) $ throwIO CommitCreateFailed - return coid - - return (c { commitInfo = (commitInfo c) { gitId = Stored (COid coid) } } - , COid coid) - - where - withRef Nothing = flip ($) nullPtr - withRef (Just name) = BS.useAsCString (E.encodeUtf8 name) - - withEncStr "" = flip ($) nullPtr - withEncStr enc = withCString enc - -getCommitParents :: Commit -> IO [Commit] -getCommitParents c = - traverse (\p -> do parent <- loadObject p c - case parent of - Nothing -> error "Cannot find Git commit" - Just p' -> return p') - (commitParents c) - -getCommitParentPtrs :: Commit -> IO [ForeignPtr C'git_commit] -getCommitParentPtrs c = - withForeignPtr (repositoryPtr (objectRepo c)) $ \repoPtr -> - for (commitParents c) $ \p -> - case p of - ObjRef (Commit { commitObj = Just obj }) -> return obj - _ -> do - Oid (COid oid) <- - case p of - IdRef coid -> return $ Oid coid - ObjRef x -> objectId x - - withForeignPtr oid $ \commit_id -> - alloca $ \ptr -> do - r <- c'git_commit_lookup ptr repoPtr commit_id - when (r < 0) $ throwIO CommitLookupFailed - ptr' <- peek ptr - FC.newForeignPtr ptr' (c'git_commit_free ptr') - -modifyCommitTree - :: Commit -> FilePath -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool - -> IO (Either a Commit) -modifyCommitTree c path f createIfNotExist = - withObject (commitTree c) c $ \tr -> do - result <- modifyTree path f createIfNotExist tr - case result of - Left x -> return (Left x) - Right tr' -> return $ Right $ c { commitTree = ObjRef tr' } - -removeFromCommitTree :: Commit -> FilePath -> IO Commit -removeFromCommitTree c path = - withObject (commitTree c) c $ \tr -> do - tr' <- removeFromTree path tr - return c { commitTree = ObjRef tr' } - -doUpdateCommit :: Commit -> [Text] -> TreeEntry -> IO Commit -doUpdateCommit c xs item = do - t <- loadObject (commitTree c) c - case t of - Nothing -> throwIO CommitLookupFailed - Just t' -> do - newt <- doUpdateTree t' xs item - return c { commitTree = ObjRef newt - , commitInfo = - newBase (objectRepo c) - (Pending (flip doWriteCommit Nothing - >=> return . snd)) Nothing - , commitObj = Nothing } - -updateCommit :: Commit -> FilePath -> TreeEntry -> IO Commit -updateCommit c = doUpdateCommit c . splitPath - -commitHistoryFirstParent :: Commit -> IO [Commit] -commitHistoryFirstParent c = - case commitParents c of - [] -> return [c] - (p:_) -> do p' <- loadObject' p c - ps <- commitHistoryFirstParent p' - return (c:ps) - -commitEntry :: Commit -> FilePath -> IO (Maybe TreeEntry) -commitEntry c path = - flip lookupTreeEntry path =<< loadObject' (commitTree c) c - -data PinnedEntry = PinnedEntry { pinnedOid :: Oid - , pinnedCommit :: Commit - , pinnedEntry :: TreeEntry } - deriving Show - -identifyEntry :: Commit -> TreeEntry -> IO PinnedEntry -identifyEntry co x = do - oid <- case x of - BlobEntry blob _ -> objectRefId blob - TreeEntry tree -> objectRefId tree - return (PinnedEntry oid co x) - -commitEntryHistory :: Commit -> FilePath -> IO [PinnedEntry] -commitEntryHistory c path = map head - . filter (not . null) - . groupBy ((==) `on` pinnedOid) <$> go c - where go co = do - entry <- getEntry co - rest <- case commitParents co of - [] -> return [] - (p:_) -> go =<< loadObject' p co - return $ maybe rest (:rest) entry - - getEntry co = do - ce <- commitEntry co path - case ce of - Nothing -> return Nothing - Just ce' -> Just <$> identifyEntry co ce' - --- Commit.hs diff --git a/Data/Git/Common.hs b/Data/Git/Common.hs deleted file mode 100644 --- a/Data/Git/Common.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Common - ( Signature(..) - , createSignature - , packSignature - , withSignature - - , Base(..) - , newBase ) - where - -import qualified Data.ByteString as BS -import Data.Git.Internal -import qualified Data.Text as T -import qualified Data.Text.ICU.Convert as U -import Data.Time -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, - utcTimeToPOSIXSeconds) -import qualified Prelude - -data Signature = Signature { signatureName :: Text - , signatureEmail :: Text - , signatureWhen :: UTCTime } - deriving (Show, Eq) - --- | Convert a time in seconds (from Stripe's servers) to 'UTCTime'. See --- "Data.Time.Format" for more on working with 'UTCTime'. -fromSeconds :: Integer -> UTCTime -fromSeconds = posixSecondsToUTCTime . fromInteger - --- | Convert a 'UTCTime' back to an Integer suitable for use with Stripe's API. -toSeconds :: UTCTime -> Integer -toSeconds = round . utcTimeToPOSIXSeconds - -peekGitTime :: Ptr (C'git_time) -> IO UTCTime -peekGitTime time = - -- jww (2012-09-29): Handle offset here - return . fromSeconds . toInteger . c'git_time'time =<< peek time - -packGitTime :: UTCTime -> C'git_time -packGitTime utcTime = - C'git_time { c'git_time'time = fromIntegral (toSeconds utcTime) - , c'git_time'offset = 0 } -- jww (2012-09-29): NYI - -createSignature :: Signature -createSignature = - Signature { signatureName = T.empty - , signatureEmail = T.empty - , signatureWhen = - UTCTime { utctDay = - ModifiedJulianDay { - toModifiedJulianDay = 0 } - , utctDayTime = secondsToDiffTime 0 } } - -packSignature :: U.Converter -> Ptr C'git_signature -> IO Signature -packSignature conv sig = do - name <- peek (p'git_signature'name sig) >>= BS.packCString - email <- peek (p'git_signature'email sig) >>= BS.packCString - time <- peekGitTime (p'git_signature'when sig) - return $ - Signature { signatureName = U.toUnicode conv name - , signatureEmail = U.toUnicode conv email - , signatureWhen = time } - -withSignature :: U.Converter -> Signature - -> (Ptr C'git_signature -> IO a) -> IO a -withSignature conv sig f = - BS.useAsCString (U.fromUnicode conv (signatureName sig)) $ \nameCStr -> - BS.useAsCString (U.fromUnicode conv (signatureEmail sig)) $ \emailCStr -> - alloca $ \ptr -> do - poke ptr (C'git_signature nameCStr emailCStr - (packGitTime (signatureWhen sig))) - f ptr - --- Common.hs diff --git a/Data/Git/Error.hs b/Data/Git/Error.hs deleted file mode 100644 --- a/Data/Git/Error.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Error types which may be thrown during Git operations, using --- 'Control.Exception.throwIO'. -module Data.Git.Error - ( GitException(..), Result ) - where - -import Control.Exception -import Data.Typeable -import Data.Text -import Prelude hiding (FilePath) - --- | There is a separate 'GitException' for each possible failure when --- interacting with the Git repository. -data GitException = RepositoryNotExist String - | RepositoryInvalid - | BlobCreateFailed - | BlobEmptyCreateFailed - | TreeCreateFailed - | TreeBuilderCreateFailed - | TreeBuilderInsertFailed - | TreeBuilderWriteFailed - | TreeLookupFailed - | TreeCannotTraverseBlob - | TreeEntryLookupFailed - | TreeUpdateFailed - | CommitCreateFailed - | CommitLookupFailed - | ReferenceCreateFailed - | RefCannotCreateFromPartialOid - | ReferenceLookupFailed - | ObjectLookupFailed - | ObjectIdTooLong - | ObjectRefRequiresFullOid - | OidCopyFailed - deriving (Show, Typeable) - -type Result = Either Text - -instance Exception GitException - --- Error.hs diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs deleted file mode 100644 --- a/Data/Git/Internal.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - -module Data.Git.Internal - ( ObjPtr - , ByteSource - - , Updatable(..) - - , Base(..), newBase - - , Repository(..) - , openRepository - , createRepository - , openOrCreateRepository - , repositoryPtr - - , lookupObject' - , withObject - , withObjectPtr - - , RefTarget(..) - , Reference(..) - - , module X ) - where - -import Bindings.Libgit2 as X -import Control.Applicative as X -import Control.Category as X -import Control.Exception as X -import Control.Lens as X -import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_, - forM, forM_, msum, unless, guard) -import Data.Bool as X -import Data.ByteString as B hiding (map) -import Data.Conduit -import Data.Either as X hiding (lefts, rights) -import Data.Foldable as X -import Data.Function as X hiding ((.), id) -import Data.Git.Error as X -import Data.Git.Oid as X -import Data.List as X hiding (foldl, foldl', foldl1, foldr1, foldl1', - foldr, concat, maximum, minimum, - product, sum, all, and, any, concatMap, - elem, notElem, or, find, mapAccumL, - mapAccumR, maximumBy, minimumBy) -import Data.Maybe as X -import Data.Monoid as X -import Data.Stringable as X hiding (length) -import Data.Text as X (Text) -import Data.Tuple as X -import Data.Traversable as X -import Filesystem as X hiding (createTree) -import qualified Filesystem.Path.CurrentOS as F -import Filesystem.Path.CurrentOS as X (FilePath) -import Foreign.C.String as X -import Foreign.C.Types as X -import Foreign.ForeignPtr as X -import Foreign.Marshal.Alloc as X -import Foreign.Marshal.Utils as X -import Foreign.Ptr as X -import Foreign.StablePtr as X -import Foreign.Storable as X -import Prelude as X (undefined, error, otherwise, IO, Show, show, - Enum, Eq, Ord, (<), (==), (/=), round, Int, - Integer, fromIntegral, fromInteger, toInteger, - putStrLn, (-), (+)) -import Unsafe.Coerce as X - -type ObjPtr a = Maybe (ForeignPtr a) - -type ByteSource = GSource IO B.ByteString - -class Updatable a where - getId :: a -> Ident a - objectRepo :: a -> Repository - objectPtr :: a -> ObjPtr C'git_object - - update :: a -> IO a - update_ :: a -> IO () - update_ = void . update - - objectId :: a -> IO Oid - objectId x = case getId x of - Pending f -> Oid <$> f x - Stored y -> return $ Oid y - - objectRef :: a -> IO (ObjRef a) - objectRef x = do - oid <- objectId x - case oid of - Oid coid -> return (IdRef coid) - PartialOid _ _ -> error "Did not expect to see a PartialOid" - - objectRefId :: ObjRef a -> IO Oid - objectRefId (IdRef coid) = return (Oid coid) - objectRefId (ObjRef x) = objectId x - - maybeObjectId :: a -> Maybe Oid - maybeObjectId x = case getId x of - Pending _ -> Nothing - Stored y -> Just (Oid y) - - lookupFunction :: Repository -> Oid -> IO (Maybe a) - - loadObject :: Updatable b => ObjRef a -> b -> IO (Maybe a) - loadObject (IdRef coid) y = lookupFunction (objectRepo y) (Oid coid) - loadObject (ObjRef x) _ = return (Just x) - - loadObject' :: Updatable b => ObjRef a -> b -> IO a - loadObject' x y = - maybe (throwIO ObjectLookupFailed) return =<< loadObject x y - - getObject :: ObjRef a -> Maybe a - getObject (IdRef _) = Nothing - getObject (ObjRef x) = Just x - -data Repository = Repository - { repoPath :: FilePath - -- jww (2013-01-21): These two callbacks are a temporary workaround until - -- libgit2 supports full virtualization of repositories. See: - -- https://github.com/libgit2/libgit2/issues/1213 - , repoBeforeReadRef :: [Repository -> Text -> IO ()] - , repoOnWriteRef :: [Repository -> Reference -> IO ()] - , repoObj :: ForeignPtr C'git_repository - } - -instance Eq Repository where - x == y = repoPath x == repoPath y && repoObj x == repoObj y - -instance Show Repository where - show x = "Repository " <> toString (repoPath x) - -data RefTarget = RefTargetId Oid - | RefTargetSymbolic Text - deriving (Show, Eq) - -data Reference = Reference { refRepo :: Repository - , refName :: Text - , refTarget :: RefTarget - , refObj :: ObjPtr C'git_reference } - deriving (Show, Eq) - -data Base a = Base { gitId :: Ident a - , gitRepo :: Repository - , gitObj :: ObjPtr C'git_object } - deriving Eq - -instance Show (Base a) where - show x = case gitId x of - Pending _ -> "Base..." - Stored y -> "Base#" ++ show y - -newBase :: Repository -> Ident a -> ObjPtr C'git_object -> Base a -newBase repo oid obj = Base { gitId = oid - , gitRepo = repo - , gitObj = obj } - -repositoryPtr :: Repository -> ForeignPtr C'git_repository -repositoryPtr repo = repoObj repo - -openRepository :: FilePath -> IO Repository -openRepository path = - openRepositoryWith path c'git_repository_open - -createRepository :: FilePath -> Bool -> IO Repository -createRepository path bare = - openRepositoryWith path (\x y -> c'git_repository_init x y (fromBool bare)) - -openOrCreateRepository :: FilePath -> Bool -> IO Repository -openOrCreateRepository path bare = do - p <- isDirectory path - if p - then openRepository path - else createRepository path bare - -openRepositoryWith :: FilePath - -> (Ptr (Ptr C'git_repository) -> CString -> IO CInt) - -> IO Repository -openRepositoryWith path fn = alloca $ \ptr -> - case F.toText path of - Left p -> doesNotExist p - Right p -> - withCStringable p $ \str -> do - r <- fn ptr str - when (r < 0) $ doesNotExist p - ptr' <- peek ptr - fptr <- newForeignPtr p'git_repository_free ptr' - return Repository { repoPath = path - , repoBeforeReadRef = [] - , repoOnWriteRef = [] - , repoObj = fptr - } - where doesNotExist = throwIO . RepositoryNotExist . toString - -withObject :: (Updatable a, Updatable b) => ObjRef a -> b -> (a -> IO c) -> IO c -withObject objRef parent f = do - obj <- loadObject objRef parent - case obj of - Nothing -> error "Cannot find Git object in repository" - Just obj' -> f obj' - -withObjectPtr :: (Updatable a, Updatable b) - => ObjRef a -> b -> (Ptr c -> IO d) -> IO d -withObjectPtr objRef parent f = - withObject objRef parent $ \obj -> - case objectPtr obj of - Nothing -> error "Cannot find Git object id" - Just objPtr -> withForeignPtr objPtr (f . castPtr) - -lookupObject' - :: Repository -> Oid - -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> IO CInt) - -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> CUInt -> IO CInt) - -> (COid -> ForeignPtr C'git_object -> Ptr C'git_object -> IO b) - -> IO (Maybe b) -lookupObject' repo oid lookupFn lookupPrefixFn createFn = - alloca $ \ptr -> do - r <- withForeignPtr (repositoryPtr repo) $ \repoPtr -> - case oid of - Oid (COid oid') -> - withForeignPtr oid' $ \oidPtr -> - lookupFn ptr repoPtr oidPtr - PartialOid (COid oid') len -> - withForeignPtr oid' $ \oidPtr -> - lookupPrefixFn ptr repoPtr oidPtr (fromIntegral len) - if r < 0 - then return Nothing - else do - ptr' <- castPtr <$> peek ptr - coid <- c'git_object_id ptr' - coidCopy <- mallocForeignPtr - withForeignPtr coidCopy $ flip c'git_oid_cpy coid - - fptr <- newForeignPtr p'git_object_free ptr' - Just <$> createFn (COid coidCopy) fptr ptr' - --- Internal.hs diff --git a/Data/Git/Object.hs b/Data/Git/Object.hs deleted file mode 100644 --- a/Data/Git/Object.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Object - ( Object(..) - , ObjectType(..) - , NamedRef(..) - , revParse - , lookupObject ) - where - -import Data.ByteString as B hiding (map) -import Data.Git.Blob -import Data.Git.Commit -import Data.Git.Internal -import Data.Git.Reference -import Data.Git.Tag -import Data.Git.Tree -import qualified Data.Map as M - -data ObjectType = BlobType | TreeType | CommitType | TagType - -data Object = BlobObj Blob - | TreeObj Tree - | CommitObj Commit - | TagObj Tag - -data NamedRef a = FullHash a - | PartialHash a - | BranchName a - | TagName a - | RefName a - | FullRefName a - | Specifier a - -revParse :: CStringable a => NamedRef a -> IO (Maybe Oid) -revParse (FullHash r) = parseOid r -revParse (PartialHash r) = parseOid r -revParse (BranchName r) = undefined -revParse (TagName r) = undefined -revParse (RefName r) = undefined -revParse (FullRefName r) = undefined -revParse (Specifier r) = undefined - -lookupObject :: Repository -> Oid -> IO (Maybe Object) -lookupObject repo oid = - lookupObject' repo 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 x y -> c'git_object_type y >>= createObject repo coid x) - -lookupRefObject :: Repository -> Text -> IO (Maybe Object) -lookupRefObject repo ref = do - oid <- resolveRef repo ref - maybe (return Nothing) (lookupObject repo) oid - -createObject :: Repository -> COid -> ForeignPtr C'git_object -> C'git_otype - -> IO Object -createObject repo coid obj typ - | typ == c'GIT_OBJ_BLOB = - return $ BlobObj Blob { blobInfo = - newBase repo (Stored coid) (Just obj) - , blobContents = BlobEmpty } - - | typ == c'GIT_OBJ_TREE = - return $ TreeObj Tree { treeInfo = - newBase repo (Stored coid) (Just obj) - , treeContents = M.empty } - - | otherwise = return undefined - --- Object.hs diff --git a/Data/Git/Oid.hs b/Data/Git/Oid.hs deleted file mode 100644 --- a/Data/Git/Oid.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} - --- | The 'Oid' type represents a Git hash value, whether partial or full. In --- general users do not interact with this type much, as all the top-level --- functions which expect hash values typically expect strings. -module Data.Git.Oid - ( Oid(..) - , COid(..) - , oidToStr - , ObjRef(..) - , Ident(..) - , wrapOidPtr - , compareCOid - , compareCOidLen - , equalCOid - , parseOid ) - where - -import Bindings.Libgit2.Oid -import Control.Applicative -import Control.Exception -import Control.Monad -import qualified Data.ByteString.Char8 as BC -import Data.ByteString.Unsafe -import Data.Git.Error -import Data.Stringable as S -import Foreign.C.String -import Foreign.ForeignPtr -import Foreign.Ptr -import System.IO.Unsafe - --- | 'COid' is a type wrapper for a foreign pointer to libgit2's 'git_oid' --- structure. Users should not have to deal with this type. -newtype COid = COid (ForeignPtr C'git_oid) - -oidToStr :: Ptr C'git_oid -> IO String -oidToStr = c'git_oid_allocfmt >=> peekCString - -instance Show COid where - show (COid coid) = unsafePerformIO $ withForeignPtr coid oidToStr - --- | 'ObjRef' refers to either a Git object of a particular type (if it has --- already been loaded into memory), or it refers to the 'COid' of that --- object in the repository. This permits deferred loading of objects --- within potentially very large structures, such as trees and commits. --- However, it also means that every access to a sub-object must use --- loadObject from the type class 'Updatable'. -data ObjRef a = IdRef COid - | ObjRef a - deriving Show - -wrapOidPtr :: Ptr C'git_oid -> IO (ObjRef a) -wrapOidPtr = newForeignPtr_ >=> return . IdRef . COid - --- | An 'Ident' abstracts the fact that some objects won't have an identifier --- until they are written to disk -- even if sufficient information exists --- to determine that hash value. If construct as a 'Pending' value, it is --- an 'IO' action that writes the object to disk and retrieves the resulting --- hash value from Git; if 'Stored', it is a 'COid' that is known to the --- repository. -data Ident a = Pending (a -> IO COid) - | Stored COid - -instance Eq (Ident a) where - Pending f1 == Pending f2 = False - Stored oid1 == Stored oid2 = oid1 == oid2 - _ == _ = False - -instance Show (Ident a) where - show (Pending _) = "Ident..." - show (Stored coid) = show coid - --- | 'Oid' represents either a full or partial SHA1 hash code used to identify --- Git objects. -data Oid = Oid COid - | PartialOid COid Int - -instance Show Oid where - show (Oid x) = show x - show (PartialOid x l) = take l $ show x - --- | Compare two 'COid' values for equality. More typical is to use 'compare'. -compareCOid :: COid -> COid -> Ordering -(COid x) `compareCOid` (COid y) = - let c = unsafePerformIO $ - withForeignPtr x $ \x' -> - withForeignPtr y $ \y' -> - c'git_oid_cmp x' y' - in c `compare` 0 - --- | Compare two 'COid' values for equality, but only up to a certain length. -compareCOidLen :: COid -> COid -> Int -> Ordering -compareCOidLen (COid x) (COid y) l = - let c = unsafePerformIO $ - withForeignPtr x $ \x' -> - withForeignPtr y $ \y' -> - c'git_oid_ncmp x' y' (fromIntegral l) - in c `compare` 0 - -instance Ord COid where - compare = compareCOid - --- | 'True' if two 'COid' values are equal. -equalCOid :: Ord a => a -> a -> Bool -x `equalCOid` y = (x `compare` y) == EQ - -instance Eq COid where - (==) = equalCOid - -instance Eq Oid where - (Oid x) == (Oid y) = x `equalCOid` y - (PartialOid x xl) == (PartialOid y yl) = - xl == yl && compareCOidLen x y xl == EQ - _ == _ = False - --- | Convert a hash string to a 'Maybe' 'Oid' value. If the string is less --- than 40 hexadecimal digits, the result will be of type 'PartialOid'. --- --- >>> parseOid "a143ecf" --- Just a143ecf --- >>> parseOid "a143ecf" >>= (\(Just (PartialOid _ l)) -> return $ l == 7) --- True --- --- >>> let hash = "6cfc2ca31732fb6fa6b54bae6e586a57a0611aab" --- >>> parseOid hash --- Just 6cfc2ca31732fb6fa6b54bae6e586a57a0611aab --- >>> parseOid hash >>= (\(Just (Oid _)) -> return True) --- True -parseOid :: CStringable a => a -> IO (Maybe Oid) -parseOid str - | len > 40 = throwIO ObjectIdTooLong - | otherwise = do - oid <- mallocForeignPtr - withCStringable str $ \cstr -> - withForeignPtr oid $ \ptr -> do - r <- if len == 40 - then c'git_oid_fromstr ptr cstr - else c'git_oid_fromstrn ptr cstr (fromIntegral len) - if r < 0 - then return Nothing - else return . Just $ if len == 40 - then Oid (COid oid) - else PartialOid (COid oid) len - where len = S.length str - --- Oid.hs diff --git a/Data/Git/Reference.hs b/Data/Git/Reference.hs deleted file mode 100644 --- a/Data/Git/Reference.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module Data.Git.Reference - ( RefTarget(..) - , Reference(..) - , createRef - , resolveRef - , lookupRef - , listRefNames - , ListFlags - , allRefsFlag - , oidRefsFlag - , looseOidRefsFlag - , symbolicRefsFlag - , mapRefs - , mapAllRefs - , mapOidRefs - , mapLooseOidRefs - , mapSymbolicRefs - , writeRef - , writeRef_ ) - where - -import Bindings.Libgit2 -import Data.ByteString -import Data.Git.Internal -import Data.IORef -import qualified Data.Text as T -import qualified Data.Text.Encoding as E -import Foreign.Marshal.Array -import qualified Prelude -import Prelude ((+),(-)) - -createRef :: Repository -> Text -> RefTarget -> Reference -createRef repo name target = - Reference { refRepo = repo - , refName = name - , refTarget = target - , refObj = Nothing } - -lookupRef :: Repository -> Text -> IO (Maybe Reference) -lookupRef repo name = alloca $ \ptr -> do - mapM_ (\f -> f repo name) (repoBeforeReadRef repo) - r <- withForeignPtr (repositoryPtr repo) $ \repoPtr -> - withCStringable name $ \namePtr -> - c'git_reference_lookup ptr repoPtr namePtr - if r < 0 - then return Nothing - else do - ref <- peek ptr - fptr <- newForeignPtr p'git_reference_free ref - typ <- c'git_reference_type ref - targ <- if typ == c'GIT_REF_OID - then do oidPtr <- c'git_reference_oid ref - newForeignPtr_ oidPtr - >>= return . RefTargetId . Oid . COid - else do targName <- c'git_reference_target ref - packCString targName - >>= return . RefTargetSymbolic . E.decodeUtf8 - return $ Just Reference { refRepo = repo - , refName = name - , refTarget = targ - , refObj = Just fptr } - -writeRef :: Reference -> IO Reference -writeRef ref = alloca $ \ptr -> do - withForeignPtr (repoObj (refRepo ref)) $ \repoPtr -> - withCStringable (refName ref) $ \namePtr -> do - r <- case refTarget ref of - RefTargetId (PartialOid {}) -> - throwIO RefCannotCreateFromPartialOid - - RefTargetId (Oid (COid coid)) -> - withForeignPtr coid $ \coidPtr -> - c'git_reference_create_oid ptr repoPtr namePtr - coidPtr (fromBool True) - - RefTargetSymbolic symName -> - withCStringable symName $ \symPtr -> - c'git_reference_create_symbolic ptr repoPtr namePtr - symPtr (fromBool True) - when (r < 0) $ throwIO ReferenceCreateFailed - - fptr <- newForeignPtr_ =<< peek ptr - let ref' = ref { refObj = Just fptr } - mapM_ (\f -> f (refRepo ref') ref') (repoOnWriteRef (refRepo ref')) - return ref' - -writeRef_ :: Reference -> IO () -writeRef_ = void . writeRef - --- int git_reference_name_to_oid(git_oid *out, git_repository *repo, --- const char *name) - -resolveRef :: Repository -> Text -> IO (Maybe Oid) -resolveRef repos name = alloca $ \ptr -> do - mapM_ (\f -> f repos name) (repoBeforeReadRef repos) - withCStringable name $ \namePtr -> - withForeignPtr (repoObj repos) $ \repoPtr -> do - r <- c'git_reference_name_to_oid ptr repoPtr namePtr - if r < 0 - then return Nothing - else Just . Oid <$> COid <$> newForeignPtr_ ptr - --- int git_reference_rename(git_reference *ref, const char *new_name, --- int force) - ---renameRef = c'git_reference_rename - --- int git_reference_delete(git_reference *ref) - ---deleteRef = c'git_reference_delete - --- 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 T.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) - -listRefNames :: Repository -> ListFlags -> IO [Text] -listRefNames repo flags = - alloca $ \c'refs -> - withForeignPtr (repositoryPtr repo) $ \repoPtr -> do - r <- c'git_reference_list c'refs repoPtr (flagsToInt flags) - when (r < 0) $ throwIO ReferenceLookupFailed - - refs <- gitStrArray2List c'refs - c'git_strarray_free c'refs - return refs - -foreachRefCallback :: CString -> Ptr () -> IO CInt -foreachRefCallback name payload = do - (callback,results) <- peek (castPtr payload) >>= deRefStablePtr - result <- packCString name >>= callback . E.decodeUtf8 - 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) - -mapRefs :: Repository -> ListFlags -> (Text -> IO a) -> IO [a] -mapRefs repo flags callback = do - ioRef <- newIORef [] - bracket - (newStablePtr (callback,ioRef)) - deRefStablePtr - (\ptr -> with ptr $ \pptr -> - withForeignPtr (repositoryPtr repo) $ \repoPtr -> do - _ <- c'git_reference_foreach repoPtr (flagsToInt flags) - foreachRefCallbackPtr (castPtr pptr) - readIORef ioRef) - -mapAllRefs :: Repository -> (Text -> IO a) -> IO [a] -mapAllRefs repo = mapRefs repo allRefsFlag -mapOidRefs :: Repository -> (Text -> IO a) -> IO [a] -mapOidRefs repo = mapRefs repo oidRefsFlag -mapLooseOidRefs :: Repository -> (Text -> IO a) -> IO [a] -mapLooseOidRefs repo = mapRefs repo looseOidRefsFlag -mapSymbolicRefs :: Repository -> (Text -> IO a) -> IO [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 - --- Refs.hs diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs deleted file mode 100644 --- a/Data/Git/Repository.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | 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 Data.Git.Repository - ( ObjPtr - - , Updatable(..) - - , Repository(..) - , openRepository - , createRepository - , openOrCreateRepository - , repositoryPtr - - , lookupObject' - , withObject - , withObjectPtr - ) - where - -import Data.Git.Internal - --- Repository.hs diff --git a/Data/Git/Tag.hs b/Data/Git/Tag.hs deleted file mode 100644 --- a/Data/Git/Tag.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Data.Git.Tag where - -import Data.Git.Common -import Data.Git.Internal -import qualified Data.Text as T -import qualified Prelude - -data Tag = Tag { tagInfo :: Base Tag - , tagRef :: Oid } - -instance Show Tag where - show x = case gitId (tagInfo x) of - Pending _ -> "Tag..." - Stored y -> "Tag#" ++ show y - --- Tag.hs diff --git a/Data/Git/Tree.hs b/Data/Git/Tree.hs deleted file mode 100644 --- a/Data/Git/Tree.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} - -module Data.Git.Tree where - -import Bindings.Libgit2 -import Control.Concurrent.ParallelIO -import Data.Git.Blob -import Data.Git.Common -import Data.Git.Error -import Data.Git.Internal -import qualified Data.Map as M -import qualified Data.Text as T -import qualified Filesystem.Path.CurrentOS as F -import qualified Prelude - -data TreeEntry = BlobEntry { blobEntry :: ObjRef Blob - , blobEntryIsExe :: Bool } - | TreeEntry { treeEntry :: ObjRef Tree } - -blobRefWithMode :: Bool -> Blob -> TreeEntry -blobRefWithMode mode b = BlobEntry (ObjRef b) mode - -blobRef :: Blob -> TreeEntry -blobRef = blobRefWithMode False - -exeBlobRef :: Blob -> TreeEntry -exeBlobRef = blobRefWithMode True - -blobIdRef :: Oid -> Bool -> TreeEntry -blobIdRef (Oid coid) = BlobEntry (IdRef coid) -blobIdRef (PartialOid {}) = throw ObjectRefRequiresFullOid - -treeRef :: Tree -> TreeEntry -treeRef t = TreeEntry (ObjRef t) - -treeIdRef :: Oid -> TreeEntry -treeIdRef (Oid coid) = TreeEntry (IdRef coid) -treeIdRef (PartialOid {}) = throw ObjectRefRequiresFullOid - --- instance Eq TreeEntry where --- (BlobEntry x x2) == (BlobEntry y y2) = x == y && x2 == y2 --- (TreeEntry x) == (TreeEntry y) = x == y --- _ == _ = False - -type TreeMap = M.Map Text TreeEntry - -data Tree = Tree { treeInfo :: Base Tree - , treeContents :: TreeMap } - -instance Show Tree where - show x = case gitId (treeInfo x) of - Pending _ -> "Tree..." - Stored y -> "Tree#" ++ show y - -instance Show TreeEntry where - show (BlobEntry blob _) = "BlobEntry (" ++ show blob ++ ")" - show (TreeEntry tree) = "TreeEntry (" ++ show tree ++ ")" - -instance Updatable Tree where - getId x = gitId (treeInfo x) - objectRepo x = gitRepo (treeInfo x) - objectPtr x = gitObj (treeInfo x) - update = writeTree - lookupFunction = lookupTree -#if defined(PROFILING) - loadObject' x y = - maybe (throwIO ObjectLookupFailed) return =<< loadObject x y -#endif - -newTreeBase :: Tree -> Base Tree -newTreeBase t = - newBase (gitRepo (treeInfo t)) - (Pending (doWriteTree >=> return . snd)) Nothing - --- | Create a new, empty tree. --- --- Since empty trees cannot exist in Git, attempting to write out an empty --- tree is a no-op. -createTree :: Repository -> Tree -createTree repo = - Tree { treeInfo = - newBase repo (Pending (doWriteTree >=> return . snd)) Nothing - , treeContents = M.empty } - -lookupTree :: Repository -> Oid -> IO (Maybe Tree) -lookupTree repo oid = - lookupObject' repo oid c'git_tree_lookup c'git_tree_lookup_prefix $ - \coid obj _ -> do - entriesAList <- withForeignPtr obj $ \treePtr -> do - entryCount <- c'git_tree_entrycount (castPtr treePtr) - foldM - (\m idx -> do - entry <- c'git_tree_entry_byindex (castPtr treePtr) - (fromIntegral idx) - when (entry == nullPtr) $ throwIO ObjectLookupFailed - entryId <- c'git_tree_entry_id entry - coid <- mallocForeignPtr - withForeignPtr coid $ \coid' -> - c'git_oid_cpy coid' entryId - - entryName <- c'git_tree_entry_name entry - >>= peekCString >>= return . T.pack - entryAttrs <- c'git_tree_entry_attributes entry - entryType <- c'git_tree_entry_type entry - - let entryObj = if entryType == c'GIT_OBJ_BLOB - then BlobEntry (IdRef (COid coid)) False - else TreeEntry (IdRef (COid coid)) - - return ((entryName,entryObj):m)) - [] [0..(entryCount-1)] - return Tree { treeInfo = newBase repo (Stored coid) (Just obj) - , treeContents = M.fromList entriesAList } - -doLookupTreeEntry :: Tree -> [Text] -> IO (Maybe TreeEntry) -doLookupTreeEntry t [] = return (Just (TreeEntry (ObjRef t))) -doLookupTreeEntry t (name:names) = do - -- Lookup the current name in this tree. If it doesn't exist, and there are - -- more names in the path and 'createIfNotExist' is True, create a new Tree - -- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry - -- {})@, and if not we'll have Nothing. - - -- Prelude.putStrLn $ "Tree: " ++ show t - -- Prelude.putStrLn $ "Tree Entries: " ++ show (treeContents t) - -- Prelude.putStrLn $ "Lookup: " ++ toString name - y <- case M.lookup name (treeContents t) of - Nothing -> return Nothing - Just j -> case j of - BlobEntry b mode -> do - bl <- loadObject b t - for bl $ \x -> return $ BlobEntry (ObjRef x) mode - TreeEntry t' -> do - tr <- loadObject t' t - for tr $ \x -> return $ TreeEntry (ObjRef x) - - -- Prelude.putStrLn $ "Result: " ++ show y - -- Prelude.putStrLn $ "Names: " ++ show names - if null names - then return y - else - case y of - Just (BlobEntry {}) -> throw TreeCannotTraverseBlob - Just (TreeEntry (ObjRef t')) -> doLookupTreeEntry t' names - _ -> return Nothing - -lookupTreeEntry :: Tree -> FilePath -> IO (Maybe TreeEntry) -lookupTreeEntry tr = doLookupTreeEntry tr . splitPath - -withGitTree :: Updatable b - => ObjRef Tree -> b -> (Ptr C'git_tree -> IO a) -> IO a -withGitTree tref obj f = - withForeignPtr (repositoryPtr (objectRepo obj)) $ \repoPtr -> - case tref of - IdRef (COid oid) -> withGitTreeOid repoPtr oid - - ObjRef (Tree { treeInfo = Base { gitId = Stored (COid oid) } }) -> - withGitTreeOid repoPtr oid - - ObjRef (Tree { treeInfo = Base { gitObj = Just t } }) -> - withForeignPtr t (f . castPtr) - - ObjRef t -> do t' <- update t - withGitTree (ObjRef t') obj f - - where withGitTreeOid repoPtr oid = - withForeignPtr oid $ \tree_id -> - alloca $ \ptr -> do - r <- c'git_tree_lookup ptr repoPtr tree_id - when (r < 0) $ throwIO TreeLookupFailed - f =<< peek ptr - --- | Write out a tree to its repository. If it has already been written, --- nothing will happen. -writeTree :: Tree -> IO Tree -writeTree t@(Tree { treeInfo = Base { gitId = Stored _ } }) = return t -writeTree t = fst <$> doWriteTree t - -doWriteTree :: Tree -> IO (Tree, COid) -doWriteTree t = alloca $ \ptr -> - withForeignPtr (repoObj (gitRepo (treeInfo t))) $ \repoPtr -> do - r <- c'git_treebuilder_create ptr nullPtr - when (r < 0) $ throwIO TreeBuilderCreateFailed - builder <- peek ptr - - -- jww (2012-10-14): With the loose object backend, there should be no - -- race conditions here as there will never be a request to access the - -- same file by multiple threads. If that ever does happen, or if this - -- code is changed to write to the packed object backend, simply change - -- the function 'parallel' to 'sequence' here. - oids <- parallel $ - flip map (M.toList (treeContents t)) $ \(k, v) -> - case v of - BlobEntry bl exe -> - withObject bl t $ \bl' -> do - bl'' <- update bl' - (Oid coid) <- objectId bl'' - return (k, BlobEntry (ObjRef bl'') exe, coid, - if exe then 0o100755 else 0o100644) - TreeEntry tr -> - withObject tr t $ \tr' -> do - tr'' <- update tr' - (Oid coid) <- objectId tr'' - return (k, TreeEntry (ObjRef tr''), coid, 0o040000) - - newList <- for oids $ \(k, entry, coid, flags) -> do - insertObject builder k coid flags - return (k, entry) - - coid <- mallocForeignPtr - withForeignPtr coid $ \coid' -> do - r3 <- c'git_treebuilder_write coid' repoPtr builder - when (r3 < 0) $ throwIO TreeBuilderWriteFailed - - return (t { treeInfo = (treeInfo t) { gitId = Stored (COid coid) } - , treeContents = M.fromList newList }, COid coid) - - where - insertObject :: (CStringable a) - => Ptr C'git_treebuilder -> a -> COid -> CUInt -> IO () - insertObject builder key (COid coid) attrs = - withForeignPtr coid $ \coid' -> - withCStringable key $ \name -> do - r2 <- c'git_treebuilder_insert nullPtr builder name coid' attrs - when (r2 < 0) $ throwIO TreeBuilderInsertFailed - -doModifyTree - :: [Text] -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool - -> Tree -> IO (Either a Tree) -doModifyTree [] _ _ _ = throw TreeLookupFailed -doModifyTree (name:names) f createIfNotExist t = do - -- Lookup the current name in this tree. If it doesn't exist, and there are - -- more names in the path and 'createIfNotExist' is True, create a new Tree - -- and descend into it. Otherwise, if it exists we'll have @Just (TreeEntry - -- {})@, and if not we'll have Nothing. - y <- case M.lookup name (treeContents t) of - Nothing -> - return $ - if createIfNotExist && not (null names) - then Just . TreeEntry . ObjRef . createTree - $ gitRepo (treeInfo t) - else Nothing - Just j -> case j of - BlobEntry b mode -> do - bl <- loadObject b t - for bl $ \x -> return $ BlobEntry (ObjRef x) mode - TreeEntry t' -> do - tr <- loadObject t' t - for tr $ \x -> return $ TreeEntry (ObjRef x) - - if null names - then do - -- If there are no further names in the path, call the transformer - -- function, f. It receives a @Maybe TreeEntry@ to indicate if there - -- was a previous entry at this path. It should return a 'Left' value - -- to propagate out a user-defined error, or a @Maybe TreeEntry@ to - -- indicate whether the entry at this path should be deleted or - -- replaced with something new. - -- - -- NOTE: There is no provision for leaving the entry unchanged! It is - -- assumed to always be changed, as we have no reliable method of - -- testing object equality that is not O(n). - let ze = f y - case ze of - Left err -> return $ Left err - Right z -> - return $ Right $ - t { treeInfo = newTreeBase t - , treeContents = - case z of - Nothing -> M.delete name (treeContents t) - Just z' -> M.insert name z' (treeContents t) } - - else - -- If there are further names in the path, descend them now. If - -- 'createIfNotExist' was False and there is no 'Tree' under the - -- current name, or if we encountered a 'Blob' when a 'Tree' was - -- required, throw an exception to avoid colliding with user-defined - -- 'Left' values. - case y of - Just (BlobEntry {}) -> throw TreeCannotTraverseBlob - Just (TreeEntry (ObjRef t')) -> do - st <- doModifyTree names f createIfNotExist t' - case st of - err@(Left _) -> return err - Right st' -> - return $ Right $ - t { treeInfo = newTreeBase t - , treeContents = - if M.null (treeContents st') - then M.delete name (treeContents t) - else M.insert name (TreeEntry (ObjRef st')) - (treeContents t) } - _ -> throw TreeLookupFailed - -modifyTree - :: FilePath -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool - -> Tree -> IO (Either a Tree) -modifyTree = doModifyTree . splitPath - -doUpdateTree :: Tree -> [Text] -> TreeEntry -> IO Tree -doUpdateTree t xs item = do - t' <- doModifyTree xs (const (Right (Just item))) True t - case t' of - Right tr -> return tr - _ -> throwIO TreeUpdateFailed - -updateTree :: Tree -> FilePath -> TreeEntry -> IO Tree -updateTree tr = doUpdateTree tr . splitPath - -removeFromTree :: FilePath -> Tree -> IO Tree -removeFromTree p tr = do - t' <- modifyTree p (const (Right Nothing)) False tr - case t' of - Right tr' -> return tr' - _ -> throwIO TreeUpdateFailed - -splitPath :: FilePath -> [Text] -splitPath path = T.splitOn "/" text - where text = case F.toText path of - Left x -> error $ "Invalid path: " ++ T.unpack x - Right y -> y - --- Tree.hs diff --git a/Data/Git/Tutorial.hs b/Data/Git/Tutorial.hs deleted file mode 100644 --- a/Data/Git/Tutorial.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-| This module provides a brief introductory tutorial in the \"Introduction\" - section followed by a lengthy discussion of the library's design and idioms. --} - -module Data.Git.Tutorial - ( - -- * Introduction - -- $intro - - -- * Repositories - -- $repositories - - -- * References - -- $references - - -- * Commits - -- $commits - ) where - -{- $intro - - The @gitlib@ library provides high-level types for working with the - @libgit2@ C library (). The intention is to - make @libgit2@ easier and more type-safe, while using laziness to avoid - unnecessary work. --} - -{- $repositories - - Every use of @gitlib@ must begin with a 'Data.Git.Repository' object. At - the moment each 'Repository' must be associated with a local directory, - even if the Git objects are kept elsewhere via a custom backend (see - ). - - If no 'Repository' exists yet, use 'Data.Git.Repository.createRepository'; - if one does exist, use 'Data.Git.Repository.openRepository'; or, you can - use 'Data.Git.Repository.openOrCreateRepository'. For example: - -> repo <- openOrCreateRepository path False -- False here means "not bare" -> ... make use of the repository ... - - Note that the 'path' variable here is of type 'Filesystem.Path.FilePath', - since @gitlib@ almost never uses the 'String' type. --} - -{- $references - - If you are working with an existing repository, probably the first thing - you'll want to do is resolve a reference so that you can lookup a commit: - -> repo <- openOrCreateRepository path False -> ref <- resolveRef repo "HEAD" -> commit <- maybe (return Nothing) (lookupCommit repo) ref - - 'resolveRef' works for both symbolic and specific refs. Further, this - pattern is rather common, so there is a shortcut called - 'Data.Git.Commit.lookupRefCommit'. Or, if you have a SHA string, you can - use 'Data.Git.Commit.lookupCommit' with 'Data.Git.Oid.parseOid'. - -> repo <- openOrCreateRepository path False -> commitFromRef <- lookupRefCommit repo "HEAD" :: Maybe Commit -> commitFromSHA <- lookupCommit repo (parseOid "f7acdbed") :: Maybe Commit - --} - -{- $commits - - If you don't have a commit object, the recommend way to create one is by - creating a 'Data.Git.Common.Signature' and using it to modify the return - value from 'Data.Git.Commit.create'. This requires a 'Repository' object: - -> now <- getCurrentTime -> let sig = Signature { -> signatureName = "John Smith" -> , signatureEmail = "johnsmith@nowhere.org" -> , signatureWhen = now } -> c = (createCommit repo) { -> , commitAuthor = sig -> , commitCommitter = sig } -> - - Load a 'Data.Git.Commit.Commit', and thereafter its history through its - parents, or load a 'Data.Git.Tree.Tree' or 'Data.Git.Blob.Blob' from - its contents. - - 3. Construct a new commit --} diff --git a/Git.hs b/Git.hs new file mode 100644 --- /dev/null +++ b/Git.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Interface for working with Git repositories. +module Git where + +import Control.Applicative +import qualified Control.Exception.Lifted as Exc +import Control.Failure +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Data.ByteString (ByteString) +import Data.Conduit +import Data.Default +import Data.Map (Map) +import Data.Maybe +import Data.Tagged +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time +import Data.Typeable +import Filesystem.Path.CurrentOS +import Prelude hiding (FilePath) +import System.Mem (performGC) + +{- $repositories -} +data RepositoryFacts = RepositoryFacts + { hasSymbolicReferences :: !Bool + } deriving Show + +type MonadGit m = (Failure Git.GitException m, Applicative m, + MonadIO m, MonadBaseControl IO m) + +-- | 'Repository' is the central point of contact between user code and +-- Git data objects. Every object must belong to some repository. +class (Applicative m, Monad m, Failure GitException m, + Eq (Oid m), Ord (Oid m), Show (Oid m)) => Repository m where + data Oid m + data TreeData m + data Options m + + facts :: m RepositoryFacts + + parseOid :: Text -> m (Oid m) + renderOid :: Oid m -> Text + renderOid = renderObjOid . Tagged + renderObjOid :: Tagged a (Oid m) -> Text + renderObjOid = renderOid . unTagged + + -- References + createRef :: Text -> RefTarget m (Commit m) -> m (Reference m (Commit m)) + createRef_ :: Text -> RefTarget m (Commit m) -> m () + createRef_ = (void .) . createRef + lookupRef :: Text -> m (Maybe (Reference m (Commit m))) + updateRef :: Text -> RefTarget m (Commit m) -> m (Reference m (Commit m)) + updateRef_ :: Text -> RefTarget m (Commit m) -> m () + updateRef_ = (void .) . updateRef + deleteRef :: Text -> m () + + allRefs :: m [Reference m (Commit m)] + allRefs = catMaybes <$> (mapM lookupRef =<< allRefNames) + + allRefNames :: m [Text] + allRefNames = map refName <$> allRefs + + resolveRef :: Text -> m (Maybe (CommitRef m)) + resolveRef name = lookupRef name >>= referenceToRef (Just name) + + -- Lookup + lookupCommit :: CommitOid m -> m (Commit m) + lookupTree :: TreeOid m -> m (Tree m) + lookupBlob :: BlobOid m -> m (Blob m) + lookupTag :: TagOid m -> m (Tag m) + + lookupObject :: Text -> m (Object m) + existsObject :: Oid m -> m Bool + + traverseObjects :: forall a. + (Object m -> m a) -> Maybe (CommitName m) -> m [a] + traverseObjects_ :: (Object m -> m ()) -> Maybe (CommitName m) -> m () + traverseObjects_ = (void .) . traverseObjects + + pushCommit :: (MonadTrans t, MonadGit m, MonadGit (t m), + Repository m, Repository (t m)) + => CommitName m -> Maybe Text -> Text + -> t m (CommitRef (t m)) + + traverseCommits :: forall a. + (CommitRef m -> m a) -> CommitName m -> m [a] + traverseCommits_ :: (CommitRef m -> m ()) -> CommitName m -> m () + traverseCommits_ = (void .) . traverseCommits + + missingObjects :: Maybe (CommitName m) -- ^ A commit we may already have + -> CommitName m -- ^ The commit we need + -> m [Object m] -- ^ All the objects in between + + -- Object creation + newTree :: m (Tree m) + hashContents :: BlobContents m -> m (BlobOid m) + createBlob :: BlobContents m -> m (BlobOid m) + createCommit :: [CommitRef m] -> TreeRef m + -> Signature -> Signature -> Text -> Maybe Text -> m (Commit m) + createTag :: CommitOid m -> Signature -> Text -> Text -> m (Tag m) + + deleteRepository :: m () + + -- Pack files + buildPackFile :: FilePath -> [Either (CommitOid m) (TreeOid m)] + -> m FilePath + buildPackFile _ _ = + failure (BackendError "Backend does not support building pack files") + + buildPackIndex :: FilePath -> ByteString -> m (Text, FilePath, FilePath) + buildPackIndex _ _ = + failure (BackendError "Backend does not support building pack indexes") + + writePackFile :: FilePath -> m () + writePackFile _ = + failure (BackendError "Backend does not support writing pack files") + + -- Git remotes + remoteFetch :: Text {- URI -} -> Text {- fetch spec -} -> m () + +{- $exceptions -} +-- | There is a separate 'GitException' for each possible failure when +-- interacting with the Git repository. +data GitException = BackendError Text + | GitError Text + | RepositoryNotExist + | RepositoryInvalid + | RepositoryCannotAccess Text + | BlobCreateFailed + | BlobEmptyCreateFailed + | BlobEncodingUnknown Text + | BlobLookupFailed + | PushNotFastForward Text + | TranslationException Text + | TreeCreateFailed Text + | TreeBuilderCreateFailed + | TreeBuilderInsertFailed Text + | TreeBuilderRemoveFailed Text + | TreeBuilderWriteFailed Text + | TreeLookupFailed + | TreeCannotTraverseBlob + | TreeCannotTraverseCommit + | TreeEntryLookupFailed FilePath + | TreeUpdateFailed + | TreeWalkFailed + | CommitCreateFailed + | CommitLookupFailed Text + | ReferenceCreateFailed + | ReferenceDeleteFailed Text + | RefCannotCreateFromPartialOid + | ReferenceListingFailed + | ReferenceLookupFailed Text + | ObjectLookupFailed Text Int + | ObjectRefRequiresFullOid + | OidCopyFailed + | OidParseFailed Text + | QuotaHardLimitExceeded Int Int + deriving (Eq, Show, Typeable) + +-- jww (2013-02-11): Create a BackendException data constructor of forall +-- e. Exception e => BackendException e, so that each can throw a derived +-- exception. +instance Exc.Exception GitException + +{- $oids -} +type BlobOid m = Tagged (Blob m) (Oid m) +type TreeOid m = Tagged (Tree m) (Oid m) +type CommitOid m = Tagged (Commit m) (Oid m) +type TagOid m = Tagged (Tag m) (Oid m) + +{- $references -} +data RefTarget m a = RefObj !(ObjRef m a) | RefSymbolic !Text + +data Reference m a = Reference + { refName :: !Text + , refTarget :: !(RefTarget m a) } + +data CommitName m = CommitObjectId !(CommitOid m) + | CommitRefName !Text + | CommitReference !(Reference m (Commit m)) + +instance Repository m => Show (CommitName m) where + show (CommitObjectId coid) = T.unpack (renderObjOid coid) + show (CommitRefName name) = show name + show (CommitReference ref) = show (refName ref) + +nameOfCommit :: Commit m -> CommitName m +nameOfCommit = CommitObjectId . commitOid + +commitNameToRef :: Repository m => CommitName m -> m (Maybe (CommitRef m)) +commitNameToRef (CommitObjectId coid) = return (Just (ByOid coid)) +commitNameToRef (CommitRefName name) = resolveRef name +commitNameToRef (CommitReference ref) = referenceToRef Nothing (Just ref) + +renderCommitName :: Repository m => CommitName m -> Text +renderCommitName (CommitObjectId coid) = renderObjOid coid +renderCommitName (CommitRefName name) = name +renderCommitName (CommitReference ref) = refName ref + +copyOid :: (Repository m, MonadGit m, Repository n, MonadGit n) + => Oid m -> n (Oid n) +copyOid = parseOid . renderOid + +copyCommitOid :: (Repository m, MonadGit m, Repository n, MonadGit n) + => CommitOid m -> n (CommitOid n) +copyCommitOid coid = do + ncoid <- parseOid (renderObjOid coid) + return (Tagged ncoid) + +copyCommitName :: (Repository m, MonadGit m, Repository n, MonadGit n) + => CommitName m -> n (Maybe (CommitName n)) +copyCommitName (CommitObjectId coid) = + Just . CommitObjectId . Tagged <$> parseOid (renderObjOid coid) +copyCommitName (CommitRefName name) = return (Just (CommitRefName name)) +copyCommitName (CommitReference ref) = + fmap CommitReference <$> lookupRef (refName ref) + +{- $objects -} +data ObjRef m a = ByOid !(Tagged a (Oid m)) | Known !a + +type BlobRef m = ObjRef m (Blob m) +type TreeRef m = ObjRef m (Tree m) +type CommitRef m = ObjRef m (Commit m) +type TagRef m = ObjRef m (Tag m) + +data Object m = BlobObj !(BlobRef m) + | TreeObj !(TreeRef m) + | CommitObj !(CommitRef m) + | TagObj !(TagRef m) + +objectOid :: Repository m => Object m -> m (Oid m) +objectOid (BlobObj ref) = return . unTagged $ blobRefOid ref +objectOid (TreeObj ref) = unTagged <$> treeRefOid ref +objectOid (CommitObj ref) = return . unTagged $ commitRefOid ref +objectOid (TagObj ref) = return . unTagged $ tagRefOid ref + +{- $blobs -} +data Blob m = Blob { blobOid :: !(BlobOid m) + , blobContents :: !(BlobContents m) } + +blobRefOid :: Repository m => BlobRef m -> BlobOid m +blobRefOid (ByOid oid) = oid +blobRefOid (Known (Blob {..})) = blobOid + +resolveBlobRef :: Repository m => BlobRef m -> m (Blob m) +resolveBlobRef (ByOid oid) = lookupBlob oid +resolveBlobRef (Known obj) = return obj + +type ByteSource m = Producer m ByteString + +data BlobContents m = BlobString !ByteString + | BlobStream !(ByteSource m) + | BlobSizedStream !(ByteSource m) !Int + +data BlobKind = PlainBlob | ExecutableBlob | SymlinkBlob | UnknownBlob + deriving (Show, Eq, Enum) + +instance Eq (BlobContents m) where + BlobString str1 == BlobString str2 = str1 == str2 + _ == _ = False + +{- $trees -} +data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m) + , blobEntryKind :: !BlobKind } + | TreeEntry { treeEntryRef :: !(TreeRef m) } + | CommitEntry { commitEntryRef :: !(CommitOid m) } + +treeEntryOid :: Repository m => TreeEntry m -> m (Oid m) +treeEntryOid (BlobEntry boid _) = return $ unTagged boid +treeEntryOid (TreeEntry tref) = unTagged <$> treeRefOid tref +treeEntryOid (CommitEntry coid) = return $ unTagged coid + +blobEntry :: Repository m => BlobOid m -> BlobKind -> TreeEntry m +blobEntry = BlobEntry + +treeEntry :: Repository m => Tree m -> TreeEntry m +treeEntry = TreeEntry . treeRef + +commitEntry :: Repository m => Commit m -> TreeEntry m +commitEntry = CommitEntry . commitOid + +data ModifyTreeResult m = TreeEntryNotFound + | TreeEntryDeleted + | TreeEntryPersistent (TreeEntry m) + | TreeEntryMutated (TreeEntry m) + +fromModifyTreeResult :: ModifyTreeResult m -> Maybe (TreeEntry m) +fromModifyTreeResult TreeEntryNotFound = Nothing +fromModifyTreeResult TreeEntryDeleted = Nothing +fromModifyTreeResult (TreeEntryPersistent x) = Just x +fromModifyTreeResult (TreeEntryMutated x) = Just x + +toModifyTreeResult :: (TreeEntry m -> ModifyTreeResult m) + -> Maybe (TreeEntry m) + -> ModifyTreeResult m +toModifyTreeResult _ Nothing = TreeEntryNotFound +toModifyTreeResult f (Just x) = f x + +-- | A 'Tree' is anything that is "treeish". +-- +-- Minimal complete definition: 'modifyTree'. Note that for some treeish +-- things, like Tags, it should always be an error to attempt to modify the +-- tree in any way. +data Tree m = Tree + { modifyTree :: FilePath -- path within the tree + -> Bool -- create subtree's leading up to path? + -> (Maybe (TreeEntry m) -> m (ModifyTreeResult m)) + -> m (Maybe (TreeEntry m)) + + , lookupEntry :: FilePath -> m (Maybe (TreeEntry m)) + , putTreeEntry :: FilePath -> TreeEntry m -> m () + , putBlob' :: FilePath -> BlobOid m -> BlobKind -> m () + , putBlob :: FilePath -> BlobOid m -> m () + , putTree :: FilePath -> TreeRef m -> m () + , putCommit :: FilePath -> CommitOid m -> m () + , dropFromTree :: FilePath -> m () + , writeTree :: m (TreeOid m) + , traverseEntries :: forall a. (FilePath -> TreeEntry m -> m a) -> m [a] + , traverseEntries_ :: (FilePath -> TreeEntry m -> m ()) -> m () + , getTreeData :: !(TreeData m) + } + +mkTree :: Repository m + => (Tree m + -> FilePath -- path within the tree + -> Bool -- create subtree's leading up to path? + -> (Maybe (TreeEntry m) -> m (ModifyTreeResult m)) + -> m (Maybe (TreeEntry m))) + -> (Tree m -> m (TreeOid m)) + -> (forall a. Tree m -> (FilePath -> TreeEntry m -> m a) -> m [a]) + -> TreeData m + -> Tree m +mkTree modifyTree' writeTree' traverseEntries' treeData = tr + where + tr = Tree + { modifyTree = modifyTree' tr + , lookupEntry = + \path -> modifyTree' tr path False + (return . toModifyTreeResult TreeEntryPersistent) + , putTreeEntry = \path ent -> + void $ modifyTree' tr path True + (const (return (TreeEntryMutated ent))) + , putBlob' = \path b kind -> + putTreeEntry tr path (BlobEntry b kind) + , putBlob = \path b -> putBlob' tr path b PlainBlob + , putTree = \path tr' -> putTreeEntry tr path (TreeEntry tr') + , putCommit = \path c -> putTreeEntry tr path (CommitEntry c) + , dropFromTree = \path -> + void $ modifyTree' tr path False + (const (return TreeEntryDeleted)) + , writeTree = writeTree' tr + , traverseEntries = traverseEntries' tr + , traverseEntries_ = void . traverseEntries' tr + , getTreeData = treeData + } + +treeRef :: Tree m -> TreeRef m +treeRef = Known + +treeRefOid :: Repository m => TreeRef m -> m (TreeOid m) +treeRefOid (ByOid x) = return x +treeRefOid (Known x) = writeTree x + +resolveTreeRef :: Repository m => TreeRef m -> m (Tree m) +resolveTreeRef (ByOid oid) = lookupTree oid +resolveTreeRef (Known obj) = return obj + +{- $commits -} +data Signature = Signature + { signatureName :: !Text + , signatureEmail :: !Text + , signatureWhen :: !ZonedTime + } deriving Show + +instance Default Signature where + def = Signature + { signatureName = T.empty + , signatureEmail = T.empty + , signatureWhen = ZonedTime + { zonedTimeToLocalTime = LocalTime + { localDay = ModifiedJulianDay 0 + , localTimeOfDay = TimeOfDay 0 0 0 + } + , zonedTimeZone = utc + } + } + +data Commit m = Commit + { commitOid :: !(CommitOid m) + , commitParents :: ![CommitRef m] + , commitTree :: !(TreeRef m) + , commitAuthor :: !Signature + , commitCommitter :: !Signature + , commitLog :: !Text + , commitEncoding :: !Text + } + +commitRef :: Commit m -> CommitRef m +commitRef = Known + +commitRefTarget :: Commit c -> RefTarget m (Commit c) +commitRefTarget = RefObj . Known + +commitRefOid :: Repository m => CommitRef m -> CommitOid m +commitRefOid (ByOid x) = x +commitRefOid (Known x) = commitOid x + +resolveCommitRef :: Repository m => CommitRef m -> m (Commit m) +resolveCommitRef (ByOid oid) = lookupCommit oid +resolveCommitRef (Known obj) = return obj + +referenceToRef :: Repository m + => Maybe Text -> Maybe (Reference m (Commit m)) + -> m (Maybe (CommitRef m)) +referenceToRef mname mref = + case mref of + Nothing -> return Nothing + Just (Reference { refTarget = RefObj x }) -> + return (Just x) + Just ref@(Reference { refTarget = RefSymbolic name' }) -> + if fromMaybe name' mname /= name' + then resolveRef name' + else failure (ReferenceLookupFailed (refName ref)) + +{- $tags -} + +data Tag m = Tag + { tagOid :: !(TagOid m) + , tagCommit :: !(CommitRef m) + } + +tagRefOid :: Repository m => TagRef m -> TagOid m +tagRefOid (ByOid x) = x +tagRefOid (Known x) = tagOid x + +{- $merges -} + +data ModificationKind = Unchanged | Modified | Added | Deleted | TypeChanged + deriving (Eq, Ord, Enum, Show, Read) + +data MergeStatus + = NoConflict + | BothModified + | LeftModifiedRightDeleted + | LeftDeletedRightModified + | BothAdded + | LeftModifiedRightTypeChanged + | LeftTypeChangedRightModified + | LeftDeletedRightTypeChanged + | LeftTypeChangedRightDeleted + | BothTypeChanged + deriving (Eq, Ord, Enum, Show, Read) + +mergeStatus :: ModificationKind -> ModificationKind -> MergeStatus +mergeStatus Unchanged Unchanged = NoConflict +mergeStatus Unchanged Modified = NoConflict +mergeStatus Unchanged Added = undefined +mergeStatus Unchanged Deleted = NoConflict +mergeStatus Unchanged TypeChanged = NoConflict + +mergeStatus Modified Unchanged = NoConflict +mergeStatus Modified Modified = BothModified +mergeStatus Modified Added = undefined +mergeStatus Modified Deleted = LeftModifiedRightDeleted +mergeStatus Modified TypeChanged = LeftModifiedRightTypeChanged + +mergeStatus Added Unchanged = undefined +mergeStatus Added Modified = undefined +mergeStatus Added Added = BothAdded +mergeStatus Added Deleted = undefined +mergeStatus Added TypeChanged = undefined + +mergeStatus Deleted Unchanged = NoConflict +mergeStatus Deleted Modified = LeftDeletedRightModified +mergeStatus Deleted Added = undefined +mergeStatus Deleted Deleted = NoConflict +mergeStatus Deleted TypeChanged = LeftDeletedRightTypeChanged + +mergeStatus TypeChanged Unchanged = NoConflict +mergeStatus TypeChanged Modified = LeftTypeChangedRightModified +mergeStatus TypeChanged Added = undefined +mergeStatus TypeChanged Deleted = LeftTypeChangedRightDeleted +mergeStatus TypeChanged TypeChanged = BothTypeChanged + +data MergeResult m + = MergeSuccess + { mergeCommit :: CommitOid m + } + | MergeConflicted + { mergeCommit :: CommitOid m + , mergeHeadLeft :: CommitOid m + , mergeHeadRight :: CommitOid m + , mergeConflicts :: Map FilePath (ModificationKind, ModificationKind) + } + +instance Repository m => Show (MergeResult m) where + show (MergeSuccess mc) = "MergeSuccess (" ++ show mc ++ ")" + show (MergeConflicted mc hl hr cs) = + "MergeResult" + ++ "\n { mergeCommit = " ++ show mc + ++ "\n , mergeHeadLeft = " ++ show hl + ++ "\n , mergeHeadRight = " ++ show hr + ++ "\n , mergeConflicts = " ++ show cs + ++ "\n }" + +copyConflict :: (Repository m, MonadGit m, Repository n, MonadGit n) + => MergeResult m -> n (MergeResult n) +copyConflict (MergeSuccess mc) = + MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc)) +copyConflict (MergeConflicted hl hr mc cs) = + MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl)) + <*> (Tagged <$> parseOid (renderObjOid hr)) + <*> (Tagged <$> parseOid (renderObjOid mc)) + <*> pure cs + +{- $miscellaneous -} + +data RepositoryOptions = RepositoryOptions + { repoPath :: !FilePath + , repoIsBare :: !Bool + , repoAutoCreate :: !Bool + } + +instance Default RepositoryOptions where + def = RepositoryOptions "" True True + +data RepositoryFactory t m c = RepositoryFactory + { openRepository :: RepositoryOptions -> m c + , runRepository :: forall a. c -> t m a -> m a + , closeRepository :: c -> m () + , getRepository :: t m c + , defaultOptions :: !RepositoryOptions + , startupBackend :: m () + , shutdownBackend :: m () + } + +withBackendDo :: (MonadIO m, MonadBaseControl IO m) + => RepositoryFactory t m a -> m b -> m b +withBackendDo fact f = do + startupBackend fact + Exc.finally f (liftIO performGC >> shutdownBackend fact) + +withRepository' :: (Repository (t m), MonadTrans t, + MonadBaseControl IO m, MonadIO m) + => RepositoryFactory t m c + -> RepositoryOptions + -> t m a + -> m a +withRepository' factory opts action = + Exc.bracket + (openRepository factory opts) + (closeRepository factory) + (flip (runRepository factory) action) + +withRepository :: (Repository (t m), MonadTrans t, + MonadBaseControl IO m, MonadIO m) + => RepositoryFactory t m c + -> FilePath + -> t m a + -> m a +withRepository factory path = + withRepository' factory + (defaultOptions factory) { repoPath = path } + +-- Git.hs diff --git a/Git/Tutorial.hs b/Git/Tutorial.hs new file mode 100644 --- /dev/null +++ b/Git/Tutorial.hs @@ -0,0 +1,87 @@ +{-| This module provides a brief introductory tutorial in the \"Introduction\" + section followed by a lengthy discussion of the library's design and idioms. +-} + +module Git.Tutorial + ( + -- * Introduction + -- $intro + + -- * Repositories + -- $repositories + + -- * References + -- $references + + -- * Commits + -- $commits + ) where + +{- $intro + + The @gitlib@ library provides high-level types for working with the + @libgit2@ C library (). The intention is to + make @libgit2@ easier and more type-safe, while using laziness to avoid + unnecessary work. +-} + +{- $repositories + + Every use of @gitlib@ must begin with a 'Git.Libgit2.Repository' object. At + the moment each 'Repository' must be associated with a local directory, + even if the Git objects are kept elsewhere via a custom backend (see + ). + + If no 'Repository' exists yet, use 'Git.Libgit2.Repository.createRepository'; + if one does exist, use 'Git.Libgit2.Repository.openRepository'; or, you can + use 'Git.Libgit2.Repository.openOrCreateRepository'. For example: + +> repo <- openOrCreateRepository path False -- False here means "not bare" +> ... make use of the repository ... + + Note that the 'path' variable here is of type 'Filesystem.Path.FilePath', + since @gitlib@ almost never uses the 'String' type. +-} + +{- $references + + If you are working with an existing repository, probably the first thing + you'll want to do is resolve a reference so that you can lookup a commit: + +> repo <- openOrCreateRepository path False +> ref <- resolveRef repo "HEAD" +> commit <- maybe (return Nothing) (lookupCommit repo) ref + + 'resolveRef' works for both symbolic and specific refs. Further, this + pattern is rather common, so there is a shortcut called + 'Git.Libgit2.Commit.lookupRefCommit'. Or, if you have a SHA string, you can + use 'Git.Libgit2.Commit.lookupCommit' with 'Git.Libgit2.Oid.parseOid'. + +> repo <- openOrCreateRepository path False +> commitFromRef <- lookupRefCommit repo "HEAD" :: Maybe Commit +> commitFromSHA <- lookupCommit repo (parseOid "f7acdbed") :: Maybe Commit + +-} + +{- $commits + + If you don't have a commit object, the recommend way to create one is by + creating a 'Git.Libgit2.Common.Signature' and using it to modify the return + value from 'Git.Libgit2.Commit.create'. This requires a 'Repository' object: + +> now <- getCurrentTime +> let sig = Signature { +> signatureName = "John Smith" +> , signatureEmail = "johnsmith@nowhere.org" +> , signatureWhen = now } +> c = (createCommit repo) { +> , commitAuthor = sig +> , commitCommitter = sig } +> + + Load a 'Git.Libgit2.Commit.Commit', and thereafter its history through its + parents, or load a 'Git.Libgit2.Tree.Tree' or 'Git.Libgit2.Blob.Blob' from + its contents. + + 3. Construct a new commit +-} diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -1,6 +1,6 @@ Name: gitlib -Version: 0.7.0 -Synopsis: Higher-level types for working with hlibgit2 +Version: 1.0.1 +Synopsis: API library for working with Git repositories License-file: LICENSE License: MIT Author: John Wiegley @@ -9,80 +9,48 @@ Cabal-Version: >=1.10 Category: FFI Description: - @gitlib@ is a high-level, lazy and conduit-aware type wrapper around the - libgit2 C library (). The aim is both - type-safety and convenience of use for Haskell users, combined with high - performance and minimal memory footprint by taking advantage of Haskell's - laziness and the conduit library's deterministic resource cleanup. + @gitlib@ is a high-level, lazy and conduit-aware set of abstractions for + programming with Git types. Several different backends are available, + including one for the libgit2 C library () (see + @gitlib-libgit2@). The aim is both type-safety and convenience of use for + Haskell users, combined with high performance and minimal memory footprint + by taking advantage of Haskell's laziness and the conduit library's + deterministic resource cleanup. . - For further information, as well as typical use cases, see - "Data.Git.Tutorial". + For further information, as well as typical use cases, see "Git.Tutorial". Source-repository head type: git location: git://github.com/fpco/gitlib.git -Test-suite smoke - Default-language: Haskell98 - Type: exitcode-stdio-1.0 - Main-is: Smoke.hs - Hs-source-dirs: test - Build-depends: base >=3 - , gitlib - , hlibgit2 >= 0.17 - , HUnit >= 1.2.5 - , bytestring >= 0.9.2.1 - , containers >= 0.4.2 - , lens >= 2.8 - , parallel-io >= 0.3.2.1 - , stringable >= 0.1.1 - , system-fileio >= 0.3.9 - , system-filepath >= 0.4.7 - , text >= 0.11.2 - , time >= 1.4 - Test-suite doctests - Default-language: Haskell98 - Type: exitcode-stdio-1.0 - Main-is: Doctest.hs - Hs-source-dirs: test - Build-depends: base == 4.* - , directory >= 1.0 && < 1.3 - , doctest >= 0.8 && <= 0.10 - , filepath >= 1.3 && < 1.4 + Default-language: Haskell98 + Type: exitcode-stdio-1.0 + Main-is: Doctest.hs + Hs-source-dirs: test + Build-depends: + base + , directory >= 1.0 + , doctest >= 0.8 + , doctest-prop >= 0.1 + , filepath >= 1.3 Library - default-language: Haskell98 - default-extensions: ForeignFunctionInterface - build-depends: - base >= 3 && < 5 - , hlibgit2 >= 0.17 - , bytestring >= 0.9.2.1 - , conduit >= 0.5.5 - , containers >= 0.4.2 - , lens >= 2.8 - , parallel-io >= 0.3.2.1 - , stringable >= 0.1.1 - , system-fileio >= 0.3.9 - , system-filepath >= 0.4.7 - , text >= 0.11.2 - , text-icu >= 0.6.3 - , time >= 1.4 - exposed-modules: - Data.Git - Data.Git.Backend - Data.Git.Backend.Trace - Data.Git.Blob - Data.Git.Commit - Data.Git.Common - Data.Git.Error - Data.Git.Internal - Data.Git.Object - Data.Git.Oid - Data.Git.Reference - Data.Git.Repository - Data.Git.Tag - Data.Git.Tree - Data.Git.Tutorial - -- other-modules: - -- Data.Git.Internal + default-language: Haskell98 + ghc-options: -Wall + build-depends: + base >= 3 && < 5 + , bytestring >= 0.9.2.1 + , conduit >= 1.0.0 + , containers >= 0.4.2.1 + , data-default >= 0.5.0 + , failure >= 0.2.0.1 + , lifted-base >= 0.2 + , system-filepath >= 0.4.7 + , tagged >= 0.2.3.1 + , transformers >= 0.3.0.0 + , text >= 0.11.2 + , time >= 1.4 + exposed-modules: + Git + Git.Tutorial diff --git a/test/Doctest.hs b/test/Doctest.hs --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -16,11 +16,12 @@ : sources getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "Data/Git" +getSources = + filter (\n -> ".hs" `isSuffixOf` n && n /= "./Setup.hs") <$> go "." where go dir = do (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs + (files ++) . concat <$> mapM go (filter (not . (== "./test")) dirs) getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) getFilesAndDirectories dir = do diff --git a/test/Smoke.hs b/test/Smoke.hs deleted file mode 100644 --- a/test/Smoke.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -{-# OPTIONS_GHC -fno-warn-wrong-do-bind #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Main where - -import Bindings.Libgit2.OdbBackend -import Control.Applicative -import Control.Concurrent.ParallelIO -import Control.Monad -import Data.Git -import Data.Git.Backend -import Data.Git.Backend.Trace -import Data.Maybe -import Data.Text as T hiding (map) -import qualified Data.Text.Encoding as E -import Data.Time.Clock.POSIX -import Data.Traversable -import Filesystem (removeTree, isDirectory) -import Filesystem.Path.CurrentOS -import Foreign.C.String -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable -import qualified Prelude -import Prelude (putStrLn) -import Prelude hiding (FilePath, putStr, putStrLn) -import System.Exit -import Test.HUnit - -default (Text) - -main :: IO () -main = do - counts' <- runTestTT tests - case counts' of - Counts _ _ errors' failures' -> - if errors' > 0 || failures' > 0 - then exitFailure - else exitSuccess - stopGlobalPool - -catBlob :: Repository -> Text -> IO (Maybe Text) -catBlob repo sha = do - hash <- parseOid sha - for hash $ \hash' -> do - obj <- lookupObject repo hash' - case obj of - Just (BlobObj b) -> do - (_, contents) <- getBlobContents b - str <- blobSourceToString contents - case str of - Nothing -> return T.empty - Just str' -> return (E.decodeUtf8 str') - - Just _ -> error "Found something else..." - Nothing -> error "Didn't find anything :(" - -withRepository :: Text -> (Repository -> Assertion) -> Assertion -withRepository n f = do - let p = fromText n - exists <- isDirectory p - when exists $ removeTree p - - -- we want exceptions to leave the repo behind - f =<< createRepository p True - - removeTree p - -oid :: Updatable a => a -> IO Text -oid = objectId >=> return . oidToText . Just - -oidToText :: Maybe Oid -> Text -oidToText = T.pack . show . fromJust - -sampleCommit :: Repository -> Tree -> Signature -> Commit -sampleCommit repo tr sig = - (createCommit repo sig) { commitTree = ObjRef tr - , commitLog = "Sample log message." } - -tests :: Test -tests = test [ - - "singleBlob" ~: - - withRepository "singleBlob.git" $ \repo -> do - update_ $ createBlob repo (E.encodeUtf8 "Hello, world!\n") - - x <- catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b" - x @?= Just "Hello, world!\n" - - x <- catBlob repo "af5626b" - x @?= Just "Hello, world!\n" - - return () - - , "singleTree" ~: - - withRepository "singleTree.git" $ \repo -> do - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - x <- oid tr - x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" - - return() - - , "twoTrees" ~: - - withRepository "twoTrees.git" $ \repo -> do - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - x <- oid tr - x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" - - let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye) - x <- oid tr - x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" - - return() - - , "deleteTree" ~: - - withRepository "deleteTree.git" $ \repo -> do - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - x <- oid tr - x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" - - let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye) - x <- oid tr - x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" - - -- Confirm that deleting world.txt also deletes the now-empty subtree - -- goodbye/files, which also deletes the then-empty subtree goodbye, - -- returning us back the original tree. - tr <- removeFromTree "goodbye/files/world.txt" tr - x <- oid tr - x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" - - return() - - , "createCommit" ~: - - withRepository "createCommit.git" $ \repo -> do - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - - let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye) - x <- oid tr - x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" - - -- The Oid has been cleared in tr, so this tests that it gets written as - -- needed. - let sig = Signature { - signatureName = "John Wiegley" - , signatureEmail = "johnw@newartisans.com" - , signatureWhen = posixSecondsToUTCTime 1348980883 } - - x <- oid $ sampleCommit repo tr sig - x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" - - return() - - , "createTwoCommits" ~: - - withRepository "createTwoCommits.git" $ \repo -> alloca $ \loosePtr -> do - withCString "createTwoCommits.git/objects" $ \objectsDir -> do - r <- c'git_odb_backend_loose loosePtr objectsDir (-1) 0 - when (r < 0) $ error "Failed to create loose objects backend" - loosePtr' <- peek loosePtr - backend <- traceBackend loosePtr' - odbBackendAdd repo backend 3 - - let hello = createBlob repo (E.encodeUtf8 "Hello, world!\n") - tr <- updateTree (createTree repo) "hello/world.txt" (blobRef hello) - - let goodbye = createBlob repo (E.encodeUtf8 "Goodbye, world!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye) - tr <- update tr - x <- oid tr - x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" - - -- The Oid has been cleared in tr, so this tests that it gets written as - -- needed. - let sig = Signature { - signatureName = "John Wiegley" - , signatureEmail = "johnw@newartisans.com" - , signatureWhen = posixSecondsToUTCTime 1348980883 } - c = sampleCommit repo tr sig - c <- update c - x <- oid c - x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" - - let goodbye2 = createBlob repo (E.encodeUtf8 "Goodbye, world again!\n") - tr <- updateTree tr "goodbye/files/world.txt" (blobRef goodbye2) - tr <- update tr - x <- oid tr - x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706" - - let sig = Signature { - signatureName = "John Wiegley" - , signatureEmail = "johnw@newartisans.com" - , signatureWhen = posixSecondsToUTCTime 1348981883 } - c2 = (sampleCommit repo tr sig) { - commitLog = "Second sample log message." - , commitParents = [ObjRef c] } - x <- oid c2 - x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" - - c2 <- update c2 - cid <- objectId c2 - writeRef $ createRef repo "refs/heads/master" (RefTargetId cid) - writeRef $ createRef repo "HEAD" (RefTargetSymbolic "refs/heads/master") - - x <- oidToText <$> resolveRef repo "refs/heads/master" - x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" - - mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name) - - ehist <- commitHistoryFirstParent c2 - Prelude.putStrLn $ "ehist: " ++ show ehist - - ehist2 <- commitEntryHistory c2 "goodbye/files/world.txt" - Prelude.putStrLn $ "ehist2: " ++ show ehist2 - - -- oid <- parseOid ("2506e7fc" :: Text) - -- c3 <- lookupCommit (fromJust oid) repo - -- ehist3 <- commitEntryHistory "goodbye/files/world.txt" (fromJust c3) - -- Prelude.putStrLn $ "ehist3: " ++ show ehist3 - - oid <- parseOid ("2506e7fc" :: Text) - c4 <- lookupCommit repo (fromJust oid) - c5 <- maybe (return Nothing) (lookupCommit repo) oid - c6 <- lookupCommit repo (fromJust oid) - ehist4 <- commitEntryHistory (fromJust c4) "goodbye/files/world.txt" - Prelude.putStrLn $ "ehist4: " ++ show (Prelude.head ehist4) - - , "smallTest1" ~: - - withRepository "smallTest1.git" $ \repo -> do - let blob = - createBlob repo "# Auto-created repository for tutorial contents\n" - masterRef = "refs/heads/master" - sig = Signature { signatureName = "First Name" - , signatureEmail = "user1@email.org" - , signatureWhen = posixSecondsToUTCTime 1348981883 } - tree <- updateTree (createTree repo) "README.md" (blobRef blob) - commit <- writeCommit (createCommit repo sig) - { commitLog = "Initial commit" - , commitTree = ObjRef tree - } (Just masterRef) - c1id <- objectId commit - print $ "commit1 sha = " ++ show c1id - - let sig2 = Signature { signatureName = "Second Name" - , signatureEmail = "user2@email.org" - , signatureWhen = posixSecondsToUTCTime 1348982883 } - blob <- writeBlob $ createBlob repo "This is some content." - blobOID <- objectId blob - commit' <- updateCommit commit { - commitAuthor = sig - , commitCommitter = sig - , commitLog = "This is another log message." - , commitParents = [ObjRef commit] - } "foo.txt" (blobRef blob) - commitOID <- objectId commit' - print $ "commit2 sha = " ++ show commitOID - writeRef_ $ createRef repo masterRef $ RefTargetId commitOID - - True @?= True - - return () - - ] - --- Main.hs ends here