diff --git a/github-post-receive.cabal b/github-post-receive.cabal --- a/github-post-receive.cabal +++ b/github-post-receive.cabal @@ -1,28 +1,33 @@ name: github-post-receive -version: 0.1.0.0 -synopsis: github web hooks server -description: This is a server of github web hooks. -homepage: http://github.com/amkkun/github-post-receive +version: 1.0.0.0 +synopsis: Github post-receive server library +description: This is a library to construct a github post-receive server. +homepage: https://github.com/amutake/github-post-receive license: BSD3 license-file: LICENSE author: Shohei Yasutake -maintainer: Shohei Yasutake +maintainer: Shohei Yasutake copyright: Copyright (C) 2013 Shohei Yasutake category: Web build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 source-repository head - type: git - location: git://github.com/amkkun/github-post-receive.git + type: git + location: git://github.com/amutake/github-post-receive.git -executable github-post-receive +library + exposed-modules: Github.PostReceive.Types + , Github.PostReceive.Server hs-source-dirs: src - main-is: main.hs - build-depends: base == 4.* - , aeson >= 0.6.1 - , bytestring >= 0.10 - , http-types >= 0.6 - , process >= 1.0 - , scotty >= 0.3 - , transformers >= 0.2 + build-depends: base ==4.* + , bytestring ==0.10.* + , text ==0.11.* + , aeson >=0.6 + , email-validate >=1.0 + , conduit >=1.0 + , http-types >=0.8 + , wai >=2.0 + , warp >=2.0 + ghc-options: -Wall -fno-warn-orphans -fno-warn-unused-do-bind + default-language: Haskell2010 diff --git a/src/Github/PostReceive/Server.hs b/src/Github/PostReceive/Server.hs new file mode 100644 --- /dev/null +++ b/src/Github/PostReceive/Server.hs @@ -0,0 +1,22 @@ +module Github.PostReceive.Server + ( start + ) where + +import Control.Applicative ((<$>)) +import Data.Aeson (decode) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Conduit (($$)) +import qualified Data.Conduit.List as CL +import Network.HTTP.Types (ok200, badRequest400, urlDecode) +import Network.Wai (requestBody, responseLBS) +import Network.Wai.Handler.Warp (run, Port) + +import Github.PostReceive.Types (Payload) + +start :: Port -> (Payload -> IO ()) -> IO () +start port cont = run port $ \req -> do + bs <- B.drop (length "payload=") . B.concat <$> (requestBody req $$ CL.consume) + case decode $ BL.fromStrict $ urlDecode True bs of + Nothing -> return (responseLBS badRequest400 [] BL.empty) + Just payload -> cont payload >> return (responseLBS ok200 [] BL.empty) diff --git a/src/Github/PostReceive/Types.hs b/src/Github/PostReceive/Types.hs new file mode 100644 --- /dev/null +++ b/src/Github/PostReceive/Types.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} + +module Github.PostReceive.Types + ( Payload (..) + , Commit (..) + , Repository (..) + , User (..) + -- Re-exports + , EmailAddress + ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Data.Aeson (Value (..), FromJSON (..), (.:), (.:?)) +import qualified Data.ByteString.Char8 as B +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable (Typeable) +import Text.Email.Validate (EmailAddress, emailAddress) + +data Payload = Payload + { payloadRef :: Text + , payloadAfter :: Text + , payloadBefore :: Text + , payloadCreated :: Bool + , payloadDeleted :: Bool + , payloadForced :: Bool + , payloadCompare :: Text + , payloadCommits :: [Commit] + , payloadHeadCommit :: Commit + , payloadRepository :: Repository + , payloadPusher :: User + } deriving (Show, Eq, Typeable) + +instance FromJSON Payload where + parseJSON (Object o) = Payload + <$> o .: "ref" + <*> o .: "after" + <*> o .: "before" + <*> o .: "created" + <*> o .: "deleted" + <*> o .: "forced" + <*> o .: "compare" + <*> o .: "commits" + <*> o .: "head_commit" + <*> o .: "repository" + <*> o .: "pusher" + parseJSON _ = fail "Payload must be an object" + +data Commit = Commit + { commitId :: Text + , commitDistinct :: Bool + , commitMessage :: Text + , commitTimestamp :: Text + , commitUrl :: Text + , commitAuthor :: User + , commitCommitter :: User + , commitAdded :: [FilePath] + , commitRemoved :: [FilePath] + , commitModified :: [FilePath] + } deriving (Show, Eq, Typeable) + +instance FromJSON Commit where + parseJSON (Object o) = Commit + <$> o .: "id" + <*> o .: "distinct" + <*> o .: "message" + <*> o .: "timestamp" + <*> o .: "url" + <*> o .: "author" + <*> o .: "committer" + <*> o .: "added" + <*> o .: "removed" + <*> o .: "modified" + parseJSON _ = fail "Commit must be an object" + +data Repository = Repository + { repoId :: Int + , repoName :: Text + , repoUrl :: Text + , repoDescription :: Text + , repoHomepage :: Maybe Text + , repoWatchers :: Int + , repoStargazers :: Int + , repoForks :: Int + , repoFork :: Bool + , repoSize :: Int + , repoOwner :: User + , repoPrivate :: Bool + , repoOpenIssues :: Int + , repoHasIssues :: Bool + , repoHasDownloads :: Bool + , repoHasWiki :: Bool + , repoLanguage :: Text + , repoCreatedAt :: Int + , repoPushedAt :: Int + , repoMasterBranch :: Text + } deriving (Show, Eq, Typeable) + +instance FromJSON Repository where + parseJSON (Object o) = Repository + <$> o .: "id" + <*> o .: "name" + <*> o .: "url" + <*> o .: "description" + <*> o .:? "homepage" + <*> o .: "watchers" + <*> o .: "stargazers" + <*> o .: "forks" + <*> o .: "fork" + <*> o .: "size" + <*> o .: "owner" + <*> o .: "private" + <*> o .: "open_issues" + <*> o .: "has_issues" + <*> o .: "has_downloads" + <*> o .: "has_wiki" + <*> o .: "language" + <*> o .: "created_at" + <*> o .: "pushed_at" + <*> o .: "master_branch" + parseJSON _ = fail "Repository must be an object" + +data User = User + { userName :: Text + , userEmail :: Maybe EmailAddress + , userUsername :: Maybe Text + } deriving (Show, Eq, Typeable) + +instance FromJSON User where + parseJSON (Object o) = User + <$> o .: "name" + <*> o .:? "email" + <*> o .:? "username" + parseJSON _ = fail "User must be an object" + +instance FromJSON EmailAddress where + parseJSON (String t) = case emailAddress $ B.pack . T.unpack $ t of + Just a -> pure a + Nothing -> fail "failed to parse EmailAddress" + parseJSON _ = fail "EmailAddress must be a text" diff --git a/src/main.hs b/src/main.hs deleted file mode 100644 --- a/src/main.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Main where - -import System.Environment -import System.Exit -import Web.Scotty - -import Config -import Receiver - -type Port = Int - -main :: IO () -main = do - args <- getArgs - (port, path) <- checkArgs args - str <- readFile path - let result = parseConfig str - case result of - Left err -> print err - Right configs -> scotty port $ receiver configs - -checkArgs :: [String] -> IO (Port, FilePath) -checkArgs [port, path] = return (read port, path) -checkArgs _ = putStrLn "post-receive port conf" >> exitFailure