diff --git a/config/routes b/config/routes index 047abaa..fd6d03e 100644 --- a/config/routes +++ b/config/routes @@ -51,7 +51,7 @@ /u/#Text/r/#Text/c RepoCommitsR GET /u/#Text/r/#Text/git/info/refs GitRefDiscoverR GET -/u/#Text/r/#Text/git/git-upload-pack GitUploadRequestR POST +--/u/#Text/r/#Text/git/git-upload-pack GitUploadRequestR POST -- /u/#Text/p/#Text/t TicketsR GET -- /u/#Text/p/#Text/t/#TicketId TicketR GET diff --git a/src/Vervis/Handler/Git.hs b/src/Vervis/Handler/Git.hs index f274ceb..5e153a7 100644 --- a/src/Vervis/Handler/Git.hs +++ b/src/Vervis/Handler/Git.hs @@ -15,7 +15,7 @@ module Vervis.Handler.Git ( getGitRefDiscoverR - , postGitUploadRequestR + --, postGitUploadRequestR ) where @@ -59,6 +59,25 @@ getGitRefDiscoverR sharer repo = do _ -> notFound else notFound +{- This is commented out for now because it doesn't work. The 'collectObjIds' + - function file descriptor exhaustion. I don't know whether and how I can fix + - that. Maybe dive deep into what happens under the hood in 'hit', or make a + - fork of 'hit' which streams things using 'pipes' or 'conduit'. Or perhaps + - check how 'git' and 'libgit2' do these things without resource leaks. I + - don't know, I'm exhausted. + - + - Another option is to traverse objects using gitlib, via conduit. johnw told + - me on IRC he has a version of gitlib based on pipes. Either way I don't know + - if this thing will work on top of hit, because of how hit keeps open file + - descriptors. + - + - I could also try to change collectObjIds to be a function that streams raw + - objects, and keeps a hashmap of IDs to avoid reading an object twice. + - + - Will any of that help? I don't know. + - + - + - postGitUploadRequestR :: Text -> Text -> Handler GitUploadPackResult postGitUploadRequestR sharer repo = do path <- askRepoDir sharer repo @@ -87,11 +106,41 @@ postGitUploadRequestR sharer repo = do -- TODO currently the code assumes all of these are commits -- but they can also be tags (are there other options?) - let oids = urWants ur + let wants = urWants ur lbs <- liftIO $ withRepo pathG $ \ git -> do + -- quick hack: in the case of a clone where the client has + -- no HAVEs, the minimal set is the entire ancestor tree of + -- the wants. So let's just collect all the ancestors. let getC oid = (oid,) <$> getCommit git (unObjId oid) - pairs <- traverse getC oids - oidset <- collectObjIds git pairs + wantsP <- traverse getC wants + let collect _ oid l = do + mo <- getObject git (unObjId oid) False + case mo of + Just (ObjCommit c) -> return ((oid,c):l, Just c) + _ -> error "non-commit parent" + pairs <- loadCommitsMulti git collect wantsP $ map (fmap Just) wantsP + oidset <- catch (collectObjIds git pairs) $ \ e -> do + print (e :: SomeException) + throwIO e + + --for_ oidset $ \ oid -> do + -- obj <- getObject_ git (unObjId oid) True + -- putStrLn $ take 120 $ show obj + + --let isCommit r = do + -- obj <- getObject_ git r False + -- case obj of + -- ObjCommit _ -> return True + -- _ -> return False + -- allCommits c = do + -- bools <- traverse isCommit $ commitParents c + -- return $ and bools + --bools <- for pairs $ \ (_oid, c) -> allCommits c + --let nNotC = length $ filter not bools + --putStrLn $ "Total commits: " ++ show (length pairs) + --putStrLn $ "Commits with non-commit parents: " ++ show nNotC + serializePack git oidset - return $ GitUploadPackResult lbs + return $ GitUploadPackResult $ "0008NAK\n" <> lbs else notFound +-}