-- | Endpoints for git api
module Routes.Git
    ( getRefsR
    , postUploadPackR
    , postReceivePackR
    ) where

import ClassyPrelude hiding (Handler)

import qualified Data.Binary.Builder as Builder
import qualified Git
import qualified Log
import qualified Yesod

import Data.Conduit (ConduitT, Flush (Chunk, Flush), await, yield, (.|))
import Database (Unique (..), User, repositoryPrivate, userUsername)
import Database.Persist (entityVal)
import HagiaSite (HagiaSite (..), Handler, repoPath)
import Network.HTTP.Types.Status (badRequest400)
import Path (PathSegment, toText)
import Yesod (entityKey, getYesod, runDB)
import Yesod.Auth.HashDB (validatePass)

-- | First request before pushing or pulling
getRefsR :: PathSegment -> PathSegment -> Handler Yesod.TypedContent
getRefsR userName repoName = do
    user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
    repo <- runDB . Yesod.getBy404 $ UniqueUserRepo (toText repoName) (entityKey user)
    projectRoot <- repoPath userName repoName

    when (repositoryPrivate . entityVal $ repo) $
        authenticateRequest $
            entityVal user

    HagiaSite{git} <- getYesod
    service <-
        Yesod.lookupGetParam "service" >>= \case
            Nothing -> Yesod.sendResponseStatus badRequest400 ("Unspecified service" :: Text)
            Just x -> pure x
    advertise <- case service of
        "git-upload-pack" -> pure $ Git.advertiseRefsUpload git
        "git-receive-pack" -> pure $ Git.advertiseRefsReceive git
        other ->
            Log.warning ("Unexpected service: " <> tshow other)
                >> Yesod.sendResponseStatus badRequest400 ("Bad service" :: Text)
    version <- Yesod.lookupHeader "Git-Protocol"

    Yesod.alreadyExpired
    Yesod.respondSource
        ("application/x-" <> encodeUtf8 service <> "-advertisement")
        (advertise projectRoot version .| flushEvery 4096)

-- | Second request of pulling
postUploadPackR :: PathSegment -> PathSegment -> Handler Yesod.TypedContent
postUploadPackR userName repoName = do
    user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
    repo <- runDB . Yesod.getBy404 $ UniqueUserRepo (toText repoName) (entityKey user)
    projectRoot <- repoPath userName repoName

    when (repositoryPrivate . entityVal $ repo) $
        authenticateRequest $
            entityVal user

    version <- Yesod.lookupHeader "Git-Protocol"

    HagiaSite{git} <- getYesod
    let response = Yesod.rawRequestBody .| Git.uploadPack git projectRoot version
    Yesod.respondSource
        "application/x-git-upload-pack-result"
        (response .| flushEvery 4096)

-- | Second request of pushing
postReceivePackR :: PathSegment -> PathSegment -> Handler Yesod.TypedContent
postReceivePackR userName repoName = do
    user <- runDB . Yesod.getBy404 $ UniqueUsername (toText userName)
    _repo <- runDB . Yesod.getBy404 $ UniqueUserRepo (toText repoName) (entityKey user)
    projectRoot <- repoPath userName repoName

    authenticateRequest $ entityVal user

    version <- Yesod.lookupHeader "Git-Protocol"

    HagiaSite{git} <- getYesod
    let response = Yesod.rawRequestBody .| Git.receivePack git projectRoot version
    Yesod.respondSource
        "application/x-git-upload-pack-result"
        (response .| flushEvery 4096)

-- | Convenience function for streaming with yesod. We don't really care when to flush
flushEvery :: Monad m => Int -> ConduitT ByteString (Flush Builder.Builder) m ()
flushEvery n = go 0
  where
    go !l = do
        when (l >= n) $ yield Flush
        await >>= \case
            Nothing -> pure ()
            Just chunk -> do
                yield . Chunk . Builder.fromByteString $ chunk
                go $! l + length chunk

authenticateRequest :: User -> Handler ()
authenticateRequest user =
    Yesod.lookupBasicAuth >>= \case
        Nothing -> do
            Log.debug "Setting authentication header"
            Yesod.addHeader "WWW-Authenticate" "Basic realm=\"hagia\""
            Yesod.notAuthenticated
        Just (username, password) -> do
            Log.debug "Reading authentication header"
            when
                (username /= userUsername user || maybe False not (validatePass user password))
                Yesod.notAuthenticated