Add create status endpoint

Author: jamesdabbs

github.cabal

@@ -86,6 +86,7 @@ Library
     GitHub.Data.Request
     GitHub.Data.Reviews
     GitHub.Data.Search
+    GitHub.Data.Statuses
     GitHub.Data.Teams
     GitHub.Data.URL
     GitHub.Data.Webhooks
@@ -118,6 +119,7 @@ Library
     GitHub.Endpoints.Repos.DeployKeys
     GitHub.Endpoints.Repos.Forks
     GitHub.Endpoints.Repos.Releases
+    GitHub.Endpoints.Repos.Statuses
     GitHub.Endpoints.Repos.Webhooks
     GitHub.Endpoints.Search
     GitHub.Endpoints.Users

spec/GitHub/CommitsSpec.hs

@@ -6,13 +6,12 @@ import qualified GitHub
 
 import GitHub.Auth                    (Auth (..))
 import GitHub.Endpoints.Repos.Commits (Commit, commitSha, commitsFor',
-                                       commitsForR, diffR, mkName)
+                                       commitsForR, diffR, mkCommitName)
 import GitHub.Request                 (executeRequest)
 
 import Control.Monad      (forM_)
 import Data.Either.Compat (isRight)
 import Data.List          (nub, sort)
-import Data.Proxy         (Proxy (..))
 import Data.String        (fromString)
 import System.Environment (lookupEnv)
 import Test.Hspec         (Spec, describe, it, pendingWith, shouldBe,
@@ -59,6 +58,5 @@ spec = do
         d `shouldSatisfy` isRight
 
     it "issue #155" $ withAuth $ \auth -> do
-      let mkCommitName = mkName (Proxy :: Proxy Commit)
       d <- executeRequest auth $ diffR "nomeata" "codespeed" (mkCommitName "ghc") (mkCommitName "tobami:master")
       d `shouldSatisfy` isRight

src/GitHub/Data.hs

@@ -16,6 +16,7 @@ module GitHub.Data (
     mkTeamName,
     mkOrganizationName,
     mkRepoName,
+    mkCommitName,
     fromUserName,
     fromOrganizationName,
     -- ** Id
@@ -48,6 +49,7 @@ module GitHub.Data (
     module GitHub.Data.Request,
     module GitHub.Data.Reviews,
     module GitHub.Data.Search,
+    module GitHub.Data.Statuses,
     module GitHub.Data.Teams,
     module GitHub.Data.URL,
     module GitHub.Data.Webhooks
@@ -76,6 +78,7 @@ import GitHub.Data.Repos
 import GitHub.Data.Request
 import GitHub.Data.Reviews
 import GitHub.Data.Search
+import GitHub.Data.Statuses
 import GitHub.Data.Teams
 import GitHub.Data.URL
 import GitHub.Data.Webhooks
@@ -110,6 +113,9 @@ mkRepoId = Id
 mkRepoName :: Text -> Name Repo
 mkRepoName = N
 
+mkCommitName :: Text -> Name Commit
+mkCommitName = N
+
 fromOrganizationName :: Name Organization -> Name Owner
 fromOrganizationName = N . untagName
 

src/GitHub/Data/Statuses.hs

@@ -0,0 +1,81 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE NoImplicitPrelude  #-}
+{-# LANGUAGE OverloadedStrings  #-}
+module GitHub.Data.Statuses where
+
+import GitHub.Data.Definitions
+import GitHub.Data.Id          (Id)
+import GitHub.Data.URL         (URL)
+import GitHub.Internal.Prelude
+import Prelude ()
+
+data StatusState
+    = StatusPending
+    | StatusSuccess
+    | StatusError
+    | StatusFailure
+  deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic)
+
+instance NFData StatusState where rnf = genericRnf
+instance Binary StatusState
+
+instance FromJSON StatusState where
+  parseJSON (String "pending") = pure StatusPending
+  parseJSON (String "success") = pure StatusSuccess
+  parseJSON (String "error")   = pure StatusError
+  parseJSON (String "failure") = pure StatusFailure
+  parseJSON _ = fail "Could not build a StatusState"
+
+instance ToJSON StatusState where
+  toJSON StatusPending = String "pending"
+  toJSON StatusSuccess = String "success"
+  toJSON StatusError   = String "error"
+  toJSON StatusFailure = String "failure"
+
+data Status = Status
+    { statusCreatedAt   :: !UTCTime
+    , statusUpdatedAt   :: !UTCTime
+    , statusState       :: !StatusState
+    , statusTargetUrl   :: !(Maybe URL)
+    , statusDescription :: !(Maybe Text)
+    , statusId          :: !(Id Status)
+    , statusUrl         :: !URL
+    , statusContext     :: !(Maybe Text)
+    , statusCreator     :: !SimpleUser
+    }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance FromJSON Status where
+  parseJSON = withObject "Status" $ \o -> Status
+      <$> o .: "created_at"
+      <*> o .: "updated_at"
+      <*> o .: "state"
+      <*> o .:? "target_url"
+      <*> o .:? "description"
+      <*> o .: "id"
+      <*> o .: "url"
+      <*> o .:? "context"
+      <*> o .: "creator"
+
+data NewStatus = NewStatus
+    { newStatusState       :: !StatusState
+    , newStatusTargetUrl   :: !(Maybe URL)
+    , newStatusDescription :: !(Maybe Text)
+    , newStatusContext     :: !(Maybe Text)
+    }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData NewStatus where rnf = genericRnf
+instance Binary NewStatus
+
+instance ToJSON NewStatus where
+    toJSON (NewStatus s t d c) = object $ filter notNull $
+        [ "state"       .= s
+        , "target_url"  .= t
+        , "description" .= d
+        , "context"     .= c
+        ]
+      where
+        notNull (_, Null) = False
+        notNull (_, _)    = True

src/GitHub/Endpoints/Repos/Statuses.hs

@@ -0,0 +1,23 @@
+--
+-- The repo statuses API as described on
+-- <https://developer.github.com/v3/repos/statuses/>.
+module GitHub.Endpoints.Repos.Statuses (
+    createStatus,
+    createStatusR,
+    module GitHub.Data
+    ) where
+
+import GitHub.Data
+import GitHub.Internal.Prelude
+import GitHub.Request
+import Prelude ()
+
+createStatus :: Auth -> Name Owner -> Name Repo -> Name Commit -> NewStatus -> IO (Either Error Status)
+createStatus auth owner repo sha ns =
+  executeRequest auth $ createStatusR owner repo sha ns
+
+createStatusR :: Name Owner -> Name Repo -> Name Commit -> NewStatus -> Request 'RW Status
+createStatusR owner repo sha =
+  command Post parts . encode
+  where
+    parts = ["repos", toPathPart owner, toPathPart repo, "statuses", toPathPart sha]