github-post-receive 1.0.2.0 → 1.1.0.0

raw patch · 3 files changed

+398/−65 lines, 3 filesdep +containersdep +wai-loggerdep −conduitdep ~waidep ~warpPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, wai-logger

Dependencies removed: conduit

Dependency ranges changed: wai, warp

API changes (from Hackage documentation)

Files

• github-post-receive.cabal +13/−6
• src/Github/PostReceive/Server.hs +50/−11
• src/Github/PostReceive/Types.hs +335/−48

@@ -1,7 +1,13 @@ name:                github-post-receive-version:             1.0.2.0-synopsis:            Github post-receive server library-description:         This is a library to construct github post-receive servers.+version:             1.1.0.0+synopsis:            GitHub webhooks library+description:         This is a library to construct github webhooks servers.+                     .+                     Currently, this library supports following events:+                     .+                     * push+                     .+                     * status homepage:            https://github.com/amutake/github-post-receive license:             BSD3 license-file:        LICENSE@@ -24,11 +30,12 @@   build-depends:     base ==4.*                    , bytestring >=0.10                    , text >=0.11+                   , containers                    , aeson >=0.6.1                    , email-validate >=1.0-                   , conduit >=1.0                    , http-types >=0.8-                   , wai ==2.*-                   , warp ==2.*+                   , wai ==3.*+                   , warp >=3.0.1 && < 4+                   , wai-logger ==2.*   ghc-options:       -Wall -fno-warn-orphans -fno-warn-unused-do-bind   default-language:  Haskell2010

@@ -1,22 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+ module Github.PostReceive.Server     ( start+    , app     ) where  import Control.Applicative ((<$>))-import Data.Aeson (decode)+import Data.Aeson (eitherDecode) 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 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 -> (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)+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

