Remove upload-pack over HTTP, 'hit' opens too many file descriptors

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

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
+-}