diff --git a/Data/Git.hs b/Data/Git.hs --- a/Data/Git.hs +++ b/Data/Git.hs @@ -9,13 +9,14 @@ ( -- * Basic types Ref + , RefName(..) , Commit(..) , Person(..) , CommitExtra(..) , Tree(..) , Blob(..) , Tag(..) - , GitTime(..) + , GitTime , ModePerm(..) -- * Helper & type related to ModePerm @@ -51,6 +52,15 @@ -- * Set objects , setObject + , toObject + + -- * Named refs + , branchWrite + , branchList + , tagWrite + , tagList + , headSet + , headGet ) where import Data.Git.Ref @@ -58,3 +68,4 @@ import Data.Git.Storage import Data.Git.Repository import Data.Git.Revision +import Data.Git.Storage.Object (toObject) diff --git a/Data/Git/Config.hs b/Data/Git/Config.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Config.hs @@ -0,0 +1,58 @@ +-- | +-- Module : Data.Git.Config +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unix +-- +-- config related types and methods. +-- +module Data.Git.Config + ( Config(..) + , Section(..) + -- * methods + , readConfig + ) where + +import Control.Applicative +import Data.Git.Path +import Filesystem.Path.CurrentOS + +newtype Config = Config [Section] + deriving (Show,Eq) + +data Section = Section + { sectionName :: String + , sectionKVs :: [(String, String)] + } deriving (Show,Eq) + +parseConfig :: String -> Config +parseConfig = Config . reverse . toSections . foldl accSections ([], Nothing) . lines + where toSections (l,Nothing) = l + toSections (l,Just s) = s : l + + -- a new section in the config file + accSections (sections, mcurrent) ('[':sectNameE) + | last sectNameE == ']' = + let sectName = take (length sectNameE - 1) sectNameE + in case mcurrent of + Nothing -> (sections, Just $ Section sectName []) + Just current -> (sectionFinalize current : sections, Just $ Section sectName []) + | otherwise = + (sections, mcurrent) + -- a normal line without having any section defined yet + accSections acc@(_, Nothing) _ = acc + -- potentially a k-v line in an existing section + accSections (sections, Just current) kvLine = + case break (== '=') kvLine of + (k,'=':v) -> (sections, Just $ sectionAppend current (strip k, strip v)) + (_,_) -> (sections, Just current) -- not a k = v line + -- append a key-value + sectionAppend (Section n l) kv = Section n (kv:l) + sectionFinalize (Section n l) = Section n $ reverse l + + strip s = dropSpaces $ reverse $ dropSpaces $ reverse s + where dropSpaces = dropWhile (\c -> c == ' ' || c == '\t') + +readConfigPath filepath = parseConfig <$> readFile (encodeString filepath) +readConfig gitRepo = readConfigPath (configPath gitRepo) diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs --- a/Data/Git/Named.hs +++ b/Data/Git/Named.hs @@ -15,14 +15,15 @@ , RefContentTy(..) , RefName(..) , readPackedRefs + , PackedRefs(..) -- * manipulating loosed name references , existsRefFile , writeRefFile , readRefFile -- * listings looses name references - , headsList - , tagsList - , remotesList + , looseHeadsList + , looseTagsList + , looseRemotesList ) where import Control.Applicative ((<$>)) @@ -119,17 +120,35 @@ toPath gitRepo RefFetchHead = gitRepo "FETCH_HEAD" toPath gitRepo (RefOther h) = gitRepo fromString h -readPackedRefs :: FilePath -> IO [(RefSpecTy, Ref)] -readPackedRefs gitRepo = do +data PackedRefs a = PackedRefs + { packedRemotes :: a + , packedBranchs :: a + , packedTags :: a + } + +readPackedRefs :: FilePath + -> ([(RefName, Ref)] -> a) + -> IO (PackedRefs a) +readPackedRefs gitRepo constr = do exists <- F.isFile (packedRefsPath gitRepo) - if exists then readLines else return [] - where readLines = foldl accu [] . BC.lines <$> F.readFile (packedRefsPath gitRepo) - accu a l + if exists then readLines else return $ finalize emptyPackedRefs + where emptyPackedRefs = PackedRefs [] [] [] + readLines = finalize . foldl accu emptyPackedRefs . BC.lines <$> F.readFile (packedRefsPath gitRepo) + finalize (PackedRefs a b c) = PackedRefs (constr a) (constr b) (constr c) + accu a l | "#" `BC.isPrefixOf` l = a - | otherwise = let (ref, r) = B.splitAt 40 l - name = FP.encodeString FP.posix $ pathDecode $ B.tail r - in (toRefTy name, fromHex ref) : a + | otherwise = + let (ref, r) = B.splitAt 40 l + name = FP.encodeString FP.posix $ pathDecode $ B.tail r + in case toRefTy name of + -- accumulate tag, branch and remotes + RefTag refname -> a { packedTags = (refname, fromHex ref) : packedTags a } + RefBranch refname -> a { packedBranchs = (refname, fromHex ref) : packedBranchs a } + RefRemote refname -> a { packedRemotes = (refname, fromHex ref) : packedRemotes a } + -- anything else that shouldn't be there get dropped on the floor + _ -> a +-- | list all the loose refs available recursively from a directory starting point listRefs :: FilePath -> IO [RefName] listRefs root = listRefsAcc [] root where listRefsAcc acc dir = do @@ -147,14 +166,14 @@ getRefsRecursively dir (extra ++ acc) xs stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p -headsList :: FilePath -> IO [RefName] -headsList gitRepo = listRefs (headsPath gitRepo) +looseHeadsList :: FilePath -> IO [RefName] +looseHeadsList gitRepo = listRefs (headsPath gitRepo) -tagsList :: FilePath -> IO [RefName] -tagsList gitRepo = listRefs (tagsPath gitRepo) +looseTagsList :: FilePath -> IO [RefName] +looseTagsList gitRepo = listRefs (tagsPath gitRepo) -remotesList :: FilePath -> IO [RefName] -remotesList gitRepo = listRefs (remotesPath gitRepo) +looseRemotesList :: FilePath -> IO [RefName] +looseRemotesList gitRepo = listRefs (remotesPath gitRepo) existsRefFile :: FilePath -> RefSpecTy -> IO Bool existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs --- a/Data/Git/Path.hs +++ b/Data/Git/Path.hs @@ -14,6 +14,8 @@ import Data.Git.Ref import Data.String +configPath gitRepo = gitRepo "config" + headsPath gitRepo = gitRepo "refs" "heads" "" tagsPath gitRepo = gitRepo "refs" "tags" "" remotesPath gitRepo = gitRepo "refs" "remotes" "" diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -10,8 +10,14 @@ -- module Data.Git.Repository ( Git + -- * Config + , configRead + , Cfg.Config(..) + , Cfg.Section(..) + -- * Trees , HTree , HTreeEnt(..) + , RefName(..) , getCommitMaybe , getCommit , getTreeMaybe @@ -23,6 +29,13 @@ , resolveRevision , initRepo , isRepo + -- * named refs manipulation + , branchWrite + , branchList + , tagWrite + , tagList + , headSet + , headGet ) where import Control.Applicative ((<$>)) @@ -43,8 +56,12 @@ import Data.Git.Storage.Loose import Data.Git.Storage.CacheFile import Data.Git.Ref +import qualified Data.Git.Config as Cfg +import Data.Set (Set) + import qualified Data.Map as M +import qualified Data.Set as Set -- | hierarchy tree, either a reference to a blob (file) or a tree (directory). data HTreeEnt = TreeDir Ref HTree | TreeFile Ref @@ -100,9 +117,12 @@ RefDirect ref -> return $ Just ref RefLink refspecty -> followToRef onFailure refspecty _ -> error "cannot handle reference content" - else case M.lookup refty lookupCache of - Nothing -> onFailure - y -> return y + else case refty of + RefTag name -> mapLookup name $ packedTags lookupCache + RefBranch name -> mapLookup name $ packedBranchs lookupCache + RefRemote name -> mapLookup name $ packedRemotes lookupCache + _ -> return Nothing + where mapLookup name m = maybe onFailure (return . Just) $ M.lookup name m namedResolvers = case prefix of "HEAD" -> [ RefHead ] @@ -220,3 +240,57 @@ findEnt x = find (\(_, b, _) -> b == x) treeEntRef (_,_,r) = r + +-- | Write a branch to point to a specific reference +branchWrite :: Git -- ^ repository + -> RefName -- ^ the name of the branch to write + -> Ref -- ^ the reference to set + -> IO () +branchWrite git branchName ref = + writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref) + +-- | Return the list of branches +branchList :: Git -> IO (Set RefName) +branchList git = do + ps <- Set.fromList . M.keys . packedBranchs <$> getCacheVal (packedNamed git) + ls <- Set.fromList <$> looseHeadsList (gitRepoPath git) + return $ Set.union ps ls + +-- | Write a tag to point to a specific reference +tagWrite :: Git -- ^ repository + -> RefName -- ^ the name of the tag to write + -> Ref -- ^ the reference to set + -> IO () +tagWrite git tagname ref = + writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref) + +-- | Return the list of branches +tagList :: Git -> IO (Set RefName) +tagList git = do + ps <- Set.fromList . M.keys . packedTags <$> getCacheVal (packedNamed git) + ls <- Set.fromList <$> looseTagsList (gitRepoPath git) + return $ Set.union ps ls + +-- | Set head to point to either a reference or a branch name. +headSet :: Git -- ^ repository + -> Either Ref RefName -- ^ either a raw reference or a branch name + -> IO () +headSet git (Left ref) = + writeRefFile (gitRepoPath git) RefHead (RefDirect ref) +headSet git (Right refname) = + writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname) + +-- | Get what the head is pointing to, or the reference otherwise +headGet :: Git + -> IO (Either Ref RefName) +headGet git = do + content <- readRefFile (gitRepoPath git) RefHead + case content of + RefLink (RefBranch b) -> return $ Right b + RefLink spec -> error ("unknown content link in HEAD: " ++ show spec) + RefDirect r -> return $ Left r + RefContentUnknown bs -> error ("unknown content in HEAD: " ++ show bs) + +-- | Read the Config +configRead :: Git -> IO Cfg.Config +configRead git = Cfg.readConfig (gitRepoPath git) diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs --- a/Data/Git/Storage.hs +++ b/Data/Git/Storage.hs @@ -12,6 +12,7 @@ ( Git , packedNamed , gitRepoPath + -- * opening repositories , openRepo , closeRepo , withRepo @@ -19,9 +20,12 @@ , findRepoMaybe , findRepo , isRepo + -- * creating repositories , initRepo + -- * repository accessors , getDescription , setDescription + -- * iterators , iterateIndexes , findReference , findReferencesWithPrefix @@ -69,7 +73,7 @@ data PackIndexReader = PackIndexReader PackIndexHeader FileReader -- | this is a cache representation of the packed-ref file -type PackedRef = CacheFile (M.Map RefSpecTy Ref) +type CachedPackedRef = CacheFile (PackedRefs (M.Map RefName Ref)) -- | represent a git repo, with possibly already opened filereaders -- for indexes and packs @@ -77,13 +81,15 @@ { gitRepoPath :: FilePath , indexReaders :: IORef [(Ref, PackIndexReader)] , packReaders :: IORef [(Ref, FileReader)] - , packedNamed :: PackedRef + , packedNamed :: CachedPackedRef } -- | open a new git repository context openRepo :: FilePath -> IO Git openRepo path = liftM3 (Git path) (newIORef []) (newIORef []) packedRef - where packedRef = newCacheVal (packedRefsPath path) (M.fromList <$> readPackedRefs path) M.empty + where packedRef = newCacheVal (packedRefsPath path) + (readPackedRefs path M.fromList) + (PackedRefs M.empty M.empty M.empty) -- | close a git repository context, closing all remaining fileReaders. closeRepo :: Git -> IO () diff --git a/Data/Git/Storage/CacheFile.hs b/Data/Git/Storage/CacheFile.hs --- a/Data/Git/Storage/CacheFile.hs +++ b/Data/Git/Storage/CacheFile.hs @@ -11,10 +11,11 @@ import Control.Applicative ((<$>)) import Control.Concurrent.MVar import qualified Control.Exception as E -import Data.Time.Clock -import Filesystem import Filesystem.Path +import Filesystem.Path.CurrentOS (encodeString) import Prelude hiding (FilePath) +import System.Posix.Files (getFileStatus, modificationTime) +import System.Posix.Types (EpochTime) data CacheFile a = CacheFile { cacheFilepath :: FilePath @@ -23,22 +24,22 @@ , cacheLock :: MVar (MTime, a) } -utcZero = UTCTime (toEnum 0) 0 +timeZero = 0 newCacheVal :: FilePath -> IO a -> a -> IO (CacheFile a) newCacheVal path refresh initialVal = - CacheFile path refresh initialVal <$> newMVar (MTime utcZero, initialVal) + CacheFile path refresh initialVal <$> newMVar (MTime timeZero, initialVal) getCacheVal :: CacheFile a -> IO a getCacheVal cachefile = modifyMVar (cacheLock cachefile) getOrRefresh where getOrRefresh s@(mtime, cachedVal) = do cMTime <- getMTime $ cacheFilepath cachefile case cMTime of - Nothing -> return ((MTime utcZero, cacheIniVal cachefile), cacheIniVal cachefile) + Nothing -> return ((MTime timeZero, cacheIniVal cachefile), cacheIniVal cachefile) Just newMtime | newMtime > mtime -> cacheRefresh cachefile >>= \v -> return ((newMtime, v), v) | otherwise -> return (s, cachedVal) -newtype MTime = MTime UTCTime deriving (Eq,Ord) +newtype MTime = MTime EpochTime deriving (Eq,Ord) -getMTime filepath = (Just . MTime <$> getModified filepath) +getMTime filepath = (Just . MTime . modificationTime <$> getFileStatus (encodeString filepath)) `E.catch` \(_ :: E.SomeException) -> return Nothing diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs --- a/Data/Git/Storage/Object.hs +++ b/Data/Git/Storage/Object.hs @@ -57,6 +57,7 @@ import Data.List (intersperse) import Data.Monoid import Data.Word +import Data.Hourglass import Text.Printf #if MIN_VERSION_bytestring(0,10,0) @@ -232,9 +233,12 @@ _ <- string "> " time <- PC.decimal :: Parser Integer _ <- string " " - timezone <- PC.signed PC.decimal + timezoneFmt <- PC.signed PC.decimal + let timezoneSign = if timezoneFmt < 0 then negate else id + let (h,m) = abs timezoneFmt `divMod` 100 + timezone = timezoneSign (h * 60 + m) skipChar '\n' - return $ Person name email (GitTime time timezone) + return $ Person name email (gitTime time timezone) objectParseTree = ObjTree <$> treeParse objectParseCommit = ObjCommit <$> commitParse @@ -337,7 +341,6 @@ objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs) -- used for objectWrite for commit and tag -writeName label (Person name email (GitTime time tz)) = - B.concat [label, " ", name, " <", email, "> ", BC.pack (printf "%d %s%02d%02d" time tzs tzh tzm) ] - where tzs = if tz >= 0 then "+" else "-" :: String - (tzh,tzm) = abs (tz) `divMod` 100 +writeName label (Person name email locTime) = + B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr] + where timeStr = timePrint ("EPOCH TZHM" :: String) locTime diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -24,10 +24,8 @@ , getPermission , getFiletype -- * time type - , GitTime(..) - , toUTCTime - , toPOSIXTime - , toZonedTime + , GitTime + , gitTime -- * Pack delta types , DeltaOfs(..) , DeltaRef(..) @@ -43,9 +41,7 @@ import Data.Git.Ref import Data.Git.Delta -import Data.Time.Clock -import Data.Time.LocalTime -import Data.Time.Clock.POSIX +import Data.Hourglass (Elapsed, LocalTime(..), TimezoneOffset(..)) import Data.Data @@ -60,22 +56,11 @@ deriving (Show,Eq,Data,Typeable) -- | Git time is number of seconds since unix epoch with a timezone -data GitTime = GitTime Integer Int - deriving (Show,Eq) - -toUTCTime :: GitTime -> UTCTime -toUTCTime = zonedTimeToUTC . toZonedTime - -toPOSIXTime :: GitTime -> POSIXTime -toPOSIXTime = utcTimeToPOSIXSeconds . toUTCTime +type GitTime = LocalTime Elapsed -toZonedTime :: GitTime -> ZonedTime -toZonedTime (GitTime epoch tzHourMin) = zonedTime - where tz = minutesToTimeZone (signum h * minutes) - (h,m) = tzHourMin `divMod` 100 - minutes = abs h * 60 + m - utcTime = posixSecondsToUTCTime $ fromIntegral epoch - zonedTime = utcToZonedTime tz utcTime +gitTime :: Integer -> Int -> GitTime +gitTime seconds tzMins = + LocalTime (fromIntegral seconds) (TimezoneOffset tzMins) -- | the enum instance is useful when marshalling to pack file. instance Enum ObjectType where diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -19,10 +19,11 @@ import Data.Git.Types import Data.Git.Ref import Data.Git.Repository -import Data.Git.Named import Data.Git.Revision import Data.Git.Diff +import Data.Hourglass import Data.Word +import qualified Data.Set as S import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Char8 as BC import Text.Printf @@ -47,7 +48,7 @@ -- 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 + where readIORefAndReplace ioref emptyVal = do v <- readIORef ioref writeIORef ioref emptyVal @@ -157,7 +158,7 @@ mapM_ putStrLn [ ("commit: " ++ show ref) , ("author: " ++ BC.unpack (personName author) ++ " <" ++ BC.unpack (personEmail author) ++ ">") - , ("date: " ++ show (toZonedTime $ personTime author) ++ " (" ++ show (toUTCTime $ personTime author) ++ ")") + , ("date: " ++ timePrint ISO8601_DateAndTime (personTime author) ++ " (" ++ timePrint ISO8601_DateAndTime (personTime author) ++ ")") , "" , BC.unpack $ commitMessage commit ] @@ -215,12 +216,12 @@ showRefs git = do - putStrLn "[HEADS]" - heads <- headsList (gitRepoPath git) - mapM_ (putStrLn . show) heads + putStrLn "[BRANCHES]" + heads <- branchList git + mapM_ (putStrLn . refNameRaw) $ S.toList heads putStrLn "[TAGS]" - tags <- tagsList (gitRepoPath git) - mapM_ (putStrLn . show) tags + tags <- tagList git + mapM_ (putStrLn . refNameRaw) $ S.toList tags main = do args <- getArgs @@ -232,7 +233,9 @@ ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) ["log",rev] -> withCurrentRepo $ getLog (fromString rev) ["diff",rev1,rev2] -> withCurrentRepo $ showDiff (fromString rev1) (fromString rev2) + ["tag"] -> withCurrentRepo $ showRefs ["show-refs"] -> withCurrentRepo $ showRefs + ["read-config"] -> withCurrentRepo $ \git -> configRead git >>= putStrLn . show cmd : [] -> error ("unknown command: " ++ cmd) [] -> error "no args" _ -> error "unknown command line arguments" diff --git a/Tests/Repo.hs b/Tests/Repo.hs --- a/Tests/Repo.hs +++ b/Tests/Repo.hs @@ -15,9 +15,6 @@ import Data.Git.Types import Data.Git.Repository -import Data.Time.LocalTime -import Data.Time.Clock -import Data.Time.Calendar import Data.Maybe import Text.Bytedump diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -12,9 +12,7 @@ import Data.Git.Storage.Loose import Data.Git.Ref import Data.Git.Types -import Data.Time.LocalTime -import Data.Time.Clock -import Data.Time.Calendar +import Data.Hourglass import Data.Maybe @@ -45,22 +43,12 @@ arbitraryEnt = liftM3 (,,) arbitrary (arbitraryBSno0 48) arbitrary arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt -instance Arbitrary TimeZone where - arbitrary = hoursToTimeZone . rel <$> arbitrary - where rel a = (a `mod` 24) - 12 - -instance Arbitrary UTCTime where - arbitrary = UTCTime <$> (flip addDays b <$> choose (0, 365 * 40)) - <*> (secondsToDiffTime <$> arbitrary) - where b = fromGregorian 1970 1 1 - -instance Arbitrary GitTime where - arbitrary = GitTime <$> (arbitrary `suchThat` \i -> i > 0) <*> arbitraryTz - where arbitraryTz = do - h <- choose (0, 23) - m <- (* 30) <$> choose (0,1) - return (h * 100 + m - 1200) - +instance Arbitrary TimezoneOffset where + arbitrary = TimezoneOffset <$> choose (-11*60, 12*60) +instance Arbitrary Elapsed where + arbitrary = Elapsed . Seconds <$> choose (0,2^32-1) +instance Arbitrary t => Arbitrary (LocalTime t) where + arbitrary = LocalTime <$> arbitrary <*> arbitrary instance Arbitrary ModePerm where arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ] diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,5 +1,5 @@ Name: hit -Version: 0.5.5 +Version: 0.6.0 Synopsis: Git operations in haskell Description: . @@ -46,7 +46,8 @@ , random , zlib , zlib-bindings >= 0.1 && < 0.2 - , time + , hourglass + , unix , patience Exposed-modules: Data.Git Data.Git.Types @@ -62,6 +63,7 @@ Data.Git.Repository Data.Git.Diff Other-modules: Data.Git.Internal + Data.Git.Config Data.Git.Storage.FileReader Data.Git.Storage.FileWriter Data.Git.Storage.CacheFile @@ -86,6 +88,7 @@ , filepath , directory , hit + , hourglass , patience Buildable: True else @@ -101,7 +104,7 @@ , bytestring , test-framework >= 0.3 , test-framework-quickcheck2 >= 0.2 - , time + , hourglass , hit Test-Suite test-repository @@ -114,7 +117,7 @@ , bytestring , test-framework >= 0.3 , test-framework-quickcheck2 >= 0.2 - , time + , hourglass , bytedump >= 1.0 , hit