github-post-receive 0.1.0.0 → 1.0.0.0
raw patch · 4 files changed
+184/−41 lines, 4 filesdep +conduitdep +email-validatedep +textdep −processdep −scottydep −transformersdep ~aesondep ~bytestringdep ~http-types
Dependencies added: conduit, email-validate, text, wai, warp
Dependencies removed: process, scotty, transformers
Dependency ranges changed: aeson, bytestring, http-types
Files
- github-post-receive.cabal +22/−17
- src/Github/PostReceive/Server.hs +22/−0
- src/Github/PostReceive/Types.hs +140/−0
- src/main.hs +0/−24
github-post-receive.cabal view
@@ -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 <amkkun@gmail.com>+maintainer: Shohei Yasutake <amutake.s@gmail.com> 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
+ src/Github/PostReceive/Server.hs view
@@ -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)
+ src/Github/PostReceive/Types.hs view
@@ -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"
− src/main.hs
@@ -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