@@ -1,15 +1,26 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Github.PostReceive.Types     ( Payload (..)+    , PushEvent (..)+    , StatusEvent (..)     , Commit (..)     , Repository (..)     , User (..)+    , SimpleUser (..)+    , Branch (..)+    , SimpleCommit (..)+    , StatusCommit (..)+    , SimpleStatusCommit (..)+    , Tree (..)+    , Or (..)+    , toEither       -- Re-exports     , EmailAddress     ) where -import Control.Applicative ((<$>), (<*>), pure)+import Control.Applicative ((<$>), (<*>), pure, (<|>)) import Data.Aeson (Value (..), FromJSON (..), (.:), (.:?)) import qualified Data.ByteString.Char8 as B import Data.Text (Text)@@ -17,43 +28,88 @@ 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)+data Payload = Push PushEvent+             | Status StatusEvent+             deriving (Show, Eq, Typeable)  instance FromJSON Payload where-    parseJSON (Object o) = Payload+    parseJSON v = Push <$> parseJSON v+              <|> Status <$> parseJSON v++data PushEvent = PushEvent+    { pushEventRef :: Text+    , pushEventBefore :: Text+    , pushEventAfter :: Text+    , pushEventCreated :: Bool+    , pushEventDeleted :: Bool+    , pushEventForced :: Bool+    , pushEventBaseRef :: Maybe Text+    , pushEventCompare :: Url+    , pushEventCommits :: [Commit]+    , pushEventHeadCommit :: Commit+    , pushEventRepository :: Repository+    , pushEventPusher :: SimpleUser+    , pushEventSender :: User+    } deriving (Show, Eq, Typeable)++instance FromJSON PushEvent where+    parseJSON (Object o) = PushEvent         <$> o .: "ref"-        <*> o .: "after"         <*> o .: "before"+        <*> o .: "after"         <*> o .: "created"         <*> o .: "deleted"         <*> o .: "forced"+        <*> o .:? "base_ref"         <*> o .: "compare"         <*> o .: "commits"         <*> o .: "head_commit"         <*> o .: "repository"         <*> o .: "pusher"-    parseJSON _ = fail "Payload must be an object"+        <*> o .: "sender"+    parseJSON _ = fail "PushEvent must be an object" +data StatusEvent = StatusEvent+    { statusEventId :: Int+    , statusEventSHA :: Text+    , statusEventName :: Text+    , statusEventTargetUrl :: Url+    , statusEventContext :: Text+    , statusEventDescription :: Text+    , statusEventState :: Text+    , statusEventCommit :: StatusCommit+    , statusEventBranches :: [Branch]+    , statusEventCreatedAt :: Text -- TODO: Change to date type+    , statusEventUpdatedAt :: Text -- TODO: Change to date type+    , statusEventRepository :: Repository+    , statusEventSender :: User+    } deriving (Show, Eq, Typeable)++instance FromJSON StatusEvent where+    parseJSON (Object o) = StatusEvent+        <$> o .: "id"+        <*> o .: "sha"+        <*> o .: "name"+        <*> o .: "target_url"+        <*> o .: "context"+        <*> o .: "description"+        <*> o .: "state"+        <*> o .: "commit"+        <*> o .: "branches"+        <*> o .: "created_at"+        <*> o .: "updated_at"+        <*> o .: "repository"+        <*> o .: "sender"+    parseJSON _ = fail "StatusEvent must be an object"+ data Commit = Commit     { commitId :: Text     , commitDistinct :: Bool     , commitMessage :: Text     , commitTimestamp :: Text-    , commitUrl :: Text-    , commitAuthor :: User-    , commitCommitter :: User+    , commitUrl :: Url+    , commitAuthor :: SimpleUser+    , commitCommitter :: SimpleUser     , commitAdded :: [FilePath]     , commitRemoved :: [FilePath]     , commitModified :: [FilePath]@@ -76,65 +132,296 @@ data Repository = Repository     { repoId :: Int     , repoName :: Text-    , repoUrl :: Text+    , repoFullName :: Text+    , repoOwner :: Or SimpleUser User+    , repoPrivate :: Bool+    , repoHtmlUrl :: Url     , repoDescription :: Text-    , repoHomepage :: Maybe Text-    , repoWatchers :: Int-    , repoStargazers :: Int-    , repoForks :: Int     , repoFork :: Bool+      -- urls+    , repoUrl :: Text+    , repoForksUrl :: Url+    , repoKeysUrl :: Url+    , repoCollaboratorsUrl :: Url+    , repoTeamsUrl :: Url+    , repoHooksUrl :: Url+    , repoIssueEventsUrl :: Url+    , repoEventsUrl :: Url+    , repoAssigneesUrl :: Url+    , repoBranchesUrl :: Url+    , repoTagsUrl :: Url+    , repoBlobsUrl :: Url+    , repoGitTagsUrl :: Url+    , repoGitRefsUrl :: Url+    , repoTreesUrl :: Url+    , repoStatusesUrl :: Url+    , repoLanguagesUrl :: Url+    , repoStargazersUrl :: Url+    , repoContributorsUrl :: Url+    , repoSubscribersUrl :: Url+    , repoSubscriptionUrl :: Url+    , repoCommitsUrl :: Url+    , repoGitCommitsUrl :: Url+    , repoIssueCommentUrl :: Url+    , repoContentsUrl :: Url+    , repoCompareUrl :: Url+    , repoMergesUrl :: Url+    , repoArchiveUrl :: Url+    , repoDownloadsUrl :: Url+    , repoIssuesUrl :: Url+    , repoPullsUrl :: Url+    , repoMilestonesUrl :: Url+    , repoNotificationsUrl :: Url+    , repoLabelsUrl :: Url+    , repoReleasesUrl :: Url+      -- date+    , repoCreatedAt :: Or Int Text -- Int or DateString+    , repoUpdatedAt :: Text+    , repoPushedAt :: Or Int Text -- Int or DateString+    , repoGitUrl :: Url+    , repoSshUrl :: Url+    , repoCloneUrl :: Url+    , repoSvnUrl :: Url+    , repoHomepage :: Maybe Url     , repoSize :: Int-    , repoOwner :: User-    , repoPrivate :: Bool-    , repoOpenIssues :: Int+    , repoStargazersCount :: Int+    , repoWatchersCount :: Int+    , repoLanguage :: Text     , repoHasIssues :: Bool     , repoHasDownloads :: Bool     , repoHasWiki :: Bool-    , repoLanguage :: Text-    , repoCreatedAt :: Int-    , repoPushedAt :: Int-    , repoMasterBranch :: Text+    , repoHasPages :: Bool+    , repoForksCount :: Int+    , repoMirrorUrl :: Maybe Url+    , repoOpenIssuesCount :: Int+      -- for compatiblity?+    , repoForks :: Int+    , repoOpenIssues :: Int+    , repoWatchers :: Int+    , repoStargazers :: Maybe Int+    , repoMasterBranch :: Maybe Text     } deriving (Show, Eq, Typeable)  instance FromJSON Repository where     parseJSON (Object o) = Repository         <$> o .: "id"         <*> o .: "name"-        <*> o .: "url"+        <*> o .: "full_name"+        <*> o .: "owner"+        <*> o .: "private"+        <*> o .: "html_url"         <*> o .: "description"-        <*> o .:? "homepage"-        <*> o .: "watchers"-        <*> o .: "stargazers"-        <*> o .: "forks"         <*> o .: "fork"+        <*> o .: "url"+        <*> o .: "forks_url"+        <*> o .: "keys_url"+        <*> o .: "collaborators_url"+        <*> o .: "teams_url"+        <*> o .: "hooks_url"+        <*> o .: "issue_events_url"+        <*> o .: "events_url"+        <*> o .: "assignees_url"+        <*> o .: "branches_url"+        <*> o .: "tags_url"+        <*> o .: "blobs_url"+        <*> o .: "git_tags_url"+        <*> o .: "git_refs_url"+        <*> o .: "trees_url"+        <*> o .: "statuses_url"+        <*> o .: "languages_url"+        <*> o .: "stargazers_url"+        <*> o .: "contributors_url"+        <*> o .: "subscribers_url"+        <*> o .: "subscription_url"+        <*> o .: "commits_url"+        <*> o .: "git_commits_url"+        <*> o .: "issue_comment_url"+        <*> o .: "contents_url"+        <*> o .: "compare_url"+        <*> o .: "merges_url"+        <*> o .: "archive_url"+        <*> o .: "downloads_url"+        <*> o .: "issues_url"+        <*> o .: "pulls_url"+        <*> o .: "milestones_url"+        <*> o .: "notifications_url"+        <*> o .: "labels_url"+        <*> o .: "releases_url"+        <*> o .: "created_at"+        <*> o .: "updated_at"+        <*> o .: "pushed_at"+        <*> o .: "git_url"+        <*> o .: "ssh_url"+        <*> o .: "clone_url"+        <*> o .: "svn_url"+        <*> o .:? "homepage"         <*> o .: "size"-        <*> o .: "owner"-        <*> o .: "private"-        <*> o .: "open_issues"+        <*> o .: "stargazers_count"+        <*> o .: "watchers_count"+        <*> o .: "language"         <*> o .: "has_issues"         <*> o .: "has_downloads"         <*> o .: "has_wiki"-        <*> o .: "language"-        <*> o .: "created_at"-        <*> o .: "pushed_at"-        <*> o .: "master_branch"+        <*> o .: "has_pages"+        <*> o .: "forks_count"+        <*> o .:? "mirror_url"+        <*> o .: "open_issues_count"+        <*> o .: "forks"+        <*> o .: "open_issues"+        <*> o .: "watchers"+        <*> o .:? "stargazers"+        <*> o .:? "master_branch"     parseJSON _ = fail "Repository must be an object"  data User = User-    { userName :: Text-    , userEmail :: Maybe EmailAddress-    , userUsername :: Maybe Text+    { userLogin :: Text+    , userId :: Int+    , userAvatarUrl :: Url+    , userGravatarId :: Text+    , userUrl :: Url+    , userHtmlUrl :: Url+    , userFollowersUrl :: Url+    , userFollowingUrl :: Url+    , userGistsUrl :: Url+    , userStarredUrl :: Url+    , userSubscriptionsUrl :: Url+    , userOrganizationsUrl :: Url+    , userReposUrl :: Url+    , userEventsUrl :: Url+    , userReceivedEventsUrl :: Url+    , userType :: Text+    , userSiteAdmin :: Bool     } deriving (Show, Eq, Typeable)  instance FromJSON User where     parseJSON (Object o) = User+        <$> o .: "login"+        <*> o .: "id"+        <*> o .: "avatar_url"+        <*> o .: "gravatar_id"+        <*> o .: "url"+        <*> o .: "html_url"+        <*> o .: "followers_url"+        <*> o .: "following_url"+        <*> o .: "gists_url"+        <*> o .: "starred_url"+        <*> o .: "subscriptions_url"+        <*> o .: "organizations_url"+        <*> o .: "repos_url"+        <*> o .: "events_url"+        <*> o .: "received_events_url"+        <*> o .: "type"+        <*> o .: "site_admin"+    parseJSON _ = fail "User must be an object"++data SimpleUser = SimpleUser+    { simpleUserName :: Text+    , simpleUserEmail :: Maybe EmailAddress+    , simpleUserUsername :: Maybe Text+    , simpleUserDate :: Maybe Text+    } deriving (Show, Eq, Typeable)++instance FromJSON SimpleUser where+    parseJSON (Object o) = SimpleUser         <$> o .: "name"         <*> o .:? "email"         <*> o .:? "username"-    parseJSON _ = fail "User must be an object"+        <*> o .:? "date"+    parseJSON _ = fail "SimpleUser 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"++data Branch = Branch+    { branchName :: Text+    , branchCommit :: SimpleCommit+    } deriving (Show, Eq, Typeable)++instance FromJSON Branch where+    parseJSON (Object o) = Branch+        <$> o .: "name"+        <*> o .: "commit"+    parseJSON _ = fail "Branch must be an object"++data SimpleCommit = SimpleCommit+    { simpleCommitSha :: Text+    , simpleCommitUrl :: Url+    , simpleCommitHtmlUrl :: Maybe Url+    } deriving (Show, Eq, Typeable)++instance FromJSON SimpleCommit where+    parseJSON (Object o) = SimpleCommit+        <$> o .: "sha"+        <*> o .: "url"+        <*> o .:? "html_url"+    parseJSON _ = fail "SimpleCommit must be an object"++-- | used in StatusEvent+data StatusCommit = StatusCommit+    { statusCommitSHA :: Text+    , statusCommitCommit :: SimpleStatusCommit+    , statusCommitUrl :: Url+    , statusCommitHtmlUrl :: Url+    , statusCommitCommentsUrl :: Url+    , statusCommitAuthor :: User+    , statusCommitCommitter :: User+    , statusCommitParents :: [SimpleCommit]+    } deriving (Show, Eq, Typeable)++instance FromJSON StatusCommit where+    parseJSON (Object o) = StatusCommit+        <$> o .: "sha"+        <*> o .: "commit"+        <*> o .: "url"+        <*> o .: "html_url"+        <*> o .: "comments_url"+        <*> o .: "author"+        <*> o .: "committer"+        <*> o .: "parents"+    parseJSON _ = fail "StatusCommit must be an object"++data SimpleStatusCommit = SimpleStatusCommit+    { simpleStatusCommitAuthor :: SimpleUser+    , simpleStatusCommitCommitter :: SimpleUser+    , simpleStatusCommitMessage :: Text+    , simpleStatusCommitTree :: Tree+    , simpleStatusCommitUrl :: Url+    , simpleStatusCommitCommentCount :: Int+    } deriving (Show, Eq, Typeable)++instance FromJSON SimpleStatusCommit where+    parseJSON (Object o) = SimpleStatusCommit+        <$> o .: "author"+        <*> o .: "committer"+        <*> o .: "message"+        <*> o .: "tree"+        <*> o .: "url"+        <*> o .: "comment_count"+    parseJSON _ = fail "SimpleStatusCommit must be an object"++data Tree = Tree+    { treeSHA :: Text+    , treeUrl :: Url+    } deriving (Show, Eq, Typeable)++instance FromJSON Tree where+    parseJSON (Object o) = Tree+        <$> o .: "sha"+        <*> o .: "url"+    parseJSON _ = fail "Tree must be an object"++type Url = Text++-- | Or a b represents a or b+-- The reason why we don't use Either type is that Either Int String type parses { "left": 1 } or { "right": "foo" }, but we want to parse 1 or "foo".+data Or a b = L a | R b deriving (Show, Eq, Typeable)++instance (FromJSON a, FromJSON b) => FromJSON (Or a b) where+    parseJSON v = L <$> parseJSON v <|> R <$> parseJSON v++toEither :: Or a b -> Either a b+toEither (L a) = Left a+toEither (R b) = Right b