github-types 0.1.0.5 → 0.2.0

raw patch · 5 files changed

+452/−64 lines, 5 filesdep +aeson-prettydep +hspecdep +hspec-smallcheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-pretty, hspec, hspec-smallcheck, http-conduit, smallcheck, time, unordered-containers, vector

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• github-types.cabal +37/−8
• src/GitHub/Types/Base.hs +50/−0
• src/GitHub/Types/Events.hs +304/−14
• src/GitHub/Types/Repository.hs +0/−42
• test/Test.hs +61/−0

@@ -1,5 +1,5 @@ name:                github-types-version:             0.1.0.5+version:             0.2.0 license:             OtherLicense license-file:        LICENSE author:              Tomas Carnecky@@ -13,15 +13,44 @@                      which are consumed or produced by the GitHub v3 API.  +source-repository head+    type:     git+    location: git://github.com/wereHamster/github-types.git++ library     default-language:    Haskell2010     hs-source-dirs:      src -    build-depends:       aeson-    build-depends:       base >= 4 && < 5-    build-depends:       text+    build-depends:+       base >= 4 && < 5+     , aeson+     , text+     , time -    exposed-modules:     GitHub.Types-    exposed-modules:     GitHub.Types.Base-    exposed-modules:     GitHub.Types.Repository-    exposed-modules:     GitHub.Types.Events+    exposed-modules:+       GitHub.Types+     , GitHub.Types.Base+     , GitHub.Types.Repository+     , GitHub.Types.Events+++test-suite spec+    default-language:    Haskell2010+    hs-source-dirs:      test src++    main-is:             Test.hs+    type:                exitcode-stdio-1.0++    build-depends:+       base < 4.9+     , hspec+     , aeson+     , aeson-pretty+     , smallcheck+     , hspec-smallcheck+     , vector+     , text+     , unordered-containers+     , time+     , http-conduit

@@ -72,3 +72,53 @@     toJSON Success = String "success"     toJSON Failure = String "failure"     toJSON Error   = String "error"++++------------------------------------------------------------------------------+-- Deployment++data Deployment = Deployment+    { deploymentId          :: Int+    , deploymentSha         :: Text+    , deploymentRef         :: Text+    , deploymentTask        :: Text+    , deploymentEnvironment :: Text+    , deploymentPayload     :: Value+    , deploymentDescription :: Text+    } deriving (Eq, Show)++instance FromJSON Deployment where+    parseJSON (Object x) = Deployment+        <$> x .: "id"+        <*> x .: "sha"+        <*> x .: "ref"+        <*> x .: "task"+        <*> x .: "environment"+        <*> x .: "payload"+        <*> x .: "description"++    parseJSON _ = mzero++++------------------------------------------------------------------------------+-- DeploymentStatus++data DeploymentStatus = DeploymentStatus+    { deploymentStatusId             :: Int+    , deploymentStatusState          :: Text+    , deploymentStatusTargetUrl      :: Maybe Text+    , deploymentStatusDescription    :: Maybe Text+    , deploymentStatusDeploymentUrl  :: Maybe Text+    } deriving (Eq, Show)++instance FromJSON DeploymentStatus where+    parseJSON (Object x) = DeploymentStatus+        <$> x .: "id"+        <*> x .: "state"+        <*> x .: "target_url"+        <*> x .: "description"+        <*> x .: "deployment_url"++    parseJSON _ = mzero

