module Github.PostReceive.Server
( start
, app
) where
import Control.Applicative ((<$>))
import Data.Aeson (eitherDecode)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Network.HTTP.Types
( ok200, badRequest400, notFound404, internalServerError500
, urlDecode, methodPost, hContentType
)
import Network.Wai
( strictRequestBody, responseLBS, Application
, rawPathInfo, requestMethod, requestHeaders
)
import Network.Wai.Handler.Warp (run, Port)
import Network.Wai.Logger (withStdoutLogger, ApacheLogger)
import Github.PostReceive.Types (Payload)
start :: Port -> M.Map B.ByteString (Payload -> IO ()) -> IO ()
start port routes = do
putStrLn startingMessage
withStdoutLogger $ run port . flip app routes
where
startingMessage = concat
[ "github-post-receive listening on port "
, show port
, " with path "
, show $ M.keys routes
]
app :: ApacheLogger -> M.Map B.ByteString (Payload -> IO ()) -> Application
app aplogger routes req respond
| method == methodPost = flip (maybe notFound) (M.lookup path routes) $ \cont ->
case contentType of
Just "application/json" -> jsonCase cont
Just "application/x-www-form-urlencoded" -> formCase cont
_ -> badRequest
| otherwise = notFound
where
path = rawPathInfo req
method = requestMethod req
contentType = lookup hContentType $ requestHeaders req
res status = aplogger req status Nothing >> respond (responseLBS status [] BL.empty)
notFound = res notFound404
badRequest = res badRequest400
internalError reason = putStrLn reason >> res internalServerError500
ok = res ok200
jsonCase cont = do
bs <- strictRequestBody req
flip (either internalError) (eitherDecode bs) $ \payload -> cont payload >> ok
formCase cont = do
bs <- BL.drop (BL.length "payload=") <$> strictRequestBody req
flip (either internalError) (eitherDecode $ BL.fromStrict $ urlDecode True $ BL.toStrict bs) $ \payload ->
cont payload >> ok