packages feed

wai-git-http (empty) → 0.0.0

raw patch · 5 files changed

+408/−0 lines, 5 filesdep +attoparsecdep +basedep +blaze-builder

Dependencies added: attoparsec, base, blaze-builder, bytestring, case-insensitive, conduit, conduit-extra, containers, directory, filepath, hspec, http-types, network, process, sockaddr, text, wai, wai-conduit, wai-git-http, warp

Files

+ src/Network/Wai/Application/CGI/Git.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.Wai.Application.CGI.Git+    ( cgiGitBackend+    ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as SB8+import qualified Data.Text as T++import Data.Conduit+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL++import Control.Exception (SomeException(..), bracket, catch)+import Control.Monad++import System.Environment (lookupEnv)+import System.FilePath+import System.IO+import System.Process++import Network.HTTP.Types+import Network.SockAddr (showSockAddr)+import Network.Wai+import Network.Wai.Conduit++import Network.Wai.Application.CGI.Git.Conduit+       (parseHeader, toResponseSource)++-- | A git back-end+--+-- The git base dir is the directory for the git repository to serve.  This is+-- `repository` for bare repositories and `repository/.git` for non-bare+-- repositories.+--+-- WARNING: This does not set up any repositories for you, it only serves them+-- you still have to take care of the repositories (and their configuration)+-- behind the scenes.+cgiGitBackend ::+       FilePath -- ^ Git base dir+    -> Application+cgiGitBackend baseDir req respond =+    case parseMethod $ requestMethod req of+        Right GET -> cgiGitBackendApp baseDir False req respond+        Right POST -> cgiGitBackendApp baseDir True req respond+        _ ->+            respond $+            responseLBS+                methodNotAllowed405+                textPlainHeader+                "Method Not Allowed\r\n"++textPlainHeader :: ResponseHeaders+textPlainHeader = [(hContentType, "text/plain")]++cgiGitBackendApp :: FilePath -> Bool -> Application+cgiGitBackendApp baseDir body req respond =+    bracket setup teardown (respond <=< cgi)+  where+    setup = execGitBackendProcess baseDir req+    teardown (rhdl, whdl, pid) = do+        terminateProcess pid -- SIGTERM+        hClose rhdl+        hClose whdl+    cgi (rhdl, whdl, _) = do+        when body $ toCGI whdl req+        hClose whdl -- telling EOF+        fromCGI rhdl++execGitBackendProcess ::+       FilePath -> Request -> IO (Handle, Handle, ProcessHandle)+execGitBackendProcess baseDir req = do+    let naddr = showSockAddr . remoteHost $ req+    epath <- lookupEnv "PATH"+    (Just whdl, Just rhdl, _, pid) <- createProcess $ proSpec naddr epath+    hSetEncoding rhdl latin1+    hSetEncoding whdl latin1+    return (rhdl, whdl, pid)+  where+    proSpec naddr epath =+        CreateProcess+        { cmdspec = RawCommand "/usr/bin/git" ["http-backend"]+        , cwd = Nothing+        , env =+              Just $+              makeEnv+                  baseDir+                  req+                  naddr+                  "git http-backend"+                  (show $ rawPathInfo req)+                  "git http-backend"+                  epath+        , std_in = CreatePipe+        , std_out = CreatePipe+        , std_err = Inherit+        , close_fds = True+        , create_group = True+        , delegate_ctlc = False+        , detach_console = False+        , create_new_console = False+        , new_session = False+        , child_group = Nothing+        , child_user = Nothing+        }++makeEnv ::+       FilePath+    -> Request+    -> String+    -> String+    -> String+    -> ByteString+    -> Maybe String+    -> [(String, String)]+makeEnv baseDir req naddr scriptName pathinfo sname epath =+    addPath epath . addLen . addType . addCookie $ baseEnv+  where+    tp = baseDir </> T.unpack (T.intercalate "/" $ pathInfo req)+    baseEnv =+        [ ("GATEWAY_INTERFACE", gatewayInterface)+        , ("SCRIPT_NAME", scriptName)+        , ("REQUEST_METHOD", SB8.unpack . requestMethod $ req)+        , ("SERVER_NAME", SB8.unpack host)+        , ("SERVER_PORT", SB8.unpack port)+        , ("REMOTE_ADDR", naddr)+        , ("SERVER_PROTOCOL", show . httpVersion $ req)+        , ("SERVER_SOFTWARE", SB8.unpack sname)+        , ("PATH_INFO", pathinfo)+        , ("QUERY_STRING", query req)+        , ("PATH_TRANSLATED", tp)+        , ("GIT_HTTP_EXPORT_ALL", "TRUE")+        ]+    headers = requestHeaders req+    addLen = addLength "CONTENT_LENGTH" $ requestBodyLength req+    addType = addEnv "CONTENT_TYPE" $ lookup hContentType headers+    addCookie = addEnv "HTTP_COOKIE" $ lookup hCookie headers+    addPath Nothing ev = ev+    addPath (Just path) ev = ("PATH", path) : ev+    query = SB8.unpack . safeTail . rawQueryString+      where+        safeTail "" = ""+        safeTail bs = SB8.tail bs+    (host, port) = hostPort req++addEnv :: String -> Maybe ByteString -> [(String, String)] -> [(String, String)]+addEnv _ Nothing envs = envs+addEnv key (Just val) envs = (key, SB8.unpack val) : envs++addLength ::+       String -> RequestBodyLength -> [(String, String)] -> [(String, String)]+addLength _ ChunkedBody envs = envs+addLength key (KnownLength len) envs = (key, show len) : envs++gatewayInterface :: String+gatewayInterface = "CGI/1.1"++toCGI :: Handle -> Request -> IO ()+toCGI whdl req = sourceRequestBody req $$ CB.sinkHandle whdl++fromCGI :: Handle -> IO Response+fromCGI rhdl = do+    (src', hs) <- cgiHeader `catch` recover+    let (st, hdr, hasBody) =+            case check hs of+                Nothing -> (internalServerError500, [], False)+                Just (s, h) -> (s, h, True)+    let src+            | hasBody = src'+            | otherwise = CL.sourceNull+    return $ responseSource st hdr src+  where+    check hs =+        lookup hContentType hs >>+        case lookup hStatus hs of+            Nothing -> Just (ok200, hs)+            Just l -> toStatus l >>= \s -> Just (s, hs')+      where+        hs' = filter (\(k, _) -> k /= hStatus) hs+    toStatus s = SB8.readInt s >>= \x -> Just (Status (fst x) s)+    emptyHeader = []+    recover (_ :: SomeException) = return (CL.sourceNull, emptyHeader)+    cgiHeader = do+        (rsrc, hs) <- CB.sourceHandle rhdl $$+ parseHeader+        src <- toResponseSource rsrc+        return (src, hs)++-- | Look-up key for Status.+hStatus :: HeaderName+hStatus = "status"++hostPort :: Request -> (ByteString, ByteString)+hostPort req =+    case requestHeaderHost req of+        Nothing -> ("Unknown", "80")+        Just hostport ->+            case SB8.break (== ':') hostport of+                (host, "") -> (host, "80")+                (host, port) -> (host, SB8.tail port)
+ src/Network/Wai/Application/CGI/Git/Conduit.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Application.CGI.Git.Conduit+    ( byteStringToBuilder+    , toResponseSource+    , parseHeader+    ) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as BB (fromByteString)+import Control.Applicative+import Data.Attoparsec.ByteString+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI(..), mk)+import Data.Conduit+import Data.Conduit.Attoparsec+import qualified Data.Conduit.List as CL+import Data.Word+import Network.HTTP.Types++----------------------------------------------------------------+byteStringToBuilder :: ByteString -> Builder+byteStringToBuilder = BB.fromByteString++----------------------------------------------------------------+toResponseSource ::+       ResumableSource IO ByteString -> IO (Source IO (Flush Builder))+toResponseSource rsrc = do+    (src, _) <- unwrapResumable rsrc+    return $ src $= CL.map (Chunk . byteStringToBuilder)++----------------------------------------------------------------+parseHeader :: Sink ByteString IO RequestHeaders+parseHeader = sinkParser parseHeader'++parseHeader' :: Parser RequestHeaders+parseHeader' = stop <|> loop+  where+    stop = [] <$ (crlf <|> endOfInput)+    loop = (:) <$> keyVal <*> parseHeader'++type RequestHeader = (CI ByteString, ByteString)++keyVal :: Parser RequestHeader+keyVal = do+    key <- takeTill (wcollon ==)+    _ <- word8 wcollon+    skipWhile (wspace ==)+    val <- takeTill (`elem` [wlf, wcr])+    crlf+    return (mk key, val)++crlf :: Parser ()+crlf = (cr >> (lf <|> return ())) <|> lf++cr :: Parser ()+cr = () <$ word8 wcr++lf :: Parser ()+lf = () <$ word8 wlf++wcollon :: Word8+wcollon = 58++wcr :: Word8+wcr = 13++wlf :: Word8+wlf = 10++wspace :: Word8+wspace = 32
+ test/GitSpec.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}++module GitSpec+    ( spec+    ) where++import Test.Hspec++import Control.Exception++import System.Directory+import System.Exit+import System.Process++import Network.Wai+import Network.Wai.Handler.Warp++import Network.Wai.Application.CGI.Git++spec :: Spec+spec = do+    let dir = "/tmp/git-http-backend-test"+    it "works when you try to clone it" $+        withApp $ \port -> do+            removePathForcibly dir+            createDirectoryIfMissing True dir+            mapM_ (callIn dir) ["git clone http://localhost:" ++ show port]+    it "works when you set a branch upstream" $+        withApp $ \port -> do+            removePathForcibly dir+            createDirectoryIfMissing True dir+            mapM_+                (callIn dir)+                [ "git init"+                , "git remote add testing http://localhost:" ++ show port+                , "touch README.md"+                , "git add README.md"+                , "git commit -m 'initial commit'"+                , "git push --set-upstream testing master"+                ]++withApp :: (Port -> IO ()) -> IO ()+withApp = testWithApplication makeApp++makeApp :: IO Application+makeApp = do+    let dir = "/tmp/git-data"+    removePathForcibly dir+    createDirectoryIfMissing True dir+    callIn dir "git init --bare"+    callIn dir "git config http.receivepack true"+    callIn dir "git config receive.denyCurrentBranch updateInstead"+    pure $ cgiGitBackend dir++callIn :: FilePath -> String -> IO ()+callIn dir cmd = do+    let cp = (shell cmd) {cwd = Just dir}+    (_, _, _, ph) <- createProcess cp+    ec <- waitForProcess ph+    case ec of+        ExitSuccess -> pure ()+        ExitFailure _ -> throwIO ec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ wai-git-http.cabal view
@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 59445b7f93cf70ea21db60b96f29ec6486e7207c2610f70f3c32edceaa8db58b++name:           wai-git-http+version:        0.0.0+synopsis:       Git http-backend CGI App of WAI+description:    Git http-backend CGI App of WAI+category:       Web, Yesod+homepage:       https://github.com/NorfairKing/wai-git-http+author:         Tom Sydney Kerckhove <syd.kerckhove@gmail.com>+maintainer:     Tom Sydney Kerckhove <syd.kerckhove@gmail.com>+license:        BSD3+build-type:     Simple+cabal-version:  >= 1.10++source-repository head+  type: git+  location: git@github.com:NorfairKing/wai-git-http.git++library+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      attoparsec >=0.10.0.0+    , base >=4 && <5+    , blaze-builder+    , bytestring+    , case-insensitive+    , conduit >=1.1+    , conduit-extra+    , containers+    , directory+    , filepath+    , http-types >=0.7+    , network+    , process+    , sockaddr+    , text+    , wai >=3.2 && <3.3+    , wai-conduit+  exposed-modules:+      Network.Wai.Application.CGI.Git+      Network.Wai.Application.CGI.Git.Conduit+  other-modules:+      Paths_wai_git_http+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  hs-source-dirs:+      test+  ghc-options: -threaded -Wall+  build-depends:+      base+    , bytestring+    , conduit >=1.1+    , conduit-extra+    , directory+    , hspec >=1.3+    , process+    , wai >=3.2 && <3.3+    , wai-git-http+    , warp+  other-modules:+      GitSpec+      Paths_wai_git_http+  default-language: Haskell2010