packages feed

hit 0.5.5 → 0.6.0

raw patch · 13 files changed

+243/−93 lines, 13 filesdep +hourglassdep +unixdep −timedep ~base

Dependencies added: hourglass, unix

Dependencies removed: time

Dependency ranges changed: base

Files

Data/Git.hs view
@@ -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)
+ Data/Git/Config.hs view
@@ -0,0 +1,58 @@+-- |+-- Module      : Data.Git.Config+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- 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)
Data/Git/Named.hs view
@@ -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
Data/Git/Path.hs view
@@ -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" </> ""
Data/Git/Repository.hs view
@@ -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)
Data/Git/Storage.hs view
@@ -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 ()
Data/Git/Storage/CacheFile.hs view
@@ -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
Data/Git/Storage/Object.hs view
@@ -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
Data/Git/Types.hs view
@@ -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
Hit/Hit.hs view
@@ -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"
Tests/Repo.hs view
@@ -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
Tests/Tests.hs view
@@ -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 ]
hit.cabal view
@@ -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