@@ -9,7 +9,9 @@ import Data.Aeson import Data.Aeson.Types import Data.Monoid-import Data.Text+import Data.Text hiding (find)+import Data.Time+import Data.List  import GitHub.Types.Base import GitHub.Types.Repository@@ -18,36 +20,155 @@  -- | All events which can be produced by GitHub. ----- See https://developer.github.com/v3/activity/events/types/-data Event-    = CommitCommentEventType    CommitCommentEvent-    | DeploymentEventType       DeploymentEvent-    | DeploymentStatusEventType DeploymentStatusEvent+-- See https://developer.github.com/v3/activity/events/+data Event = Event+    { eventId :: !Text+    , eventActor :: !Actor+    , eventRepo :: !Repo+    , eventCreatedAt :: !UTCTime+    , eventPublic :: !Bool+    , eventPayload :: !Payload+    } deriving (Eq, Show)++instance FromJSON Event where+    parseJSON (Object o) = do+        eventType <- o .: "type"++        Event+            <$> o .: "id"+            <*> o .: "actor"+            <*> o .: "repo"+            <*> o .: "created_at"+            <*> o .: "public"+            <*> (eventPayloadParser eventType =<< o .: "payload")++    parseJSON _ = fail "Event"+++data Actor = Actor+    { actorId :: !Integer+    , actorLogin :: !Text+    } deriving (Eq, Show)++instance FromJSON Actor where+    parseJSON (Object o) = Actor+        <$> o .: "id"+        <*> o .: "login"++    parseJSON _ = fail "Actor"+++data Repo = Repo+    { repoId :: !Integer+    , repoName :: !Text+    } deriving (Eq, Show)++instance FromJSON Repo where+    parseJSON (Object o) = Repo+        <$> o .: "id"+        <*> o .: "name"++    parseJSON _ = fail "Repo"+++data Payload+    = CommitCommentEventPayload            CommitCommentEvent+    | DeploymentEventPayload               DeploymentEvent+    | DeploymentStatusEventPayload         DeploymentStatusEvent+    | PushEventPayload                     PushEvent+    | IssuesEventPayload                   IssuesEvent+    | IssueCommentEventPayload             IssueCommentEvent+    | CreateEventPayload                   CreateEvent+    | PullRequestEventPayload              PullRequestEvent+    | PullRequestReviewCommentEventPayload PullRequestReviewCommentEvent+    | WatchEventPayload                    WatchEvent+    | DeleteEventPayload                   DeleteEvent+    | ForkEventPayload                     ForkEvent+    | ReleaseEventPayload                  ReleaseEvent+    | GollumEventPayload                   GollumEvent+    | MemberEventPayload                   MemberEvent+    | PublicEventPayload                   Value     deriving (Eq, Show)  +eventPayloadParsers :: [(Text, Text, Value -> Parser Payload)]+eventPayloadParsers =+    [ ( "CommitCommentEvent", "commit_comment"+      , fmap CommitCommentEventPayload . parseJSON)++    , ( "DeploymentEvent", "deployment"+      , fmap DeploymentEventPayload . parseJSON)++    , ( "DeploymentStatusEvent", "deployment_status"+      , fmap DeploymentStatusEventPayload . parseJSON)++    , ( "PushEvent", "push"+      , fmap PushEventPayload . parseJSON)++    , ( "IssuesEvent", "issues"+      , fmap IssuesEventPayload . parseJSON)++    , ( "IssueCommentEvent", "issue_comment"+      , fmap IssueCommentEventPayload . parseJSON)++    , ( "CreateEvent", "create"+      , fmap CreateEventPayload . parseJSON)++    , ( "PullRequestEvent", "pull_request"+      , fmap PullRequestEventPayload . parseJSON)++    , ( "PullRequestReviewCommentEvent", "pull_request_review_comment"+      , fmap PullRequestReviewCommentEventPayload . parseJSON)++    , ( "WatchEvent", "watch"+      , fmap WatchEventPayload . parseJSON)++    , ( "DeleteEvent", "delete"+      , fmap DeleteEventPayload . parseJSON)++    , ( "ForkEvent", "fork"+      , fmap ForkEventPayload . parseJSON)++    , ( "ReleaseEvent", "release"+      , fmap ReleaseEventPayload . parseJSON)++    , ( "GollumEvent", "gollum"+      , fmap GollumEventPayload . parseJSON)++    , ( "MemberEvent", "member"+      , fmap MemberEventPayload . parseJSON)++    , ( "PublicEvent", "public"+      , fmap PublicEventPayload . parseJSON)+    ]++++eventPayloadParser :: Text -> Value -> Parser Payload+eventPayloadParser eventType x = case find (\(t, _, _) -> t == eventType) eventPayloadParsers of+    Nothing -> fail $ "eventPayloadParser: Unknown event type: " <> unpack eventType+    Just (_, _, p) -> p x+ -- | Since the event type is included through different means (X-GitHub-Event -- header, or inline in the JSON object), it's not possible to make 'Event' -- an instance of 'FromJSON'. But if you know the type, you can use this -- parser.-eventParser :: Text -> Value -> Parser Event-eventParser "commit_comment"    x = CommitCommentEventType    <$> parseJSON x-eventParser "deployment"        x = DeploymentEventType       <$> parseJSON x-eventParser "deployment_status" x = DeploymentStatusEventType <$> parseJSON x-eventParser eventType           _ = fail $ "Unknown event type: " <> unpack eventType-+webhookPayloadParser :: Text -> Value -> Parser Payload+webhookPayloadParser eventType x =  case find (\(_, t, _) -> t == eventType) eventPayloadParsers of+    Nothing -> fail $ "webhookPayloadParser: Unknown event type: " <> unpack eventType+    Just (_, _, p) -> p x   ------------------------------------------------------------------------------ -- CommitCommentEvent  data CommitCommentEvent = CommitCommentEvent-    { commitCommentEventRepository :: Repository+    { commitCommentEventComment :: Value     } deriving (Eq, Show)  instance FromJSON CommitCommentEvent where     parseJSON (Object x) = CommitCommentEvent-        <$> x .: "repository"+        <$> x .: "comment"      parseJSON _ = fail "CommitCommentEvent" @@ -89,3 +210,172 @@         <*> x .: "repository"      parseJSON _ = fail "DeploymentStatusEvent"+++------------------------------------------------------------------------------+-- PushEvent++data PushEvent = PushEvent+    { pushEventSize :: !Int+    } deriving (Eq, Show)++instance FromJSON PushEvent where+    parseJSON (Object x) = PushEvent+        <$> x .: "size"++    parseJSON _ = fail "PushEvent"+++------------------------------------------------------------------------------+-- IssuesEvent++data IssuesEvent = IssuesEvent+    { issuesEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON IssuesEvent where+    parseJSON (Object x) = IssuesEvent+        <$> x .: "action"++    parseJSON _ = fail "IssuesEvent"+++------------------------------------------------------------------------------+-- IssuesEvent++data IssueCommentEvent = IssueCommentEvent+    { issueCommentEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON IssueCommentEvent where+    parseJSON (Object x) = IssueCommentEvent+        <$> x .: "action"++    parseJSON _ = fail "IssueCommentEvent"+++------------------------------------------------------------------------------+-- IssuesEvent++data CreateEvent = CreateEvent+    { createEventRef :: !(Maybe Text)+    } deriving (Eq, Show)++instance FromJSON CreateEvent where+    parseJSON (Object x) = CreateEvent+        <$> x .: "ref"++    parseJSON _ = fail "CreateEvent"+++------------------------------------------------------------------------------+-- PullRequestEvent++data PullRequestEvent = PullRequestEvent+    { pullRequestEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON PullRequestEvent where+    parseJSON (Object x) = PullRequestEvent+        <$> x .: "action"++    parseJSON _ = fail "PullRequestEvent"+++------------------------------------------------------------------------------+-- PullRequestEvent++data PullRequestReviewCommentEvent = PullRequestReviewCommentEvent+    { pullRequestReviewCommentEventPullRequest :: !Value+    } deriving (Eq, Show)++instance FromJSON PullRequestReviewCommentEvent where+    parseJSON (Object x) = PullRequestReviewCommentEvent+        <$> x .: "pull_request"++    parseJSON _ = fail "PullRequestReviewCommentEvent"++++------------------------------------------------------------------------------+-- WatchEvent++data WatchEvent = WatchEvent+    { watchEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON WatchEvent where+    parseJSON (Object x) = WatchEvent+        <$> x .: "action"++    parseJSON _ = fail "WatchEvent"+++------------------------------------------------------------------------------+-- DeleteEvent++data DeleteEvent = DeleteEvent+    { deleteEventRef :: !Text+    } deriving (Eq, Show)++instance FromJSON DeleteEvent where+    parseJSON (Object x) = DeleteEvent+        <$> x .: "ref"++    parseJSON _ = fail "DeleteEvent"+++------------------------------------------------------------------------------+-- ForkEvent++data ForkEvent = ForkEvent+    { forkEventForkee :: !Value+    } deriving (Eq, Show)++instance FromJSON ForkEvent where+    parseJSON (Object x) = ForkEvent+        <$> x .: "forkee"++    parseJSON _ = fail "ForkEvent"+++------------------------------------------------------------------------------+-- ReleaseEvent++data ReleaseEvent = ReleaseEvent+    { releaseEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON ReleaseEvent where+    parseJSON (Object x) = ReleaseEvent+        <$> x .: "action"++    parseJSON _ = fail "ForkEvent"+++------------------------------------------------------------------------------+-- GollumEvent++data GollumEvent = GollumEvent+    { gollumEventPages :: !Value+    } deriving (Eq, Show)++instance FromJSON GollumEvent where+    parseJSON (Object x) = GollumEvent+        <$> x .: "pages"++    parseJSON _ = fail "GollumEvent"+++------------------------------------------------------------------------------+-- MemberEvent++data MemberEvent = MemberEvent+    { memberEventAction :: !Text+    } deriving (Eq, Show)++instance FromJSON MemberEvent where+    parseJSON (Object x) = MemberEvent+        <$> x .: "action"++    parseJSON _ = fail "MemberEvent"

