packages feed

hgithub (empty) → 0.1.0

raw patch · 5 files changed

+270/−0 lines, 5 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, base64-bytestring, bytestring, case-insensitive, cmdargs, directory, hgithub, http-enumerator, text

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright: (c) Vo Minh Thu, 2012.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Network/GitHub.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Module      : Network.GitHub+-- Copyright   : (c) 2012 Vo Minh Thu,+--+-- License     : BSD-style+-- Maintainer  : thu@hypered.be+-- Stability   : experimental+-- Portability : GHC+--+-- This module provides bindings to the GitHub API v3.+module Network.GitHub where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (mzero)+import Data.Aeson+import Data.Attoparsec.Lazy (parse, Result(..))+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as L+import Data.CaseInsensitive+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Enumerator++-- | Construct a request from a `username:password` bytestring (suitable for a+-- Basic Auth scheme), a URI (starting with a `/`, e.g. `/user/repos`), and a+-- list of parameters.+apiGetRequest :: B.ByteString -> String+  -> [(CI B.ByteString, B.ByteString)] -> IO (Request IO)+apiGetRequest usernamePassword uri parameters = do+  let auth = "Basic " `B.append` B64.encode usernamePassword+  request <- parseUrl $ "https://api.github.com" ++ uri+  let request' = request+        { requestHeaders = ("Authorization", auth) : parameters }+  return request'++-- | Construct a request from a `username:password` bytestring (suitable for a+-- Basic Auth scheme), a URI (starting with a `/`, e.g. `/user/repos`), and a+-- body.+apiPostRequest :: B.ByteString -> String -> L.ByteString -> IO (Request IO)+apiPostRequest usernamePassword uri body = do+  let auth = "Basic " `B.append` B64.encode usernamePassword+  request <- parseUrl $ "https://api.github.com" ++ uri+  let request' = request+        { method = "POST"+        , requestHeaders = [("Authorization", auth)]+        , requestBody = RequestBodyLBS body+        }+  return request'++-- | Execute a GET agains the specified URI (e.g. `/user/repos`) using the+-- supplied `username:password` and parameters.+apiGet :: FromJSON a => String -> String+  -> [(CI B.ByteString, B.ByteString)] -> IO (Maybe a)+apiGet usernamePassword uri parameters = do+  request <- apiGetRequest (B.pack usernamePassword) uri parameters+  Response{..} <- withManager $ httpLbs request+  case parse json responseBody of+    Done _ value -> do+--      print value+      case fromJSON value of+        Success value' -> do+          return $ Just value'+        _ -> return Nothing+    _ -> return Nothing++-- | Execute a POST agains the specified URI (e.g. `/user/repos`) using the+-- supplied `username:password` and body.+apiPost :: FromJSON a => String -> String -> L.ByteString -> IO (Maybe a)+apiPost usernamePassword uri body = do+  request <- apiPostRequest (B.pack usernamePassword) uri body+  Response{..} <- withManager $ httpLbs request+  case parse json responseBody of+    Done _ value -> do+      print value+      case fromJSON value of+        Success value' -> do+          return $ Just value'+        _ -> return Nothing+    _ -> return Nothing++-- | Return the list of repositories for a given `username:password` string.+repositoryList :: String -> IO (Maybe [Repository])+repositoryList usernamePassword = apiGet usernamePassword "/user/repos" []++-- | Create a new repository from a given name and description.+repositoryCreate :: String -> String -> Maybe String -> IO (Maybe Repository)+repositoryCreate usernamePassword name description =+  apiPost usernamePassword "/user/repos" $ encode CreateRepository+    { createRepositoryName = T.pack name+    , createRepositoryDescription = T.pack <$> description+    }++-- | Represent a repository. TODO add missing fields.+data Repository = Repository+  { repositoryName :: Text+  , repositoryDescription :: Text+  }+  deriving Show++instance FromJSON Repository where+  parseJSON (Object v) = Repository <$>+    v .: "name" <*>+    v .: "description"+  parseJSON _ = mzero++-- | Data needed to create a new repository.+data CreateRepository = CreateRepository+  { createRepositoryName :: Text+  , createRepositoryDescription :: Maybe Text+  }+  deriving Show++instance ToJSON CreateRepository where+   toJSON CreateRepository{..} = object $+     [ "name" .= createRepositoryName+     ] ++ maybe [] ((:[]) . ("description" .=)) createRepositoryDescription
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ bin/hgithub.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Main where++import Data.Version (showVersion)+import Control.Applicative ((<$>))+import Paths_hgithub (version)+import System.Console.CmdArgs.Implicit+import System.Directory (doesFileExist)+import System.Exit++import Network.GitHub++main :: IO ()+main = (processCmd =<<) $ cmdArgs $+  modes+    [ cmdRepositoryList+    , cmdRepositoryCreate+    ]+  &= summary versionString+  &= program "hgithub"++versionString :: String+versionString =+  "hgithub " ++ showVersion version ++ " Copyright (c) 2012 Vo Minh Thu."++data Cmd =+    CmdRepositoryList+  | CmdRepositoryCreate+  { cmdRepositoryCreateName :: String+  , cmdRepositoryCreateDescription :: Maybe String+  }+  deriving (Data, Typeable)++cmdRepositoryList :: Cmd+cmdRepositoryList = CmdRepositoryList+  &= help "List repositories you have access to."+  &= explicit+  &= name "list-repositories"++cmdRepositoryCreate :: Cmd+cmdRepositoryCreate = CmdRepositoryCreate+  { cmdRepositoryCreateName = def+    &= typ "NAME"+    &= explicit+    &= name "name"+    &= help "Repository name."+  , cmdRepositoryCreateDescription = def+    &= typ "STRING"+    &= explicit+    &= name "description"+    &= help "Repository description."+  } &= help "Create a new repository."+    &= explicit+    &= name "create-repository"++processCmd :: Cmd -> IO ()+processCmd CmdRepositoryList{..} = do+  usernamePassword <- readUsernamePassword "github-username-password.txt"+  mrepos <- repositoryList usernamePassword+  case mrepos of+    Nothing -> putStrLn "Some error occured."+    Just repos -> mapM_ print repos++processCmd CmdRepositoryCreate{..} = do+  usernamePassword <- readUsernamePassword "github-username-password.txt"+  mrepo <- repositoryCreate usernamePassword+    cmdRepositoryCreateName+    cmdRepositoryCreateDescription+  case mrepo of+    Nothing -> putStrLn "Some error occured."+    Just repo -> print repo++readUsernamePassword :: FilePath -> IO String+readUsernamePassword filename = do+  b <- doesFileExist filename+  if b+    then (head . lines) <$> readFile filename+    else do+      putStrLn $ "API key file `" ++ filename ++ "` not found."+      exitWith (ExitFailure 1)
+ hgithub.cabal view
@@ -0,0 +1,38 @@+name:                hgithub+version:             0.1.0+Cabal-Version:       >= 1.8+synopsis:            Haskell bindings to the GitHub API+description:         Haskell bindings to the GitHub API+category:            Network+license:             BSD3+license-file:        LICENSE+author:              Vo Minh Thu+maintainer:          thu@hypered.be+homepage:            https://github.com/noteed/hgithub+bug-reports:         https://github.com/noteed/hgithub/issues+build-type:          Simple++source-repository head+  type: git+  location: https://github.com/noteed/hgithub++library+  build-depends:       base == 4.*,+                       aeson == 0.4.*,+                       attoparsec == 0.10.*,+                       base64-bytestring == 0.1.*,+                       bytestring == 0.9.*,+                       case-insensitive == 0.4.*,+                       http-enumerator == 0.7.*,+                       text == 0.11.*+  exposed-modules:     Network.GitHub+  ghc-options:         -Wall++executable hgithub+  hs-source-dirs:      bin+  main-is:             hgithub.hs+  build-depends:       base == 4.*,+                       cmdargs == 0.9.*,+                       directory == 1.1.*,+                       hgithub+  ghc-options:         -Wall