hit-0.4.0: Hit/Hit.hs

{-# LANGUAGE BangPatterns #-}
-- |
-- Module      : Hit
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unix
--
module Main where

import System.Environment
import Control.Applicative ((<$>))
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.Git.Storage.Pack
import Data.Git.Storage.Object
import Data.Git.Storage
import Data.Git.Types
import Data.Git.Ref
import Data.Git.Repository
import Data.Git.Revision
import Data.Word
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Char8 as BC
import Text.Printf
import qualified Data.Map as M
import qualified Data.HashTable.IO as H
import qualified Data.Hashable as Hashable

type HashTable k v = H.CuckooHashTable k v

instance Hashable.Hashable Ref where
	hash = Hashable.hash . toBinary

verifyPack pref git = do
	offsets     <- H.new
	tree        <- H.new
	refs        <- newIORef M.empty
	entries     <- fromIntegral <$> packReadHeader (gitRepoPath git) pref
	leftParsed  <- newIORef entries
	-- enumerate all objects either directly in tree for fully formed objects
	-- or a list of delta to resolves 
	packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree)
	readIORefAndReplace refs M.empty >>= dumpTree offsets tree
	where
		readIORefAndReplace ioref emptyVal = do
			v <- readIORef ioref
			writeIORef ioref emptyVal
			return v

		setObj_ refs offsets tree (!info, objData)
			| objectTypeIsDelta (poiType info) = do
				(!ty, !ref, !ptr, !lenChain) <- do
					let loc = Packed pref (poiOffset info)
					objInfo <- maybe (error "cannot find delta chain") id <$> getObjectRawAt git loc True
					let (ty, sz, _) = oiHeader objInfo
					let !ref = objectHash ty sz (oiData objInfo)
					let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain
					return (ty, ref, ptr, (length $ oiChains objInfo))
				H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain))
			| otherwise = do
				let !ref = objectHash (poiType info) (poiActualSize info) objData
				modifyIORef refs (M.insert ref ())
				H.insert offsets (poiOffset info) ref
				H.insert tree ref (info,Nothing)

		setObj leftParsed refs offsets tree x = do
			parsed <- readIORef leftParsed
			when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse")
			modifyIORef leftParsed (\i -> i-1)
			setObj_ refs offsets tree x

		dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO ()
		dumpTree offsets tree refs = do
			forM_ (M.toAscList refs) $ \(ref, ()) -> do
				ent <- fromJust <$> H.lookup tree ref
				printEnt offsets ref ent

		-- print one line about the entry
		-- format is <sha1> <type> <real size> <size> <offset> [<number of chain element> <parent element>]
		printEnt _ ref (info,Nothing) = do
			printf "%s %-6s %d %d %d\n" (show ref)
			       (objectTypeMarshall $ poiType info)
			       (poiActualSize info)
			       (poiSize info)
			       (poiOffset info)

		printEnt offsets ref (info,Just (parentOffset, lenChain)) = do
			parentRef <- case parentOffset of
				PtrRef r -> return r
				PtrOfs off -> do
					let poff = poiOffset info - off
					maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff
			printf "%s %-6s %d %d %d %d %s\n" (show ref)
			       (objectTypeMarshall $ poiType info)
			       (poiActualSize info)
			       (poiSize info)
			       (poiOffset info)
			       (lenChain)
			       (show parentRef)


catFile ty ref git = do
	let expectedType = case ty of
		"commit" -> Just TypeCommit
		"blob"   -> Just TypeBlob
		"tag"    -> Just TypeTag
		"tree"   -> Just TypeTree
		"-t"     -> Nothing
		_        -> error "unknown type request"
	mobj <- getObjectRaw git ref True
	case mobj of
		Nothing  -> error "not a valid object"
		Just obj ->
			let (objty, _, _) = oiHeader obj in
			case expectedType of
				Nothing  -> putStrLn $ objectTypeMarshall objty
				Just ety -> do
					when (ety /= objty) $ error "not expected type"
					LC.putStrLn (oiData obj)

lsTree revision _ git = do
	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision
	tree <- resolveTreeish git ref
	case tree of
		Just t -> do
			htree <- buildHTree git t
			mapM_ (showTreeEnt) htree 
		_      -> error "cannot build a tree from this reference"
	where
		showTreeEnt (p,n,TreeDir r _) = printf "%06o tree %s    %s\n" p (show r) (BC.unpack n)
		showTreeEnt (p,n,TreeFile r)  = printf "%06o blob %s    %s\n" p (show r) (BC.unpack n)

revList revision git = do
	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision
	loopTillEmpty ref
	where loopTillEmpty ref = do
		obj <- getCommit git ref
		case obj of
			Just (Commit { commitParents = parents }) -> do
				putStrLn $ show ref
				-- this behave like rev-list --first-parent.
				-- otherwise the parents need to be organized and printed
				-- in a reverse chronological fashion.
				case parents of
					[]    -> return ()
					(p:_) -> loopTillEmpty p
			Nothing -> error ("commit reference " ++ show ref ++ " in commit chain doesn't exists")

main = do
	args <- getArgs
	case args of
		["verify-pack",ref]  -> withCurrentRepo $ verifyPack (fromHexString ref)
		["cat-file",ty,ref]  -> withCurrentRepo $ catFile ty (fromHexString ref)
		["ls-tree",rev]      -> withCurrentRepo $ lsTree (fromString rev) ""
		["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path
		["rev-list",rev]     -> withCurrentRepo $ revList (fromString rev)
		cmd : [] -> error ("unknown command: " ++ cmd)
		[]       -> error "no args"
		_        -> error "unknown command line arguments"