I have no Internet but I think this will POST a new Comment. Github.Repos.Commits.postCommentOn .

mike-burns · mike-burns · commit 2d1652e0eacf · 2011-11-01T00:06:17.000-04:00
diff --git a/Github/Data.hs b/Github/Data.hs
@@ -9,6 +9,7 @@ import qualified Data.Map as Map
 import qualified Data.Text as T
 import Data.Aeson.Types
 import System.Locale (defaultTimeLocale)
+import Data.Attoparsec.Number (Number(..))
 
 import Github.Data.Definitions
 
@@ -96,6 +97,13 @@ instance FromJSON Comment where
             <*> o .: "id"
   parseJSON _          = fail "Could not build a Comment"
 
+instance ToJSON NewComment where
+  toJSON newComment =
+    Object $ Map.fromList
+      [("body", String $ T.pack $ newCommentBody newComment)
+      ,("line_number", Number $ Data.Attoparsec.Number.I $ fromIntegral $ newCommentLineNumber newComment)
+      ,("path", String $ T.pack $ newCommentPath newComment)]
+
 (.:<) :: (FromJSON a) => Object -> T.Text -> Parser [a]
 obj .:< key = case Map.lookup key obj of
                    Nothing -> pure []
diff --git a/Github/Data/Definitions.hs b/Github/Data/Definitions.hs
@@ -77,3 +77,11 @@ data Comment = Comment {
   ,commentUser :: GithubUser
   ,commentId :: Int
 } deriving (Show, Data, Typeable, Eq, Ord)
+
+-- A comment that has not yet been sent to the API.
+data NewComment = NewComment {
+   newCommentBody       :: String
+  ,newCommentLineNumber :: Int
+  ,newCommentPath       :: String
+  ,newCommentPosition   :: Int
+} deriving (Show, Eq, Ord)
diff --git a/Github/Repos/Commits.hs b/Github/Repos/Commits.hs
@@ -3,6 +3,7 @@ module Github.Repos.Commits (
 ,commit
 ,commentsFor
 ,commitCommentsFor
+,postCommentOn
 ,module Github.Data
 ) where
 
@@ -21,3 +22,8 @@ commentsFor user repo = fullGithubGet ["repos", user, repo, "comments"]
 commitCommentsFor :: String -> String -> String -> IO (Either String [Comment])
 commitCommentsFor user repo sha1 =
   fullGithubGet ["repos", user, repo, "commits", sha1, "comments"]
+
+postCommentOn :: String -> String -> String -> NewComment -> IO (Either String Comment)
+postCommentOn user repo sha1 newComment =
+  fullGithubPost ["repos", user, repo, "commits", sha1, "comments"]
+                 newComment
diff --git a/Github/Repos/Commits/Private.hs b/Github/Repos/Commits/Private.hs
@@ -8,6 +8,8 @@ import Control.Applicative
 import Data.List
 import qualified Data.ByteString.Char8 as BS
 import Network.Curl.Download
+import Network.HTTP
+import Network.URI
 
 buildUrl :: [String] -> String
 buildUrl paths = "https://api.github.com/" ++ intercalate "/" paths
@@ -16,8 +18,17 @@ fullGithubGet paths = do
   commitsJsonString <- openURI $ buildUrl paths
   return $ either Left parseJson commitsJsonString
 
-githubApiGet :: String -> IO (Either String BS.ByteString)
-githubApiGet = openURI
+-- fullGithubPost :: (ToJSON a, Show a, FromJSON b, Show b) => [String] -> a -> IO (Either String b)
+fullGithubPost paths body = do
+  let (Just uri) = parseURI $ buildUrl paths
+      request = Request {
+         rqURI = uri
+        ,rqMethod = POST
+        ,rqHeaders = []
+        ,rqBody = show $ toJSON body
+    }
+  result <- simpleHTTP request
+  return $ either (Left . show) (parseJson . BS.pack . rspBody) result
 
 parseJson :: (FromJSON b, Show b) => BS.ByteString -> Either String b
 parseJson jsonString =
diff --git a/github.cabal b/github.cabal
@@ -59,7 +59,9 @@ Library
                  containers,
                  text,
                  old-locale,
-                 download-curl
+                 download-curl,
+                 HTTP,
+                 network
   
   -- Modules not exported by this package.
   -- Other-modules:       
diff --git a/samples/CommentOnCommit.hs b/samples/CommentOnCommit.hs
@@ -0,0 +1,16 @@
+module CommentOnCommit where
+
+import qualified Github.Repos.Commits as Github
+
+main = do
+  let commentPoster = Github.postCommentOn "mike-burns" "github" "746779d28dbbeece2593ba37a30a1b457edf3f6e"
+      comment = Github.NewComment {
+         Github.newCommentBody       = "Good call"
+        ,Github.newCommentLineNumber = 20
+        ,Github.newCommentPath       = "Github/Data.hs"
+        ,Github.newCommentPosition   = 20
+      }
+  didItWork <- commentPoster comment
+  putStrLn $ either (\error   -> "Error: "  ++ (show error))
+                    (\comment -> "Posted: " ++ (show comment))
+                    didItWork