@@ -27,45 +27,3 @@         , "target_url"  .= cdsTargetUrl         , "description" .= cdsDescription         ]---data Deployment = Deployment-    { deploymentId          :: Int-    , deploymentSha         :: Text-    , deploymentRef         :: Text-    , deploymentTask        :: Text-    , deploymentEnvironment :: Text-    , deploymentPayload     :: Value-    , deploymentDescription :: Text-    } deriving (Eq, Show)--instance FromJSON Deployment where-    parseJSON (Object x) = Deployment-        <$> x .: "id"-        <*> x .: "sha"-        <*> x .: "ref"-        <*> x .: "task"-        <*> x .: "environment"-        <*> x .: "payload"-        <*> x .: "description"--    parseJSON _ = mzero---data DeploymentStatus = DeploymentStatus-    { deploymentStatusId             :: Int-    , deploymentStatusState          :: Text-    , deploymentStatusTargetUrl      :: Maybe Text-    , deploymentStatusDescription    :: Maybe Text-    , deploymentStatusDeploymentUrl  :: Maybe Text-    } deriving (Eq, Show)--instance FromJSON DeploymentStatus where-    parseJSON (Object x) = DeploymentStatus-        <$> x .: "id"-        <*> x .: "state"-        <*> x .: "target_url"-        <*> x .: "description"-        <*> x .: "deployment_url"--    parseJSON _ = mzero

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE ScopedTypeVariables   #-}++module Main where++import           Control.Applicative+import           Control.Monad++import           Test.Hspec+import           Test.SmallCheck+import           Test.SmallCheck.Series+import           Test.Hspec.SmallCheck++import           Data.Monoid         ((<>))+import           Data.Function+import           Data.List+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMS+import           Data.Text           (Text)+import qualified Data.Text           as T+import           Data.Vector         (Vector)+import qualified Data.Vector         as V+import           Data.Time+import           Data.Time.Clock.POSIX+import           Data.Aeson+import           Data.Aeson.Types+import           Data.Aeson.Encode.Pretty++import           Network.HTTP.Conduit++import           GitHub.Types.Events++++main :: IO ()+main = do+    httpManager <- newManager tlsManagerSettings+    hspec $ spec httpManager+++spec :: Manager -> Spec+spec httpManager = do++    describe "GitHub.Types.Event" $ do+        it "should parse all events from the public timeline" $ flip shouldReturn True $ do+          req <- parseUrl $ "https://api.github.com/events"+          body <- httpLbs (req { requestHeaders = ("User-Agent", "githb-types-haskell-test") : requestHeaders req }) httpManager++          case eitherDecode (responseBody body) :: Either String [Value] of+              Left e -> fail $ "Failed to parse response as list of JSON values: " <> e+              Right x -> do+                  forM_ x $ \v -> do+                      case fromJSON v :: Result Event of+                          Error s -> fail $ "Failed to parse event " <> s <> ", payload: " <> show (encodePretty v)+                          _ -> return ()++                  return True