diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010 Vincent Hanquez + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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. diff --git a/Lib/Git.hs b/Lib/Git.hs new file mode 100644 --- /dev/null +++ b/Lib/Git.hs @@ -0,0 +1,132 @@ +{- | + Module : Git + Copyright : Copyright (C) 2009-2010 Vincent Hanquez + License : BSD3 + Maintainer : Vincent Hanquez + Stability : alpha + Portabily : haven't tested + +This module provide Git functionality exec'ing the git binary. + +give simple access to commit, tree, tag, blob objects. +-} + + +module Lib.Git + ( module Lib.Git.Type + , module Lib.Git.Tree + , module Lib.Git.Index + , module Lib.Git.Lowlevel + , taglist + , initDB + , add + , rm + , commit + , checkout + , hasDiff + , resolveFilePath + ) where + +import Data.Maybe +import qualified Data.List +import Lib.Git.Type +import Lib.Git.Tree +import Lib.Git.Index +import Lib.Git.Lowlevel + +{- return a list of tags in this repository -} +taglist :: GitCtx [ TagID ] +taglist = do + o <- gitExec "tag" [] [] + case o of + Right out -> return $ lines out + Left _ -> return [] + +{- initialize a new repository database -} +initDB :: GitCtx () +initDB = do + o <- gitExec "init-db" ["--bare"] [] + case o of + Right _ -> return () + Left err -> gitError err "init-db" + +{- add filepath to repository -} +add :: [ FilePath ] -> GitCtx () +add paths = do + let opts = "--" : paths + o <- gitExec "add" opts [] + case o of + Right _ -> return () + Left err -> gitError err "add" + +{- rm filepath from repository -} +rm :: [ FilePath ] -> GitCtx () +rm paths = do + let opts = "--" : paths + o <- gitExec "rm" opts [] + case o of + Right _ -> return () + Left err -> gitError err "rm" + +{- commit change to the repository with optional filepaths -} +commit :: [ FilePath ] -> String -> String -> String -> GitCtx () +commit rsrcs author author_email logmsg = do + let authopts = [ "--author=", author ++ " <" ++ author_email ++ ">" ] + let msgopts = [ "-m", logmsg ] + let opts = authopts ++ msgopts ++ [ "--" ] ++ rsrcs + o <- gitExec "commit" opts [] + case o of + Right _ -> return () + Left err -> gitError err "commit" + +{- checkout the index to some commit id creating potentially a branch -} +checkout :: Maybe CommitID -> Maybe String -> GitCtx () +checkout rev branch = do + let bopt = maybe [] (\b -> [ "-b", b ]) branch + let copt = maybeToList rev -- [] (: []) rev + _ <- gitExec "checkout" (bopt ++ copt) [] + return () + +{- does the repository has modification in its index -} +hasDiff :: GitCtx Bool +hasDiff = do + o <- gitExec "diff" [ "--exit-code" ] [] + case o of + Left (1, _, _, _, _) -> return True + Right _ -> return False + Left err -> gitError err "hasdiff" + +resolveFilePath :: Commitent -> FilePath -> GitCtx [ (FilePath, Object) ] +resolveFilePath commitent filepath = do + let treeid = ceTree commitent + t <- catTree treeid + resolveFilePathTree t filepath + +resolveFilePathTree :: Treeent -> FilePath -> GitCtx [ (FilePath, Object) ] +resolveFilePathTree tree filepath = + case break (== '/') filepath of + ("", path) -> resolveFilePathTree tree (tail path) + (ent, "") -> do + let obj = objOfTreepath tree ent + case obj of + Just o -> return [ (ent, o) ] + Nothing -> error ("missing last ent " ++ ent) + (ent, path) -> + let obj = objOfTreepath tree ent in + case obj of + Just (Tree treeid) -> do + childtree <- catTree treeid + ret <- resolveFilePathTree childtree (tail path) + return ((ent, fromJust obj) : ret) + Just (Blob _) -> + return [ (ent, fromJust obj) ] + Just _ -> + error "assertion failed: expecting tree or blob" + Nothing -> + error ("missing ent " ++ ent) + +objOfTreepath :: Treeent -> String -> Maybe Object +objOfTreepath treeent path = + case Data.List.find (\(_, _, p) -> p == path) treeent of + Nothing -> Nothing + Just (_, obj, _) -> Just obj diff --git a/Lib/Git/Index.hs b/Lib/Git/Index.hs new file mode 100644 --- /dev/null +++ b/Lib/Git/Index.hs @@ -0,0 +1,39 @@ +module Lib.Git.Index + ( + indexUpdate + , indexCheckoutAll + , indexCheckout + , indexList + ) where + +import Lib.Git.Type + +indexUpdate :: [FilePath] -> GitCtx () +indexUpdate files = do + let args = [ "--" ] ++ files + o <- gitExec "update-index" args [] + case o of + Right _ -> return () + Left err -> gitError err "update-index" + +indexCheckoutAll :: Bool -> GitCtx () +indexCheckoutAll force = do + let args = (if force then [ "-f" ] else []) ++ [ "-a" ] + o <- gitExec "checkout-index" args [] + case o of + Right _ -> return () + Left err -> gitError err "checkout-index" + +indexCheckout :: [FilePath] -> Bool -> GitCtx () +indexCheckout paths force = do + let args = + (if force then [ "-f" ] else []) ++ + [ "--" ] ++ paths + o <- gitExec "checkout-index" args [] + case o of + Right _ -> return () + Left err -> gitError err "checkout-index" + +indexList :: GitCtx (FilePath) +indexList = do + return [] diff --git a/Lib/Git/Lowlevel.hs b/Lib/Git/Lowlevel.hs new file mode 100644 --- /dev/null +++ b/Lib/Git/Lowlevel.hs @@ -0,0 +1,148 @@ +module Lib.Git.Lowlevel + ( + revlist + , revparse + , catBlob + , catTag + , catTree + , catCommit + ) where + +import Lib.Git.Type +import Lib.Git.Tree +import Data.Char (chr, ord) +import Control.Monad +import Data.Maybe + +spanSubList :: ([a] -> Bool) -> [a] -> ([a], [a]) +spanSubList _ xs@[] = (xs, xs) +spanSubList p xs@(x:xs') + | p xs = let (ys,zs) = spanSubList p xs' in (x:ys,zs) + | otherwise = ([],xs) + +breakSubList :: ([a] -> Bool) -> [a] -> ([a], [a]) +breakSubList p = spanSubList (not . p) + +-- revision can be specified as CommitID | TagID + +{- revlist return a commit list in reverse chronological order l -} +revlist :: Maybe Int -> Maybe CommitID -> [ FilePath ] -> GitCtx [ CommitID ] +revlist lim topcommit paths = do + let commitid = fromMaybe "HEAD" topcommit + let opt_max = maybe [] (\x -> [ "max-count=" ++ show x ]) lim + let opts = opt_max ++ [ commitid, "--" ] ++ paths + o <- gitExec "rev-list" opts [] + case o of + Right out -> return $ lines out + Left err -> gitError err "rev-list" + +{- parse a tag/branch-name/commit into a commit if it exists -} +revparse :: String -> GitCtx (Maybe CommitID) +revparse commitid = do + o <- gitExec "rev-parse" [ commitid ] [] + case o of + Right out -> return $ Just (head $ lines out) + Left err -> gitError err "rev-parse" + +{- return object type -} +getObjType :: ID -> GitCtx (Maybe Object) +getObjType s = do + let object_of o = objOfString (head $ lines o) s + o <- gitExec "cat-file" [ "-t", s ] [] + case o of + Right out -> return $ object_of out + Left err -> gitError err ("cat-file -t " ++ s) + +{- return types of list of objects -} +getObjsType :: [ID] -> GitCtx [Maybe Object] +getObjsType = mapM getObjType + +{- cat an object with type specified -} +catType :: String -> ID -> GitCtx String +catType ty obj = do + o <- gitExec "cat-file" [ ty, obj ] [] + case o of + Right out -> return out + Left err -> gitError err "object doesn't exists or wrong type" + +-- cat specific objects type +catBlob :: BlobID -> GitCtx String +catTag :: TagID -> GitCtx String + +catBlob = catType "blob" +catTag = catType "tag" + +{- perms SP file \0 sha1 -} +catTree :: TreeID -> GitCtx Treeent +catTree treeid = do + let treebin_of (c, bs) = + let (perms, l1) = break (== ' ') bs in + let (file, left) = break (== '\0') (drop 1 l1) in + let sha1 = hexalise $ take 20 $ drop 1 left in + let bs' = drop 21 left in + let nt = (permsOfString perms, sha1, file) in + (nt : c, bs') + out <- catType "tree" treeid + let (trees, _) = runParseString treebin_of ([], out) + forM trees $ \(perms, sha1, file) -> do + obj <- getObjType sha1 + return (perms, fromJust obj, file) + +{- FIXME time : 1253463017 +0100 -} +catCommit :: CommitID -> GitCtx Commitent +catCommit commitid = do + out <- catType "commit" commitid + let (fullhdr, commitMsg) = breakSubList ((==) "\n\n" . take 2) out + let centinit = Commitent + { ceParents = [] + , ceTree = "" + , ceAuthor = Person { personName = "", personEmail = "" } + , ceAuthorTime = "" + , ceCommitter = Person { personName = "", personEmail = "" } + , ceCommitterTime = "" + , ceCommitMsg = drop 2 commitMsg + } + let id_of_string bs = + let (name, left) = breakSubList ((==) " <" . take 2) bs in + let (email, left') = breakSubList ((==) "> " . take 2) (drop 2 left) in + let time = drop 2 left' in + (Person { personName = name, personEmail = email }, time) + let author_of_line c bs = + let (author, authorTime) = id_of_string bs in + c { ceAuthor = author, ceAuthorTime = authorTime } + let committer_of_line c bs = + let (committer, committerTime) = id_of_string bs in + c { ceCommitter = committer, ceCommitterTime = committerTime } + let hdr_of_string (c, fline:left) = + let (cat, line) = break (== ' ') fline in + let c' = + case cat of + "tree" -> c { ceTree = drop 1 line } + "parent" -> c { ceParents = drop 1 line : ceParents c } + "author" -> author_of_line c (drop 1 line) + "committer" -> committer_of_line c (drop 1 line) + _ -> c + in + (c', left) + let (cent, _) = runParseLines hdr_of_string (centinit, lines fullhdr) + return cent + +hexalise :: String -> String +hexalise s = + concatMap (\b -> let c = ord b in [ hex $ c `div` 16, hex $ c `mod` 16 ]) s + where hex i + | i >= 0 && i <= 9 = chr $ ord '0' + i + | i >= 10 && i <= 15 = chr $ ord 'a' + i - 10 + | otherwise = '\0' + +runParseString :: ((t, String) -> (t, String)) -> (t, String) -> (t, String) +runParseString f (c, s) = + if null s + then (c, s) + else runParseString f $ f (c, s) + +runParseLines :: ((t, [a]) -> (t, [a])) -> (t, [a]) -> (t, [a]) +runParseLines f (c, l) = + if null l + then (c, l) + else runParseLines f $ f (c, l) diff --git a/Lib/Git/Tree.hs b/Lib/Git/Tree.hs new file mode 100644 --- /dev/null +++ b/Lib/Git/Tree.hs @@ -0,0 +1,46 @@ +module Lib.Git.Tree + ( treeList + , Perms + , permsOfString + , Treeent + ) where + +import Lib.Git.Type +import Data.Maybe + +type Perms = (Int, Int, Int, Int, Int, Int) -- find something better +type Treeent = [ (Perms, Object, FilePath) ] + +permsOfString :: String -> Perms +permsOfString s = + case map (read . replicate 1) s of + [ a, b, c, d, e, f ] -> (a, b, c, d, e, f) + _ -> (0, 0, 0, 0, 0, 0) + +split :: Char -> String -> [String] +split _ [] = [""] +split delim (c:cs) + | c == delim = "" : rest + | otherwise = (c : head rest) : tail rest + where + rest = split delim cs + +{- return tree list -} +treeList :: Maybe CommitID -> GitCtx Treeent +treeList commitid = do + let treeent_of_line line = + -- parse persmission SP type SP SHA1 SP filename + case split '\t' line of + [ o, filename ] -> + case split ' ' o of + [ perms, ty, sha1 ] -> + let object = fromJust $ objOfString ty sha1 in + Just (permsOfString perms, object, filename) + _ -> Nothing + _ -> Nothing + let comm = fromMaybe "HEAD" commitid + let opts = [ comm ] + o <- gitExec "ls-tree" opts [] + case o of + Right out -> return (mapMaybe treeent_of_line $ lines out) + Left err -> gitError err "ls-tree" diff --git a/Lib/Git/Type.hs b/Lib/Git/Type.hs new file mode 100644 --- /dev/null +++ b/Lib/Git/Type.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +module Lib.Git.Type + ( runGit + , GitFailure + , gitExec + , gitError + , GitCtx + , makeConfig + , Object(..) + , Config(..) + , Commitent(..) + , Person(..) + , ID + , CommitID + , BlobID + , TreeID + , TagID + , toID + , objToID + , objOfString + ) where + +import System.Process +import System.Exit +import Data.Maybe +import qualified Control.Exception as C +import Control.Concurrent +import Control.Monad.Reader +import System.IO (Handle, hFlush, hClose, hGetContents, hPutStr) + +type ID = String +type CommitID = ID +type BlobID = ID +type TreeID = ID +type TagID = ID + +data Object = + Commit CommitID + | Blob BlobID + | Tree TreeID + | Tag TagID + deriving (Show) + +type GitFailure = (Int, String, String, String, [String]) + +data Config = Config { configCwd :: FilePath, configGitPath :: Maybe FilePath } + +newtype GitCtx a = GitCtx (ReaderT Config IO a) + deriving (Monad, MonadIO, MonadReader Config) + +data Person = Person + { personName :: String + , personEmail :: String + } deriving (Show) + +data Commitent = Commitent + { ceParents :: [CommitID] + , ceTree :: TreeID + , ceAuthor :: Person + , ceAuthorTime :: String + , ceCommitter :: Person + , ceCommitterTime :: String + , ceCommitMsg :: String + } deriving (Show) + +-- read a string as an ID +toID :: String -> ID +toID = id + +objToID :: Object -> ID +objToID (Commit gitid) = gitid +objToID (Tree gitid) = gitid +objToID (Blob gitid) = gitid +objToID (Tag gitid) = gitid + +objOfString :: String -> ID -> Maybe Object +objOfString s gitid = + case s of + "blob" -> Just $ Blob gitid + "tree" -> Just $ Tree gitid + "commit" -> Just $ Commit gitid + "tag" -> Just $ Tag gitid + _ -> Nothing + +runGit :: Config -> GitCtx t -> IO t +runGit config (GitCtx a) = runReaderT a config + +-- just exec with stdin/stdout/stderr as pipes +execProcWithPipes :: FilePath -> String -> [String] -> [(String, String)] + -> IO (Handle, Handle, Handle, ProcessHandle) +execProcWithPipes mcwd command args menv = do + (Just inh, Just outh, Just errh, pid) <- createProcess (proc command args) + { std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = Just mcwd, + env = Just menv } + return (inh, outh, errh, pid) + +gitExec :: String -> [String] -> [(String, String)] + -> GitCtx (Either GitFailure String) +gitExec cmd opts menv = do + cfg <- ask + let args = cmd : opts + let gitpath = fromMaybe "git" (configGitPath cfg) + (ec, out, err) <- liftIO $ readProc (configCwd cfg) gitpath args menv "" + case ec of + ExitSuccess -> return $ Right out + ExitFailure i -> return $ Left (i, out, err, configCwd cfg, cmd : opts) + +gitError :: GitFailure -> String -> b +gitError (exitval, stdout, stderr, mcwd, cmd) msg = + error $ concat [ "git error ", "[cwd: ", mcwd, + "][exec: ", concat cmd, "][exit: ", show exitval, "][msg: ", msg, "] ", + "stdout: ", stdout, " stderr: ", stderr ] + +-- same as readProcessWithExitCode but having a configurable cwd and env, +readProc :: FilePath -> String -> [String] -> [(String, String)] -> String + -> IO (ExitCode, String, String) +readProc mcwd command args menv input = do + (inh, outh, errh, pid) <- execProcWithPipes mcwd command args menv + + outMVar <- newEmptyMVar + + out <- hGetContents outh + _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar () + + err <- hGetContents errh + _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () + + when (length input > 0) $ do hPutStr inh input; hFlush inh + hClose inh + + takeMVar outMVar + takeMVar outMVar + hClose outh + hClose errh + + ex <- waitForProcess pid + return (ex, out, err) + +{- initialize a git context. just a path for now could take limit afterwards -} +makeConfig :: FilePath -> Maybe FilePath -> Config +makeConfig path gitpath = Config { configCwd = path, configGitPath = gitpath } diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,11 @@ +hs-libgit is a haskell wrapper for git. + +It provides lowlevel operations (list/cat object, ..) and some high level operation +(commit, checkout, diff...). it requires the git binary available on the system. + +when time permit, the wrapper will be made as a binding on top of libgit2. + +TODO: +- clean the commit/tree parsing +- make it more robust/better error checking +- split modules into multiples files (lowlevel, monad, highlevel) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/libgit.cabal b/libgit.cabal new file mode 100644 --- /dev/null +++ b/libgit.cabal @@ -0,0 +1,29 @@ +Name: libgit +Version: 0.1.0 +Description: + Simple git wrapper to access common git functions in a simple haskell way. +License: BSD3 +License-file: LICENSE +Copyright: Vincent Hanquez +Author: Vincent Hanquez +Maintainer: Vincent Hanquez +Synopsis: Simple Git Wrapper +Category: Development +Stability: experimental +Build-Type: Simple +Homepage: http://github.com/vincenthz/hs-tls +Cabal-Version: >=1.6 +data-files: README + +Library + Build-Depends: base >= 3 && < 6, mtl, process + Exposed-modules: Lib.Git + Exposed-modules: Lib.Git.Type + Lib.Git.Tree + Lib.Git.Index + Lib.Git.Lowlevel + ghc-options: -Wall + +source-repository head + type: git + location: git://github.com/vincenthz/hs-libgit