Commits

Stefan Saasen committed e6af6a2

Create refs based on the ref advertisement we got from the remote

Comments (0)

Files changed (4)

src/Git/PackProtocol.hs

 
 module Git.PackProtocol(
     parsePacket
+  , toRef
   , PacketLine(..)
+  , Ref(..)
 ) where
 
 
 import Data.Attoparsec.Char8 hiding (char, space, take)
 import Data.Maybe
 
+data Ref = Ref {
+    getObjId        :: C.ByteString
+  , getRefName      :: C.ByteString
+} deriving (Show, Eq)
+
 data PacketLine = FirstLine {
     objId           :: C.ByteString
    ,ref             :: C.ByteString
     zeroId          :: C.ByteString
 } deriving (Show, Eq)
 
+toRef :: PacketLine -> Maybe Ref
+toRef (FirstLine oId r _)   = Just (Ref oId r)
+toRef (RefLine oId r)       = Just (Ref oId r)
+toRef _                     = Nothing
+
+
 parsePacket :: L.ByteString -> [PacketLine]
 parsePacket line = fromMaybe [] $ AL.maybeResult $ AL.parse parseLines line
 

src/Git/Remote.hs

 -- .git/objects/pack/tmp_pack_6bo2La
 clone' :: GitRepository -> Remote -> IO ()
 clone' repo remote@Remote{..} = do
-        packFile <- receivePack remote
+        (refs,packFile) <- receivePack remote
         let dir = pathForPack repo
             tmpPack = dir </> "tmp_pack_incoming"
         _ <- createDirectoryIfMissing True dir
         B.writeFile tmpPack packFile
-        _ <- runReaderT (createGitRepositoryFromPackfile tmpPack) repo
+        _ <- runReaderT (createGitRepositoryFromPackfile tmpPack refs) repo
         removeFile tmpPack
         putStrLn "Checking out HEAD"
         _ <- runReaderT checkoutHead repo
         return $ parsePacket $ L.fromChunks [response]
 
 
-receivePack :: Remote -> IO B.ByteString
+receivePack :: Remote -> IO ([Ref], B.ByteString)
 receivePack Remote{..} = withSocketsDo $
     withConnection getHost (show $ fromMaybe 9418 getPort) $ \sock -> do
         let payload = refDiscovery getHost getRepository
         -- FIXME - response might contain more packet lines
         !rawPack <- receiveFully sock
         putStrLn "Received pack file"
-        return $ B.drop 8 rawPack
+        return (mapMaybe toRef pack, B.drop 8 rawPack)

src/Git/Store/ObjectStore.hs

 import qualified Codec.Compression.Zlib as Z
 import qualified Crypto.Hash.SHA1 as SHA1
 -- FIXME -> don't use isJust/fromJust
-import Data.Maybe                                           (isJust, fromJust)
+import Data.Maybe                                           (isJust, fromJust, isNothing)
 import Text.Printf                                          (printf)
 import Git.Pack.Packfile
 import Git.Pack.Delta                                       (patch)
 import Git.Common                                           (GitRepository(..), ObjectId, WithRepository)
+import Git.PackProtocol                                     (Ref(..))
 -- Tree
 import Git.Store.Blob
 import System.FilePath
 import System.Directory
 import Data.Foldable                                        (forM_)
+import Data.List                                            (find)
 import Control.Monad.Reader hiding (forM_)
 
-createGitRepositoryFromPackfile :: FilePath -> WithRepository ()
-createGitRepositoryFromPackfile packFile = do
+createGitRepositoryFromPackfile :: FilePath -> [Ref] -> WithRepository ()
+createGitRepositoryFromPackfile packFile refs = do
     pack <- liftIO $ packRead packFile
     unpackPackfile pack
-    updateHead pack
+    createRefs refs
+    updateHead refs
 
 -- TODO properly handle the error condition here
 unpackPackfile :: Packfile -> WithRepository ()
             writeDelta _repo _ = error "Don't expect a resolved object here"
 
 
-updateHead :: Packfile -> WithRepository ()
-updateHead InvalidPackfile = error "Unexpected invalid packfile"
-updateHead (Packfile _ _ objs) = do
-    let commits = filter isCommit objs
-    unless (null commits) $
-        let commit = head commits
-            ref = "refs/heads/master"
+updateHead :: [Ref] -> WithRepository ()
+updateHead [] = fail "Unexpected invalid packfile"
+updateHead refs = do
+    let maybeHead = findHead refs
+    unless (isNothing maybeHead) $
+        let sha1 = C.unpack $ getObjId $ fromJust maybeHead
+            ref = maybe "refs/heads/master" (C.unpack . getRefName) $ findRef sha1 refs
             in
             do
-                let (sha1, _) = encodeBlob BCommit (objectData commit)
                 createRef ref sha1
                 createSymRef "HEAD" ref
     where isCommit ob = objectType ob == OBJ_COMMIT
+          findHead = find (\Ref{..} -> "HEAD" == getRefName)
+          findRef sha = find (\Ref{..} -> ("HEAD" /= getRefName && sha == (C.unpack getObjId)))
 
 -- ref: refs/heads/master
 createSymRef :: String -> String -> WithRepository ()
         liftIO $ writeFile (getGitDirectory repo </> symName) $ "ref: " ++ ref ++ "\n"
 
 
-createRef :: String -> String -> WithRepository ()
-createRef ref sha = do
-    repo <- ask
-    let (path, name) = splitFileName ref
-        dir          = getGitDirectory repo </> path
-    _ <- liftIO $ createDirectoryIfMissing True dir
-    liftIO $ writeFile (dir </> name) (sha ++ "\n")
 
 pathForPack :: GitRepository -> FilePath
 pathForPack repo = getGitDirectory repo </> "objects" </> "pack"
     where compress data' = Z.compress $ L.fromChunks [data'] -- FIXME should data be lazy in the first place?
 
 
-
-
-
 createEmptyGitRepository :: FilePath -> IO ()
 createEmptyGitRepository gitDir =
         mapM_ (\dir -> createDirectoryIfMissing True (gitDir </> dir)) topLevelDirectories
 getGitDirectory :: GitRepository -> FilePath
 getGitDirectory = (</> ".git") . getName
 
+createRefs :: [Ref] -> WithRepository ()
+createRefs refs = do
+    writeRefs "refs/remotes/origin" $ filterTags refs
+    writeRefs "refs/tags" $ tags refs
+    where simpleRefName  = head . reverse . C.split '/'
+          filterTags     = filter (not . C.isPrefixOf "refs/tags" . getRefName)
+          tags           = filter (\e -> (not . C.isSuffixOf "^{}" $ getRefName e) && (C.isPrefixOf "refs/tags" $ getRefName e))
+          writeRefs refSpace     = mapM_ (\Ref{..} -> createRef (refSpace ++ "/" ++ (C.unpack . simpleRefName $ getRefName)) (C.unpack getObjId)) 
+
+createRef :: String -> String -> WithRepository ()
+createRef ref sha = do
+    repo <- ask
+    let (path, name) = splitFileName ref
+        dir          = getGitDirectory repo </> path
+    _ <- liftIO $ createDirectoryIfMissing True dir
+    liftIO $ writeFile (dir </> name) (sha ++ "\n")

src/Git/Unpack.hs

         putStrLn $ "Creating directory: " ++ show dir
         _ <- createDirectoryIfMissing True dir
         putStrLn $ "Create git repo from pack file: " ++ show packFile
-        _ <- runReaderT (createGitRepositoryFromPackfile packFile) repo
+        _ <- runReaderT (createGitRepositoryFromPackfile packFile []) repo
         putStrLn "Finished"