git-object (empty) → 0.0.0
raw patch · 7 files changed
+446/−0 lines, 7 filesdep +attoparsecdep +attoparsec-enumeratordep +basesetup-changed
Dependencies added: attoparsec, attoparsec-enumerator, base, bytestring, directory, enumerator, filepath, zlib-enum
Files
- Data/Git.hs +29/−0
- Data/Git/Parser.hs +130/−0
- Data/Git/Types.hs +62/−0
- LICENSE +29/−0
- Setup.hs +2/−0
- System/Git.hs +164/−0
- git-object.cabal +30/−0
+ Data/Git.hs view
@@ -0,0 +1,29 @@+{-|+ Types for Git objects and a parser of Git object files.+-}++module Data.Git (parseGitObject, module Data.Git.Types) where++import Codec.Zlib.Enum+import Data.Attoparsec.Enumerator+import Data.ByteString (ByteString)+import Data.Enumerator hiding (drop)+import qualified Data.Enumerator.Binary as EB+import Data.Git.Parser+import Data.Git.Types++{-|+ Parsing a Git file to 'GitObject'.+ This parser based on attoparsec-enumerator.+-}+parseGitObject :: FilePath -> IO GitObject+parseGitObject file = run_ $ EB.enumFile file+ $$ decompress defaultWindowBits+ =$ iterGitObject++iterGitObject :: Iteratee ByteString IO GitObject+iterGitObject = iterParser gitObject++infixr 0 =$+(=$) :: Monad m => Enumeratee ao ai m b -> Iteratee ai m b -> Iteratee ao m b+ee =$ ie = joinI $ ee $$ ie
+ Data/Git/Parser.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++module Data.Git.Parser (gitObject) where++import Control.Applicative hiding (many)+import qualified Data.Attoparsec as AP (takeWhile)+import qualified Data.Attoparsec.Char8 as AP (take)+import Data.Attoparsec.Char8 hiding (take)+import Data.Bits+import qualified Data.ByteString as BS (foldl', foldr)+import qualified Data.ByteString.Char8 as BS (unpack)+import Data.Git.Types+import Data.Char++----------------------------------------------------------------++gitObject :: Parser GitObject+gitObject = do+ (typ,len) <- header+ case typ of+ GtBlob -> GoBlob len <$> blob len+ GtTree -> GoTree len <$> tree+ GtCommit -> GoCommit len <$> commit+ GtTag -> GoTag len <$> tag++----------------------------------------------------------------++header :: Parser (GitType, Int)+header = (,) <$> (gitType <* spc) <*> (decimal <* nul)++gitType :: Parser GitType+gitType = GtBlob <$ string "blob"+ <|> GtTree <$ string "tree"+ <|> GtCommit <$ string "commit"+ <|> GtTag <$ string "tag"++----------------------------------------------------------------++blob :: Int -> Parser Blob+blob = AP.take++----------------------------------------------------------------++tree :: Parser [GitTreeEntry]+tree = many1 entry++entry :: Parser GitTreeEntry+entry = GitTreeEntry <$> (filetype <* spc)+ <*> (filepath <* nul)+ <*> binarySha1+ where+ filepath = many1 $ noneOf "\0"++filetype :: Parser FileType+filetype = getType . fromIntegral <$> octal+ where+ getMode x = x .&. 0o7777+ getType x+ | isBitSet x 0o0040000 = Directory+ | isBitSet x 0o0120000 = SymbolicLink+ | isBitSet x 0o0160000 = GitLink+ | otherwise = RegularFile (getMode x)+ isBitSet x mask = x .&. mask == mask++----------------------------------------------------------------++commit :: Parser GitCommit+commit = GitCommit <$> tre <*> parents <*> author <*> owner <*> logmsg+ where+ tre = string "tree " *> sha1 <* endOfLine+ parents = many parent+ parent = string "parent " *> sha1 <* endOfLine+ author = string "author " *> line+ owner = string "committer " *> line+ logmsg = endOfLine *> AP.takeWhile (const True) <* endOfInput+ line = AP.takeWhile (not.isEndOfLine) <* endOfLine++----------------------------------------------------------------++tag :: Parser GitTag+tag = GitTag <$> obj <*> typ <*> name <*> owner <*> tagmsg+ where+ obj = string "object " *> sha1 <* endOfLine+ typ = string "type " *> line+ name = string "tag " *> line+ owner = string "tagger " *> line+ tagmsg = endOfLine *> AP.takeWhile (const True) <* endOfInput+ line = AP.takeWhile (not.isEndOfLine) <* endOfLine++----------------------------------------------------------------++binarySha1 :: Parser SHA1+binarySha1 = SHA1 . (flip toASCII "") <$> AP.take 20+ where+ toASCII = BS.foldr (\w ss -> toHex w . ss) id+ toHex w = let (u,d) = w `divMod` 16+ hex2 = toH u : toH d : []+ in (hex2 ++)+ toH w+ | w >= 10 = chr $ baseA + (w' - 10)+ | otherwise = chr $ base0 + w'+ where+ w' = fromIntegral w+ baseA = ord 'a'+ base0 = ord '0'++sha1 :: Parser SHA1+sha1 = SHA1 . BS.unpack <$> AP.take 40++octal :: Parser Int+octal = BS.foldl' step 0 <$> AP.takeWhile isDig+ where+ isDig w = 48 <= w && w <= 55+ step a w = a * 8 + fromIntegral (w - 48)++----------------------------------------------------------------++{-+oneOf :: String -> Parser Char+oneOf = satisfy . inClass+-}++noneOf :: String -> Parser Char+noneOf = satisfy . notInClass++spc :: Parser ()+spc = () <$ char ' '++nul :: Parser ()+nul = () <$ char '\0'
+ Data/Git/Types.hs view
@@ -0,0 +1,62 @@+module Data.Git.Types where++import Data.ByteString (ByteString)+import System.Posix.Types (FileMode)++----------------------------------------------------------------++data GitType = GtBlob | GtTree | GtCommit | GtTag deriving (Eq,Show)++----------------------------------------------------------------++type Size = Int+data GitObject = GoBlob Size Blob+ | GoTree Size [GitTreeEntry]+ | GoCommit Size GitCommit+ | GoTag Size GitTag+ deriving (Eq,Show)++----------------------------------------------------------------++type Blob = ByteString++----------------------------------------------------------------++data GitTreeEntry = GitTreeEntry {+ fileType :: FileType+ , fileName :: FilePath+ , fileRef :: SHA1+ } deriving (Eq,Show)++data FileType = RegularFile FileMode+ | Directory+ | SymbolicLink+ | GitLink+ deriving (Eq,Show)++----------------------------------------------------------------++data GitCommit = GitCommit {+ commitRef :: SHA1+ , commitParents :: [SHA1]+ , commitAuthor :: ByteString+ , committer :: ByteString+ , commitLog :: ByteString+ } deriving (Eq,Show)++----------------------------------------------------------------++data GitTag = GitTag {+ tagRef :: SHA1+ , tagType :: ByteString+ , tagName :: ByteString+ , tagger :: ByteString+ , tagLog :: ByteString+ } deriving (Eq,Show)++----------------------------------------------------------------++newtype SHA1 = SHA1 String deriving Eq++instance Show SHA1 where+ show (SHA1 x) = x
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2011, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.+ * Neither the name of the copyright holders nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/Git.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE DeriveDataTypeable #-}++{-|+ Manipulating 'GitObject'.+-}++module System.Git (+ gitPathToGitObject+ , GitError(..)+ , GitDir, GitPath+ , findGitDir+ , rootSha1+ , rootCommitObj+ , gitPathToSha1+ , gitPathToObj+ , sha1ToObjFile+ , sha1ToObj+ ) where++import Control.Applicative+import Control.Exception+import Data.Git+import Data.Typeable (Typeable)+import Prelude hiding (catch)+import System.Directory+import System.FilePath+import System.IO++----------------------------------------------------------------++{-|+ Type for the path to Git repository directories.+-}+type GitDir = FilePath++{-|+ Type for the absolute path from the project root.+-}+type GitPath = FilePath++data GitError = GitDirNotExist | GitEntryNotExist+ deriving (Show, Typeable)+instance Exception GitError++----------------------------------------------------------------++{-|+ Getting 'GitObject' of 'GoBlob'/'GoTree' corresponding to 'GitPath'.+-}+gitPathToGitObject :: GitPath -> IO (Either SomeException GitObject)+gitPathToGitObject path = pathtoobj `catch` errorhandle+ where+ pathtoobj = findGitDir >>= gitPathToObj path >>= return . Right+ errorhandle :: SomeException -> IO (Either SomeException GitObject)+ errorhandle = return . Left++{-|+ Getting 'GitObject' of 'GoBlob'/'GoTree' corresponding to 'GitPath'.+-}+gitPathToObj :: GitPath -> GitDir -> IO GitObject+gitPathToObj path gitDir = gitPathToSha1 path gitDir >>= flip sha1ToObj gitDir++{-|+ Getting 'SHA1' corresponding to 'GitPath'.+-}+gitPathToSha1 :: GitPath -> GitDir -> IO SHA1+gitPathToSha1 path gitDir = do+ GoCommit _ commit <- rootCommitObj gitDir+ let sha1OfRootTreeObj = commitRef commit+ pathToSha1 ps sha1OfRootTreeObj gitDir+ where+ ps = tail $ splitFilePath path++pathToSha1 :: [String] -> SHA1 -> GitDir -> IO SHA1+pathToSha1 [] sha _ = return sha+pathToSha1 (f:fs) sha gitDir = do+ obj <- sha1ToObj sha gitDir+ case obj of+ GoTree _ ents -> case lokup f ents of+ Nothing -> throw GitEntryNotExist+ Just sha' -> pathToSha1 fs sha' gitDir+ _ -> throw GitEntryNotExist++{-+search :: GitDir -> [FilePath] -> GitObject -> IO GitObject+search gitDir fs (GoCommit _ com) =+ sha1ToObj (commitRef com) gitDir >>= search gitDir fs+search _ [] obj = return obj+search gitDir (f:fs) (GoTree _ ents) = case lokup f ents of+ Nothing -> throw GitEntryNotExist+ Just sha -> sha1ToObj sha gitDir >>= search gitDir fs+search _ _ _ = throw GitEntryNotExist+-}++lokup :: FilePath -> [GitTreeEntry] -> Maybe SHA1+lokup _ [] = Nothing+lokup key (e:es)+ | key == fileName e = Just (fileRef e)+ | otherwise = lokup key es++----------------------------------------------------------------++{-|+ Getting 'GitObject' of 'GoBlob' corresponding to the project root.+-}+rootCommitObj :: GitDir -> IO GitObject+rootCommitObj gitDir = rootSha1 gitDir >>= flip sha1ToObj gitDir++{-|+ Getting 'SHA1' of the project root.+-}+rootSha1 :: GitDir -> IO SHA1+rootSha1 gitDir = SHA1 <$> (getRootRefFile gitDir >>= readFileLine)++getRootRefFile :: GitDir -> IO FilePath+getRootRefFile gitDir = fieldToFile <$> readFileLine headFile+ where+ fieldToFile field = gitDir </> drop 5 field+ headFile = gitDir </> "HEAD"++----------------------------------------------------------------++{-|+ Finding 'GitDir' by tracking from the current directory+ to the root of the file system.+-}+findGitDir :: IO GitDir+findGitDir = getCurrentDirectory >>= loop+ where+ loop dir = do+ let gitDir = dir </> ".git"+ exist <- doesDirectoryExist gitDir+ if exist+ then return gitDir+ else if dir == "/"+ then throw GitDirNotExist+ else loop (takeDirectory dir)++----------------------------------------------------------------++{-|+ Getting 'GitObject' according to 'SHA1'.+-}+sha1ToObj :: SHA1 -> GitDir -> IO GitObject+sha1ToObj sha gitDir = parseGitObject $ sha1ToObjFile sha gitDir++{-|+ Getting 'FilePath' to the Git object file according to 'SHA1'.+-}+sha1ToObjFile :: SHA1 -> GitDir -> FilePath+sha1ToObjFile (SHA1 hash) gitDir =+ gitDir </> "objects" </> take 2 hash </> drop 2 hash++readFileLine :: FilePath -> IO String+readFileLine file = withBinaryFile file ReadMode hGetLine++----------------------------------------------------------------++-- splitFilePath "/foo/bar/baz/" -> ["","foo","bar","baz"]+splitFilePath :: FilePath -> [String]+splitFilePath "" = []+splitFilePath path = case break ('/'==) path of+ (xs,"") -> [xs]+ (xs,_:ys) -> xs : splitFilePath ys
+ git-object.cabal view
@@ -0,0 +1,30 @@+Name: git-object+Version: 0.0.0+Author: Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+License: BSD3+License-File: LICENSE+Synopsis: Git object and its parser+Description: This package provides data types for+ Git objects, enumerator-based parser+ of Git object files and manipulation+ functions.+Homepage: http://www.mew.org/~kazu/+Category: Data+Cabal-Version: >= 1.6+Build-Type: Simple+library+ if impl(ghc >= 6.12)+ GHC-Options: -Wall -fno-warn-unused-do-bind+ else+ GHC-Options: -Wall+ Exposed-Modules: Data.Git+ System.Git+ Other-Modules: Data.Git.Types+ Data.Git.Parser+ Build-Depends: base >= 4 && < 5, bytestring, zlib-enum,+ filepath, directory,+ attoparsec, enumerator, attoparsec-enumerator+Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/git-object.git