vervis/src/Vervis/Handler/Git.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Handler.Git
    ( getGitRefDiscoverR
    , postGitUploadRequestR
    )
where

import Prelude

import Control.Monad.IO.Class (liftIO)
import Data.Git.Harder (ObjId (..))
import Data.Git.Harder.Pack
import Data.Git.Repository (getCommit)
import Data.Git.Storage (isRepo, withRepo)
import Data.String (fromString)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Network.Git.Get (parseService)
import Network.Git.Transport.HTTP.Fetch.RefDiscovery
import Network.Git.Transport.HTTP.Fetch.UploadRequest
import Yesod.Core.Handler

import Vervis.BinaryBody (decodeRequestBody)
import Vervis.Content
import Vervis.Foundation (Handler)
import Vervis.Path (askRepoDir)

getGitRefDiscoverR :: Text -> Text -> Handler GitRefDiscovery
getGitRefDiscoverR sharer repo = do
    path <- askRepoDir sharer repo
    let pathG = fromString path
    seemsThere <- liftIO $ isRepo pathG
    if seemsThere
        then do
            rq <- getRequest
            case reqGetParams rq of
                [("service", servT)] ->
                    case parseService $ encodeUtf8 servT of
                        Just serv -> do
                            rd <- liftIO $ withRepo pathG $
                                flip buildRefDiscover' serv
                            setHeader "Cache-Control" "no-cache"
                            return $ GitRefDiscovery rd
                        Nothing -> permissionDenied "Service not supported"
                _ -> notFound
        else notFound

postGitUploadRequestR :: Text -> Text -> Handler GitUploadPackResult
postGitUploadRequestR sharer repo = do
    path <- askRepoDir sharer repo
    let pathG = fromString path
    seemsThere <- liftIO $ isRepo pathG
    if seemsThere
        then do
            ereq <- decodeRequestBody getUploadRequest
            case ereq of
                Left _   -> invalidArgs ["UploadRequest"]
                Right ur -> do
                    -- We need to handle /have/ lines and verify the /want/ed
                    -- refs appear in the ref discovery we sent. But we for now
                    -- ignore these things. Suppose the client didn't send an
                    -- /have/s, what's next? It seems we now need to build and
                    -- send a pack.
                    --
                    -- We just send a full pack with all the ancestors of the
                    -- wants.
                    --
                    -- IDEA: abstract away the HTTP request part by:
                    --
                    -- (1) Read the request body in chunks and use Get to read
                    -- (2) Use a Put to create the response, possibly send in
                    -- chunks, or instead first make LBS and then send?

                    -- TODO currently the code assumes all of these are commits
                    -- but they can also be tags (are there other options?)
                    let oids = urWants ur
                    lbs <- liftIO $ withRepo pathG $ \ git -> do
                        let getC oid = (oid,) <$> getCommit git (unObjId oid)
                        pairs <- traverse getC oids
                        oidset <- collectObjIds git pairs
                        serializePack git oidset
                    return $ GitUploadPackResult lbs
        else notFound