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 as B
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
import System.Posix.ByteString.FilePath
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
-> Source 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)]
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 m a -> m a
, closeRepository :: c -> m ()
, getRepository :: t m 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 B.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 !(CommitOid m) | RefSymbolic !RefName
instance Repository m => Show (RefTarget m) where
show (RefObj coid) = "RefObj#" ++ T.unpack (renderObjOid coid)
show (RefSymbolic name) = "RefSymbolic#" ++ T.unpack name
commitRefTarget :: Commit m -> RefTarget m
commitRefTarget = RefObj . 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
| BlobEmptyCreateFailed
| BlobEncodingUnknown Text
| BlobLookupFailed
| 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