module Git.Types where
import Control.Applicative
import qualified Control.Exception.Lifted as Exc
import Control.Failure
import Control.Monad.IO.Class
import qualified Data.Binary as Bin
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import Data.Conduit
import Data.Default
import Data.HashMap.Strict (HashMap)
import Data.Hashable
import Data.Map (Map)
import Data.Monoid
import Data.Tagged
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import Data.Typeable
type RawFilePath = ByteString
data RepositoryFacts = RepositoryFacts
{ hasSymbolicReferences :: !Bool
} deriving Show
type MonadGit m = (Failure GitException m, Applicative m,
MonadIO m, MonadBaseControl IO m)
type RefName = Text
type CommitAuthor = Text
type CommitEmail = Text
type CommitMessage = Text
type TreeFilePath = RawFilePath
class (Applicative m, Monad m, Failure GitException m, IsOid (Oid m))
=> Repository m where
type Oid m :: *
data Tree m :: *
data Options m :: *
facts :: m RepositoryFacts
parseOid :: Text -> m (Oid m)
deleteRepository :: m ()
createReference :: RefName -> RefTarget m -> m ()
lookupReference :: RefName -> m (Maybe (RefTarget m))
updateReference :: RefName -> RefTarget m -> m ()
deleteReference :: RefName -> m ()
listReferences :: m [RefName]
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 :: Oid m -> m (Object m)
existsObject :: Oid m -> m Bool
sourceObjects :: Maybe (CommitOid m)
-> CommitOid m
-> Bool
-> Producer m (ObjectOid m)
newTreeBuilder :: Maybe (Tree m) -> m (TreeBuilder m)
treeOid :: Tree m -> TreeOid m
treeEntry :: Tree m -> TreeFilePath -> m (Maybe (TreeEntry m))
listTreeEntries :: Tree m -> m [(TreeFilePath, TreeEntry m)]
diffContentsWithTree :: Source m (Either TreeFilePath ByteString)
-> Tree m -> Producer m ByteString
hashContents :: BlobContents m -> m (BlobOid m)
createBlob :: BlobContents m -> m (BlobOid m)
createCommit :: [CommitOid m] -> TreeOid m
-> Signature -> Signature -> CommitMessage -> Maybe RefName
-> m (Commit m)
createTag :: CommitOid m -> Signature -> CommitMessage -> Text -> m (Tag m)
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 a -> m a
, closeRepository :: c -> m ()
, getRepository :: t c
, defaultOptions :: !RepositoryOptions
, startupBackend :: m ()
, shutdownBackend :: m ()
}
class (Eq o, Ord o, Show o) => IsOid o where
renderOid :: o -> Text
renderOid = renderObjOid . Tagged
renderObjOid :: Tagged a o -> Text
renderObjOid = renderOid . untag
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)
data ObjectOid m = BlobObjOid !(BlobOid m)
| TreeObjOid !(TreeOid m)
| CommitObjOid !(CommitOid m)
| TagObjOid !(TagOid m)
parseObjOid :: Repository m => forall o. Text -> m (Tagged o (Oid m))
parseObjOid sha = Tagged <$> parseOid sha
copyOid :: (Repository m, Repository n) => Oid m -> n (Oid n)
copyOid = parseOid . renderOid
newtype SHA = SHA { getSHA :: ByteString } deriving (Eq, Ord, Read)
shaToText :: SHA -> Text
shaToText (SHA bs) = T.decodeUtf8 (B16.encode bs)
textToSha :: Monad m => Text -> m SHA
textToSha t =
case B16.decode $ T.encodeUtf8 t of
(bs, "") -> return (SHA bs)
_ -> fail "Invalid base16 encoding"
instance IsOid SHA where
renderOid = shaToText
instance Show SHA where
show = T.unpack . shaToText
instance Bin.Binary SHA where
put (SHA t) = Bin.put t
get = SHA <$> Bin.get
instance Hashable SHA where
hashWithSalt salt (SHA bs) = hashWithSalt salt bs
data Blob m = Blob { blobOid :: !(BlobOid m)
, blobContents :: !(BlobContents m) }
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
data TreeEntry m = BlobEntry { blobEntryOid :: !(BlobOid m)
, blobEntryKind :: !BlobKind }
| TreeEntry { treeEntryOid :: !(TreeOid m) }
| CommitEntry { commitEntryOid :: !(CommitOid m) }
instance Repository m => Show (TreeEntry m) where
show (BlobEntry oid _) = "<BlobEntry " ++ T.unpack (renderObjOid oid)
show (TreeEntry oid) = "<TreeEntry " ++ T.unpack (renderObjOid oid)
show (CommitEntry oid) = "<CommitEntry " ++ T.unpack (renderObjOid oid)
treeEntryToOid :: Repository m => TreeEntry m -> Oid m
treeEntryToOid (BlobEntry boid _) = untag boid
treeEntryToOid (TreeEntry toid) = untag toid
treeEntryToOid (CommitEntry coid) = untag coid
data TreeBuilder m = TreeBuilder
{ mtbBaseTreeOid :: Maybe (TreeOid m)
, mtbPendingUpdates :: HashMap TreeFilePath (TreeBuilder m)
, mtbNewBuilder :: Maybe (Tree m) -> m (TreeBuilder m)
, mtbWriteContents :: TreeBuilder m -> m (ModifiedBuilder m, TreeOid m)
, mtbLookupEntry :: TreeFilePath -> m (Maybe (TreeEntry m))
, mtbEntryCount :: m Int
, mtbPutEntry :: TreeBuilder m -> TreeFilePath -> TreeEntry m
-> m (ModifiedBuilder m)
, mtbDropEntry :: TreeBuilder m -> TreeFilePath
-> m (ModifiedBuilder m)
}
data ModifiedBuilder m = ModifiedBuilder (TreeBuilder m)
| BuilderUnchanged (TreeBuilder m)
instance Monoid (ModifiedBuilder m) where
mempty = BuilderUnchanged (error "ModifiedBuilder is a semigroup")
BuilderUnchanged _ `mappend` BuilderUnchanged b2 = BuilderUnchanged b2
ModifiedBuilder b1 `mappend` BuilderUnchanged _ = ModifiedBuilder b1
BuilderUnchanged _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2
ModifiedBuilder _ `mappend` ModifiedBuilder b2 = ModifiedBuilder b2
fromBuilderMod :: ModifiedBuilder m -> TreeBuilder m
fromBuilderMod (BuilderUnchanged tb) = tb
fromBuilderMod (ModifiedBuilder tb) = tb
data Commit m = Commit
{ commitOid :: !(CommitOid m)
, commitParents :: ![CommitOid m]
, commitTree :: !(TreeOid m)
, commitAuthor :: !Signature
, commitCommitter :: !Signature
, commitLog :: !CommitMessage
, commitEncoding :: !Text
}
lookupCommitParents :: Repository m => Commit m -> m [Commit m]
lookupCommitParents = mapM lookupCommit . commitParents
data Signature = Signature
{ signatureName :: !CommitAuthor
, signatureEmail :: !CommitEmail
, 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 Tag m = Tag
{ tagOid :: !(TagOid m)
, tagCommit :: !(CommitOid m)
}
data Object m = BlobObj !(Blob m)
| TreeObj !(Tree m)
| CommitObj !(Commit m)
| TagObj !(Tag m)
objectOid :: Repository m => Object m -> Oid m
objectOid (BlobObj obj) = untag (blobOid obj)
objectOid (TreeObj obj) = untag (treeOid obj)
objectOid (CommitObj obj) = untag (commitOid obj)
objectOid (TagObj obj) = untag (tagOid obj)
loadObject :: Repository m => ObjectOid m -> m (Object m)
loadObject (BlobObjOid oid) = BlobObj <$> lookupBlob oid
loadObject (TreeObjOid oid) = TreeObj <$> lookupTree oid
loadObject (CommitObjOid oid) = CommitObj <$> lookupCommit oid
loadObject (TagObjOid oid) = TagObj <$> lookupTag oid
objectToObjOid :: Repository m => Object m -> ObjectOid m
objectToObjOid (BlobObj obj) = BlobObjOid (blobOid obj)
objectToObjOid (TreeObj obj) = TreeObjOid (treeOid obj)
objectToObjOid (CommitObj obj) = CommitObjOid (commitOid obj)
objectToObjOid (TagObj obj) = TagObjOid (tagOid obj)
untagObjOid :: Repository m => ObjectOid m -> Oid m
untagObjOid (BlobObjOid oid) = untag oid
untagObjOid (TreeObjOid oid) = untag oid
untagObjOid (CommitObjOid oid) = untag oid
untagObjOid (TagObjOid oid) = untag oid
data RefTarget m = RefObj !(Oid m) | RefSymbolic !RefName
instance Repository m => Show (RefTarget m) where
show (RefObj oid) = "RefObj#" ++ T.unpack (renderOid oid)
show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name
commitRefTarget :: Commit m -> RefTarget m
commitRefTarget = RefObj . untag . commitOid
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 TreeFilePath (ModificationKind, ModificationKind)
}
copyMergeResult :: (Repository m, MonadGit m, Repository n, MonadGit n)
=> MergeResult m -> n (MergeResult n)
copyMergeResult (MergeSuccess mc) =
MergeSuccess <$> (Tagged <$> parseOid (renderObjOid mc))
copyMergeResult (MergeConflicted hl hr mc cs) =
MergeConflicted <$> (Tagged <$> parseOid (renderObjOid hl))
<*> (Tagged <$> parseOid (renderObjOid hr))
<*> (Tagged <$> parseOid (renderObjOid mc))
<*> pure cs
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 }"
data GitException
= BackendError Text
| GitError Text
| RepositoryNotExist
| RepositoryInvalid
| RepositoryCannotAccess Text
| BlobCreateFailed Text
| BlobEmptyCreateFailed
| BlobEncodingUnknown Text
| BlobLookupFailed
| DiffBlobFailed Text
| DiffPrintToPatchFailed Text
| DiffTreeToIndexFailed Text
| IndexAddFailed TreeFilePath Text
| IndexCreateFailed Text
| PushNotFastForward Text
| TranslationException Text
| TreeCreateFailed Text
| TreeBuilderCreateFailed
| TreeBuilderInsertFailed TreeFilePath
| TreeBuilderRemoveFailed TreeFilePath
| TreeBuilderWriteFailed Text
| TreeLookupFailed
| TreeCannotTraverseBlob
| TreeCannotTraverseCommit
| TreeEntryLookupFailed TreeFilePath
| TreeUpdateFailed
| TreeWalkFailed
| TreeEmptyCreateFailed
| CommitCreateFailed
| CommitLookupFailed Text
| ReferenceCreateFailed RefName
| ReferenceDeleteFailed RefName
| RefCannotCreateFromPartialOid
| ReferenceListingFailed
| ReferenceLookupFailed RefName
| ObjectLookupFailed Text Int
| ObjectRefRequiresFullOid
| OidCopyFailed
| OidParseFailed Text
| QuotaHardLimitExceeded Int Int
deriving (Eq, Show, Typeable)
instance Exc.Exception GitException