diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.0.3 +------ +* The first version for Hackage's main index. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 Denis Shevchenko + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +[![CircleCI](https://circleci.com/gh/denisshevchenko/circlehs.svg?style=shield&circle-token=6a0ecfd0e019941c9da7ed3070d6cbaa29e3597d)](https://circleci.com/gh/denisshevchenko/circlehs)   [![Code Climate](https://codeclimate.com/github/denisshevchenko/circlehs/badges/gpa.svg)](https://codeclimate.com/github/denisshevchenko/circlehs)   [![Hackage](https://img.shields.io/badge/hackage-v0.0.3-blue.svg)](http://hackage.haskell.org/package/circlehs) + +# CircleHs + +The [CircleCI](https://circleci.com/) REST API implementation in Haskell. For more info please see [official API reference](https://circleci.com/docs/api/). + +Work in progress. + +## Hello, CircleCI! + +Let's obtain information about the user: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} + +import Network.CircleCI + +main :: IO () +main = runCircleCI getUserInfo + (AccountAPIToken "e64c67410f96ba2whatever") + >>= \case + Left problem -> print problem + Right info -> print info +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/circlehs.cabal b/circlehs.cabal new file mode 100644 --- /dev/null +++ b/circlehs.cabal @@ -0,0 +1,68 @@ +name: circlehs +version: 0.0.3 + +synopsis: The CircleCI REST API for Haskell +description: + The CircleCI REST API implementation in Haskell. For more info please see . + . + Built with . + . + /Please note that implementation is incomplete yet./ + +homepage: https://github.com/denisshevchenko/circlehs +bug-reports: https://github.com/denisshevchenko/circlehs/issues + +stability: alpha + +license: MIT +license-file: LICENSE + +author: Denis Shevchenko +maintainer: me@dshevchenko.biz +copyright: 2016 Denis Shevchenko + +category: API, Web +build-type: Simple + +extra-source-files: CHANGELOG.md + , README.md + +cabal-version: >=1.10 + +tested-with: GHC == 7.10.2, GHC == 7.10.3 + +library + hs-source-dirs: src + + exposed-modules: Network.CircleCI + -- API + , Network.CircleCI.User + , Network.CircleCI.Project + , Network.CircleCI.CheckoutKey + , Network.CircleCI.Environment + , Network.CircleCI.Cache + -- Commonly used stuff. + , Network.CircleCI.Common.Types + , Network.CircleCI.Common.Run + + other-modules: Network.CircleCI.Common.HTTPS + , Network.CircleCI.Common.URL + + build-depends: base >= 4.7 && < 5 + , text >= 1.2.2.1 && < 2 + , aeson >= 0.9.0.1 && < 0.12 + , unordered-containers >= 0.2.5.1 && < 0.3 + , servant >= 0.7 && < 0.9 + , servant-client >= 0.7 && < 0.9 + , time >= 1.4.1.1 && < 1.7 + , mtl >= 2.2.1 && < 2.3 + , transformers >= 0.4.2.0 && < 0.6 + , http-client >= 0.4.24 && < 0.5 + , http-client-tls >= 0.2.2 && < 0.5 + + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-unused-binds + +source-repository head + type: git + location: https://github.com/denisshevchenko/circlehs.git diff --git a/src/Network/CircleCI.hs b/src/Network/CircleCI.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI.hs @@ -0,0 +1,39 @@ +{-| +Module : Network.CircleCI +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +Top module for re-exporting everything. +-} + +module Network.CircleCI ( + -- * Work with User info + module Network.CircleCI.User + -- * Work with Projects info + , module Network.CircleCI.Project + -- * Work with GitHub Checkout Keys + , module Network.CircleCI.CheckoutKey + -- * Work with Environment Variables for project build + , module Network.CircleCI.Environment + -- * Work with project's build cache + , module Network.CircleCI.Cache + -- * Commonly used types and functions + , module Network.CircleCI.Common.Run + , module Network.CircleCI.Common.URL + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.HTTPS +) where + +import Network.CircleCI.User +import Network.CircleCI.Project +import Network.CircleCI.CheckoutKey +import Network.CircleCI.Environment +import Network.CircleCI.Cache + +import Network.CircleCI.Common.Run +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS + diff --git a/src/Network/CircleCI/Cache.hs b/src/Network/CircleCI/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Cache.hs @@ -0,0 +1,123 @@ +{-| +Module : Network.CircleCI.Cache +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +API call for work with project build's cache. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +module Network.CircleCI.Cache ( + -- * API call + clearCache + -- * Type for response + , CacheCleared (..) + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.Run +) where + +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS +import Network.CircleCI.Common.Run + +import Control.Monad ( mzero ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.Reader ( ask ) +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Proxy as P +import Data.Text ( Text ) +import Network.HTTP.Client ( Manager ) + +import Servant.API +import Servant.Client + +-- | Clears build cache. Based on https://circleci.com/docs/api/#clear-cache. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (clearCache $ ProjectPoint "denisshevchenko" "circlehs") +-- (AccountAPIToken "e64c674195bbc0dbe3f9676c6ba2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right isCleared -> print isCleared +-- @ +clearCache :: ProjectPoint -- ^ Names of GitHub user/project. + -> CircleCIResponse CacheCleared -- ^ Info about clearing. +clearCache project = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantClearCache (userName project) + (projectName project) + (Just token) + manager + apiBaseUrl + +-- | Cache clearing status. +data CacheCleared = CacheSuccessfullyCleared + | UnableToClearCache ErrorMessage + deriving (Show) + +-- How to make CacheCleared from JSON. +instance FromJSON CacheCleared where + parseJSON (Object o) = + o .: "status" >>= toCacheCleared + parseJSON _ = mzero + +toCacheCleared :: Text -> Parser CacheCleared +toCacheCleared rawStatus = return $ + if | rawStatus `elem` okMessages -> CacheSuccessfullyCleared + | otherwise -> UnableToClearCache rawStatus + where + okMessages = [ "build dependency caches deleted" + , "build caches deleted" + ] + +------------------------------------------------------------------------------- +-- API types for Servant ------------------------------------------------------ +------------------------------------------------------------------------------- + +-- Complete API for work with build cache. +type CacheAPI = ClearCacheCall + +-- Clears build cache. +type ClearCacheCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "build-cache" + :> QueryParam "circle-token" Token + :> Delete '[JSON] CacheCleared + -- DELETE: /project/:username/:project/build-cache?circle-token=:token + +------------------------------------------------------------------------------- +-- API client calls for Servant ----------------------------------------------- +------------------------------------------------------------------------------- + +servantClearCache :: UserName + -> ProjectName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM CacheCleared +servantClearCache = client cacheAPI + +cacheAPI :: P.Proxy CacheAPI +cacheAPI = P.Proxy + diff --git a/src/Network/CircleCI/CheckoutKey.hs b/src/Network/CircleCI/CheckoutKey.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/CheckoutKey.hs @@ -0,0 +1,323 @@ +{-| +Module : Network.CircleCI.CheckoutKey +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +API calls for work with Checkout Keys. CircleCI uses Checkout Keys to check out your GitHub project, submodules, and private dependencies. + +For more info please see "Checkout SSH keys" section in your CircleCI project's Settings. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +module Network.CircleCI.CheckoutKey ( + -- * API calls + getCheckoutKeys + , getCheckoutKey + , createCheckoutKey + , deleteCheckoutKey + -- * Types for calls and responses + , Fingerprint (..) + , CheckoutKeyInfo (..) + , CheckoutKeyType (..) + , CheckoutKeyDeleted (..) + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.Run +) where + +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS +import Network.CircleCI.Common.Run + +import Control.Monad ( mzero ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.Reader ( ask ) +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Proxy as P +import Data.Text ( Text ) +import Data.Time.Clock ( UTCTime ) +import Network.HTTP.Client ( Manager ) + +import Servant.API +import Servant.Client + +-- | Shows list of checkout keys. Based on https://circleci.com/docs/api/#list-checkout-keys. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (getCheckoutKeys $ ProjectPoint "denisshevchenko" "circlehs") +-- (AccountAPIToken "e64c674195bbc0d0be3ef9679b6c6ba2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right keys -> print keys +-- @ +getCheckoutKeys :: ProjectPoint -- ^ Names of GitHub user/project. + -> CircleCIResponse [CheckoutKeyInfo] -- ^ List of checkout keys. +getCheckoutKeys project = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetCheckoutKeys (userName project) + (projectName project) + (Just token) + manager + apiBaseUrl + +-- | Shows single checkout key. Based on https://circleci.com/docs/api/#get-checkout-key. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (getCheckoutKey project fingerprint) apiToken +-- >>= \\case +-- Left problem -> print problem +-- Right key -> print key +-- where +-- project = ProjectPoint "denisshevchenko" "circlehs" +-- fingerprint = Fingerprint "79:23:05:6a:6d:4c:3c:5c:0e:64:79:49:f0:e9:8d:a0" +-- apiToken = AccountAPIToken "e64c674195bbc0d0be3ef9679b6c6ba2whatever" +-- @ +getCheckoutKey :: ProjectPoint -- ^ Names of GitHub user/project. + -> Fingerprint -- ^ Key fingerprint. + -> CircleCIResponse CheckoutKeyInfo -- ^ Checkout key info. +getCheckoutKey project (Fingerprint aFingerprint) = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetCheckoutKey (userName project) + (projectName project) + aFingerprint + (Just token) + manager + apiBaseUrl + +-- | Creates checkout key. Based on https://circleci.com/docs/api/#new-checkout-key. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (createCheckoutKey $ ProjectPoint "denisshevchenko" "circlehs") +-- (AccountAPIToken "e64c674195bbc0d0be3ef9679b6c6ba2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right newKey -> print newKey +-- @ +createCheckoutKey :: ProjectPoint -- ^ Names of GitHub user/project. + -> CircleCIResponse CheckoutKeyInfo -- ^ New checkout key info. +createCheckoutKey project = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantCreateCheckoutKey (userName project) + (projectName project) + (Just token) + manager + apiBaseUrl + +-- | Deletes single checkout key. Based on https://circleci.com/docs/api/#delete-checkout-key. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (deleteCheckoutKey project fingerprint) apiToken +-- >>= \\case +-- Left problem -> print problem +-- Right isDeleted -> print isDeleted +-- where +-- project = ProjectPoint "denisshevchenko" "circlehs" +-- fingerprint = Fingerprint "79:23:05:6a:6d:4c:3c:5c:0e:64:79:49:f0:e9:8d:a0" +-- apiToken = AccountAPIToken "e64c674195bbc0d0be3ef9679b6c6ba2whatever" +-- @ +deleteCheckoutKey :: ProjectPoint -- ^ Names of GitHub user/project. + -> Fingerprint -- ^ Key fingerprint. + -> CircleCIResponse CheckoutKeyDeleted -- ^ Status of checkout key deletion. +deleteCheckoutKey project (Fingerprint aFingerprint) = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantDeleteCheckoutKey (userName project) + (projectName project) + aFingerprint + (Just token) + manager + apiBaseUrl + +-- | Checkout key fingerprint. For example, @"79:23:05:6a:6d:4c:3c:5c:0e:64:79:49:f0:e9:8d:a0"@. +newtype Fingerprint = Fingerprint Text + deriving (Eq, Show) + +-- | Type of checkout key. +data CheckoutKeyType = GitHubDeployKey -- ^ Repo-specific SSH key. + | GitHubUserKey -- ^ User-specific SSH key. + deriving (Eq, Show) + +-- | Info about checkout key. +data CheckoutKeyInfo = CheckoutKeyInfo { + publicKey :: Text -- ^ Public SSH key. + , keyType :: CheckoutKeyType -- ^ Key type. + , fingerprint :: Fingerprint -- ^ Key fingerprint. + , preferred :: Bool -- ^ Preferred key or not. + , issueDate :: UTCTime -- ^ Date when this key was issued. + } deriving (Eq, Show) + +-- How to create CheckoutKeyInfo from JSON. +instance FromJSON CheckoutKeyInfo where + parseJSON (Object o) = CheckoutKeyInfo + <$> o .: "public_key" + <*> (o .: "type" >>= toCheckoutKeyType) + <*> (o .: "fingerprint" >>= toFingerprint) + <*> o .: "preferred" + <*> o .: "time" + parseJSON _ = mzero + +toCheckoutKeyType :: Text -> Parser CheckoutKeyType +toCheckoutKeyType "deploy-key" = return GitHubDeployKey +toCheckoutKeyType "github-user-key" = return GitHubUserKey +toCheckoutKeyType _ = return GitHubDeployKey + +toFingerprint :: Text -> Parser Fingerprint +toFingerprint = return . Fingerprint + +-- | Checkout key deleting status. +data CheckoutKeyDeleted = KeySuccessfullyDeleted + | UnableToDeleteKey ErrorMessage + deriving (Show) + +-- How to create CheckoutKeyDeleted from JSON. +instance FromJSON CheckoutKeyDeleted where + parseJSON (Object o) = + o .: "message" >>= toCheckoutKeyDeleted + parseJSON _ = mzero + +toCheckoutKeyDeleted :: Text -> Parser CheckoutKeyDeleted +toCheckoutKeyDeleted "ok" = return KeySuccessfullyDeleted +toCheckoutKeyDeleted rawMessage = return $ UnableToDeleteKey rawMessage + +------------------------------------------------------------------------------- +-- API types for Servant ------------------------------------------------------ +------------------------------------------------------------------------------- + +-- Complete API for work with checkout keys. +type CheckoutKeyAPI = + GetCheckoutKeysCall + :<|> GetCheckoutKeyCall + :<|> CreateCheckoutKeyCall + :<|> DeleteCheckoutKeyCall + +-- Lists checkout keys. +type GetCheckoutKeysCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "checkout-key" + :> QueryParam "circle-token" Token + :> Get '[JSON] [CheckoutKeyInfo] + -- GET: /project/:username/:project/checkout-key?circle-token=:token + +-- Get a checkout key. +type GetCheckoutKeyCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "checkout-key" + :> Capture "fingerprint" Text + :> QueryParam "circle-token" Token + :> Get '[JSON] CheckoutKeyInfo + -- GET: /project/:username/:project/checkout-key/:fingerprint?circle-token=:token + +-- Create checkout key. +type CreateCheckoutKeyCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "checkout-key" + :> QueryParam "circle-token" Token + :> Post '[JSON] CheckoutKeyInfo + -- POST: /project/:username/:project/checkout-key?circle-token=:token + +-- Delete a checkout key. +type DeleteCheckoutKeyCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "checkout-key" + :> Capture "fingerprint" Text + :> QueryParam "circle-token" Token + :> Delete '[JSON] CheckoutKeyDeleted + -- DELETE: /project/:username/:project/checkout-key/:fingerprint?circle-token=:token + +------------------------------------------------------------------------------- +-- API client calls for Servant ----------------------------------------------- +------------------------------------------------------------------------------- + +servantGetCheckoutKeys :: UserName + -> ProjectName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM [CheckoutKeyInfo] + +servantGetCheckoutKey :: UserName + -> ProjectName + -> Text + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM CheckoutKeyInfo + +servantCreateCheckoutKey :: UserName + -> ProjectName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM CheckoutKeyInfo + +servantDeleteCheckoutKey :: UserName + -> ProjectName + -> Text + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM CheckoutKeyDeleted + +servantGetCheckoutKeys + :<|> servantGetCheckoutKey + :<|> servantCreateCheckoutKey + :<|> servantDeleteCheckoutKey = client checkoutKeyAPI + +checkoutKeyAPI :: P.Proxy CheckoutKeyAPI +checkoutKeyAPI = P.Proxy + diff --git a/src/Network/CircleCI/Common/HTTPS.hs b/src/Network/CircleCI/Common/HTTPS.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Common/HTTPS.hs @@ -0,0 +1,22 @@ +{-| +Module : Network.CircleCI.Common.HTTPS +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +Connection manager for @https@-requests. CircleCI uses TLS. +-} + +module Network.CircleCI.Common.HTTPS ( + httpsManager +) where + +import Control.Monad.IO.Class +import Network.HTTP.Client +import Network.HTTP.Client.TLS + +-- | Connection manager with TLS support. +httpsManager :: MonadIO m => m Manager +httpsManager = liftIO $ newManager tlsManagerSettings + diff --git a/src/Network/CircleCI/Common/Run.hs b/src/Network/CircleCI/Common/Run.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Common/Run.hs @@ -0,0 +1,21 @@ +{-| +Module : Network.CircleCI.Common.Run +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +Run 'CircleCIResponse' monad. +-} + +module Network.CircleCI.Common.Run ( + runCircleCI +) where + +import Control.Monad.Reader + +-- | All API calls require account API token, so move it into 'ReaderT' monad +-- instead of passing it as an explicit argument. +runCircleCI :: ReaderT t IO a -> t -> IO a +runCircleCI = runReaderT + diff --git a/src/Network/CircleCI/Common/Types.hs b/src/Network/CircleCI/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Common/Types.hs @@ -0,0 +1,63 @@ +{-| +Module : Network.CircleCI.Common.Types +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +Common types for work with CircleCI API. +-} + +module Network.CircleCI.Common.Types ( + AccountAPIToken (..) + , Token + , UserName + , ProjectName + , BranchName + , BuildNumber (..) + , Email + , CircleCIResponse + , ProjectPoint (..) + , ErrorMessage +) where + +import Servant.Client +import Data.Text ( Text ) +import Control.Monad.Reader + +-- import CircleCI.Common.Run + +-- | CircleCI account API token. List of account API tokens can be found at https://circleci.com/account/api. +newtype AccountAPIToken = AccountAPIToken Token + +-- | API token as text, for Servant. +type Token = Text + +-- | GitHub user name. +type UserName = Text + +-- | GitHub project name. +type ProjectName = Text + +-- | GitHub branch name. +type BranchName = Text + +-- | Number of project's build on CircleCI. +newtype BuildNumber = BuildNumber Int + deriving (Eq, Show) + +-- | User email address. +type Email = Text + +-- | Monad for response from CircleCI. +type CircleCIResponse a = ReaderT AccountAPIToken IO (Either ServantError a) + +-- | GitHub project identifier, composed from user name and project name. +data ProjectPoint = ProjectPoint + { userName :: UserName -- ^ GitHub user name. + , projectName :: ProjectName -- ^ GitHub project name. + } + +-- | Message about some problem. +type ErrorMessage = Text + diff --git a/src/Network/CircleCI/Common/URL.hs b/src/Network/CircleCI/Common/URL.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Common/URL.hs @@ -0,0 +1,25 @@ +{-| +Module : Network.CircleCI.Common.URL +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +Base URL for all CircleCI API calls. Based on https://circleci.com/docs/api/#calling. +-} + +module Network.CircleCI.Common.URL ( + apiBaseUrl +) where + +import Servant.Common.BaseUrl + +-- | Base URL for all API calls. For API v1 it's @https://circleci.com/api/v1/@. +apiBaseUrl :: BaseUrl +apiBaseUrl = BaseUrl { + baseUrlScheme = Https + , baseUrlHost = "circleci.com" + , baseUrlPort = 443 + , baseUrlPath = "/api/v1" + } + diff --git a/src/Network/CircleCI/Environment.hs b/src/Network/CircleCI/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Environment.hs @@ -0,0 +1,315 @@ +{-| +Module : Network.CircleCI.Environment +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +API calls for work with Environment Variables used in project build. + +For more info please see "Environment variables" section in your CircleCI project's Settings. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +module Network.CircleCI.Environment ( + -- * API calls + getEnvVars + , getEnvVar + , addEnvVar + , deleteEnvVar + -- * Types for calls and responses + , EnvVar (..) + , EnvVarDeleted (..) + , EnvVarName + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.Run +) where + +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS +import Network.CircleCI.Common.Run + +import Control.Monad ( mzero ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.Reader ( ask ) +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson +import Data.Aeson.Types +import qualified Data.Proxy as P +import Data.Text ( Text ) +import Network.HTTP.Client ( Manager ) + +import Servant.API +import Servant.Client + +-- | Name of environment variable. +type EnvVarName = Text + +-- | Shows list of environment variables for the single project. Based on https://circleci.com/docs/api/#list-environment-variables. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (getEnvVars $ ProjectPoint "denisshevchenko" "circlehs") +-- (AccountAPIToken "e64c674195b87d76e988e9fbcba2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right envVars -> print envVars +-- @ +getEnvVars :: ProjectPoint -- ^ Names of GitHub user/project. + -> CircleCIResponse [EnvVar] -- ^ List of environment variables. +getEnvVars project = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetEnvVars (userName project) + (projectName project) + (Just token) + manager + apiBaseUrl + +-- | Shows single environment variable. Based on https://circleci.com/docs/api/#get-environment-variable. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (getEnvVar project \"GCC\") token +-- >>= \\case +-- Left problem -> print problem +-- Right envVar -> print envVar +-- where +-- project = ProjectPoint "denisshevchenko" "circlehs" +-- token = AccountAPIToken "e64c674195b87d76e988e9fbcba2whatever" +-- @ +getEnvVar :: ProjectPoint -- ^ Names of GitHub user/project. + -> EnvVarName -- ^ Environment variable name. + -> CircleCIResponse EnvVar -- ^ Environment variable. +getEnvVar project envVarName = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetEnvVar (userName project) + (projectName project) + envVarName + (Just token) + manager + apiBaseUrl + +-- | Adds environment variable. Based on https://circleci.com/docs/api/#add-environment-variable. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (addEnvVar project envVar) token +-- >>= \\case +-- Left problem -> print problem +-- Right newEnvVar -> print newEnvVar +-- where +-- project = ProjectPoint "denisshevchenko" "circlehs" +-- envVar = EnvVar \"GCC\" "\/usr\/local\/bin\/gcc-4.8" +-- token = AccountAPIToken "e64c674195b87d76e988e9fbcba2whatever" +-- @ +addEnvVar :: ProjectPoint -- ^ Names of GitHub user/project. + -> EnvVar -- ^ Environment variable. + -> CircleCIResponse EnvVar -- ^ Added environment variable. +addEnvVar project envVar = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantAddEnvVar (userName project) + (projectName project) + (Just token) + envVar + manager + apiBaseUrl + +-- | Deletes single environment variable. Based on https://circleci.com/docs/api/#delete-environment-variable. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI (deleteEnvVar project \"GCC\") token +-- >>= \\case +-- Left problem -> print problem +-- Right isDeleted -> print isDeleted +-- where +-- project = ProjectPoint "denisshevchenko" "circlehs" +-- token = AccountAPIToken "e64c674195b87d76e988e9fbcba2whatever" +-- @ +deleteEnvVar :: ProjectPoint -- ^ Names of GitHub user/project. + -> EnvVarName -- ^ Environment variable name. + -> CircleCIResponse EnvVarDeleted -- ^ Info about environment variable deleting. +deleteEnvVar project envVarName = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantDeleteEnvVar (userName project) + (projectName project) + envVarName + (Just token) + manager + apiBaseUrl + +-- | Environment variable, name/value. +data EnvVar = EnvVar { + name :: Text + , value :: Text + } deriving (Eq, Show) + +-- How to make EnvVar from JSON, for POST call. +instance FromJSON EnvVar where + parseJSON (Object o) = EnvVar + <$> o .: "name" + <*> o .: "value" + parseJSON _ = mzero + +-- How to serialize EnvVar to JSON. +instance ToJSON EnvVar where + toJSON (EnvVar aName aValue) = + object [ "name" .= aName + , "value" .= aValue + ] + +-- | Environment variable deleting status. +data EnvVarDeleted = EnvVarSuccessfullyDeleted + | UnableToDeleteEnvVar ErrorMessage + deriving (Show) + +-- How to create EnvVarDeleted from JSON. +instance FromJSON EnvVarDeleted where + parseJSON (Object o) = + o .: "message" >>= toEnvVarDeleted + parseJSON _ = mzero + +toEnvVarDeleted :: Text -> Parser EnvVarDeleted +toEnvVarDeleted rawMessage = return $ + if | rawMessage == "ok" -> EnvVarSuccessfullyDeleted + | otherwise -> UnableToDeleteEnvVar rawMessage + +------------------------------------------------------------------------------- +-- API types for Servant ------------------------------------------------------ +------------------------------------------------------------------------------- + +-- Complete API for work with environment variables. +type EnvVarAPI = + GetEnvVarsCall + :<|> GetEnvVarCall + :<|> AddEnvVarCall + :<|> DeleteEnvVarCall + +-- Lists environment variables for project. +type GetEnvVarsCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "envvar" + :> QueryParam "circle-token" Token + :> Get '[JSON] [EnvVar] + -- GET: /project/:username/:project/envvar?circle-token=:token + +-- Get single environment variable. +type GetEnvVarCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "envvar" + :> Capture "name" EnvVarName + :> QueryParam "circle-token" Token + :> Get '[JSON] EnvVar + -- GET: /project/:username/:project/envvar/:name?circle-token=:token + +-- Add environment variable. +type AddEnvVarCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "envvar" + :> QueryParam "circle-token" Token + :> ReqBody '[JSON] EnvVar + :> Post '[JSON] EnvVar + -- POST: /project/:username/:project/envvar?circle-token=:token + -- --header "Content-Type: application/json" -d '{"name":"foo", "value":"bar"}' + +-- Delete environment variable. +type DeleteEnvVarCall = + "project" + :> Capture "username" UserName + :> Capture "project" ProjectName + :> "envvar" + :> Capture "name" EnvVarName + :> QueryParam "circle-token" Token + :> Delete '[JSON] EnvVarDeleted + -- DELETE: /project/:username/:project/envvar/:name?circle-token=:token + +------------------------------------------------------------------------------- +-- API client calls for Servant ----------------------------------------------- +------------------------------------------------------------------------------- + +servantGetEnvVars :: UserName + -> ProjectName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM [EnvVar] + +servantGetEnvVar :: UserName + -> ProjectName + -> EnvVarName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM EnvVar + +servantAddEnvVar :: UserName + -> ProjectName + -> Maybe Token + -> EnvVar + -> Manager + -> BaseUrl + -> ClientM EnvVar + +servantDeleteEnvVar :: UserName + -> ProjectName + -> EnvVarName + -> Maybe Token + -> Manager + -> BaseUrl + -> ClientM EnvVarDeleted + +servantGetEnvVars + :<|> servantGetEnvVar + :<|> servantAddEnvVar + :<|> servantDeleteEnvVar = client envVarAPI + +envVarAPI :: P.Proxy EnvVarAPI +envVarAPI = P.Proxy + diff --git a/src/Network/CircleCI/Project.hs b/src/Network/CircleCI/Project.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/Project.hs @@ -0,0 +1,233 @@ +{-| +Module : Network.CircleCI.Project +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +API calls for work with info about projects. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +module Network.CircleCI.Project ( + -- * API call + getProjectsInfo + -- * Types for calls and response + , ProjectInfo (..) + , BranchBuildInfo (..) + , BuildInfo (..) + , BuildStatus (..) + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.Run +) where + +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS +import Network.CircleCI.Common.Run + +import Control.Monad ( mzero ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.Reader ( ask ) +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson +import Data.Aeson.Types +import Data.HashMap.Strict +import qualified Data.Proxy as P +import Data.Text ( Text ) +import Data.Time.Clock ( UTCTime ) +import Network.HTTP.Client ( Manager ) + +import Servant.API +import Servant.Client + +-- | Show info about all projects user is following. Based on https://circleci.com/docs/api/#projects. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI getProjectsInfo +-- (AccountAPIToken "e64c674195bbc0d0be3efa2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right info -> print info +-- @ +getProjectsInfo :: CircleCIResponse [ProjectInfo] -- ^ Info about projects. +getProjectsInfo = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetProjectsInfo (Just token) + manager + apiBaseUrl + +-- | Info about single project. +data ProjectInfo = ProjectInfo { + language :: Text -- ^ Programming language using in project. + , repositoryName :: Text -- ^ + , repositoryUrl :: Text -- ^ Repository URL. + , branches :: [BranchBuildInfo] -- ^ Info about recent builds in branches. + , defaultBranch :: Text -- ^ Name of default branch. + , isOpenSource :: Bool -- ^ If 'True' - project is open. + , followed :: Bool -- ^ If 'True' - project is followed by some user. + , gitHubUserName :: Text -- ^ GitHub user name. + -- Slack + , slackChannel :: Maybe Text -- ^ Slack channel name. + , slackWebhookUrl :: Maybe Text -- ^ Slack webhook URL. + , slackNotifyPreferenses :: Maybe Text -- ^ Slack notify preferences. + , slackSubdomain :: Maybe Text -- ^ Slack subdomain. + , slackAPIToken :: Maybe Text -- ^ Slack API token. + -- HipChat + , hipchatNotifyPreferenses :: Maybe Text -- ^ HipChat notify preferences. + , hipchatNotify :: Maybe Text -- ^ HipChat notify. + , hipchatAPIToken :: Maybe Text -- ^ HipChat API token. + , hipchatRoom :: Maybe Text -- ^ HipChat room name. + -- IRC + , ircServer :: Maybe Text -- ^ IRC server. + , ircKeyword :: Maybe Text -- ^ IRC keyword. + , ircChannel :: Maybe Text -- ^ IRC channel name. + , ircUsername :: Maybe Text -- ^ IRC user name. + , ircPassword :: Maybe Text -- ^ IRC password. + , ircNotifyPreferenses :: Maybe Text -- ^ IRC notify preferences. + } deriving (Show) + +-- How to create ProjectInfo from JSON. +instance FromJSON ProjectInfo where + parseJSON (Object o) = ProjectInfo + <$> o .: "language" + <*> o .: "reponame" + <*> o .: "vcs_url" + <*> (o .: "branches" >>= toBranchesBuildInfo) + <*> o .: "default_branch" + <*> o .: "oss" + <*> o .: "followed" + <*> o .: "username" + <*> o .:? "slack_channel" + <*> o .:? "slack_webhook_url" + <*> o .:? "slack_notify_prefs" + <*> o .:? "slack_subdomain" + <*> o .:? "slack_api_token" + <*> o .:? "hipchat_notify_prefs" + <*> o .:? "hipchat_notify" + <*> o .:? "hipchat_api_token" + <*> o .:? "hipchat_room" + <*> o .:? "irc_server" + <*> o .:? "irc_keyword" + <*> o .:? "irc_channel" + <*> o .:? "irc_username" + <*> o .:? "irc_password" + <*> o .:? "irc_notify_prefs" + parseJSON _ = mzero + +toBranchesBuildInfo :: HashMap Text RawBranchBuildInfo -> Parser [BranchBuildInfo] +toBranchesBuildInfo rawBranchesBuildInfo = return + [BranchBuildInfo { branchName = aBranchName + , lastSuccessBuild = rawLastSuccessBuild rawBranchesBuild + , lastFailedBuild = rawLastFailedBuild rawBranchesBuild + , pusherLogins = rawPusherLogins rawBranchesBuild + , recentBuilds = rawRecentBuilds rawBranchesBuild + , runningBuilds = rawRunningBuilds rawBranchesBuild + } + | (aBranchName, rawBranchesBuild) <- toList rawBranchesBuildInfo] + +-- Raw build info for a single branch, for HashMap. +data RawBranchBuildInfo = RawBranchBuildInfo { + rawLastSuccessBuild :: Maybe BuildInfo + , rawLastFailedBuild :: Maybe BuildInfo + , rawPusherLogins :: [Text] + , rawRecentBuilds :: Maybe [BuildInfo] + , rawRunningBuilds :: Maybe [BuildInfo] + } deriving (Eq, Show) + +-- How we create RawBranchBuildInfo from JSON. +instance FromJSON RawBranchBuildInfo where + parseJSON (Object o) = RawBranchBuildInfo + <$> o .:? "last_success" + <*> o .:? "last_non_success" + <*> o .: "pusher_logins" + <*> o .:? "recent_builds" + <*> o .:? "running_builds" + parseJSON _ = mzero + +-- | Build info for a single branch. +data BranchBuildInfo = BranchBuildInfo { + branchName :: Text + , lastSuccessBuild :: Maybe BuildInfo + , lastFailedBuild :: Maybe BuildInfo + , pusherLogins :: [Text] + , recentBuilds :: Maybe [BuildInfo] + , runningBuilds :: Maybe [BuildInfo] + } deriving (Eq, Show) + +-- | Info about single build. +data BuildInfo = BuildInfo { + status :: BuildStatus + , number :: Int + , commit :: Text + , pushDate :: UTCTime + , addingDate :: UTCTime + } deriving (Eq, Show) + +-- How we create BuildInfo from JSON. +instance FromJSON BuildInfo where + parseJSON (Object o) = BuildInfo + <$> (o .: "status" >>= toBuildStatus) + <*> o .: "build_num" + <*> o .: "vcs_revision" + <*> o .: "pushed_at" + <*> o .: "added_at" + parseJSON _ = mzero + +toBuildStatus :: Text -> Parser BuildStatus +toBuildStatus "running" = return BuildRunning +toBuildStatus "success" = return BuildSuccess +toBuildStatus "failed" = return BuildFailed +toBuildStatus "canceled" = return BuildCanceled +toBuildStatus "no_tests" = return NoTests +toBuildStatus _ = return BuildSuccess + +-- | Build status. +data BuildStatus = BuildRunning + | BuildSuccess + | BuildFailed + | BuildCanceled + | NoTests + deriving (Eq, Show) + +------------------------------------------------------------------------------- +-- API types for Servant ------------------------------------------------------ +------------------------------------------------------------------------------- + +-- Complete API for work with projects. +type ProjectsInfoAPI = GetProjectsInfoCall + +-- Obtain info about Projects. +type GetProjectsInfoCall = + "projects" + :> QueryParam "circle-token" Token + :> Get '[JSON] [ProjectInfo] + -- GET: /projects?circle-token=:token + +------------------------------------------------------------------------------- +-- API client calls for Servant ----------------------------------------------- +------------------------------------------------------------------------------- + +servantGetProjectsInfo :: Maybe Token + -> Manager + -> BaseUrl + -> ClientM [ProjectInfo] +servantGetProjectsInfo = client projectsInfoAPI + +projectsInfoAPI :: P.Proxy ProjectsInfoAPI +projectsInfoAPI = P.Proxy + diff --git a/src/Network/CircleCI/User.hs b/src/Network/CircleCI/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/CircleCI/User.hs @@ -0,0 +1,212 @@ +{-| +Module : Network.CircleCI.User +Copyright : (c) Denis Shevchenko, 2016 +License : MIT +Maintainer : me@dshevchenko.biz +Stability : alpha + +API calls for work with User info. +-} + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiWayIf #-} + +module Network.CircleCI.User ( + -- * API call + getUserInfo + -- * Types for calls and response + , UserInfo (..) + , ProjectShortInfo (..) + , EmailNotification (..) + , Plan (..) + , GitHubOAuth (..) + , AnalyticsId + , module Network.CircleCI.Common.Types + , module Network.CircleCI.Common.Run +) where + +import Network.CircleCI.Common.URL +import Network.CircleCI.Common.Types +import Network.CircleCI.Common.HTTPS +import Network.CircleCI.Common.Run + +import Control.Monad ( mzero ) +import Control.Monad.Except ( runExceptT ) +import Control.Monad.Reader ( ask ) +import Control.Monad.IO.Class ( liftIO ) +import Data.Aeson +import Data.Aeson.Types +import Data.HashMap.Strict +import qualified Data.Proxy as P +import Data.Text ( Text ) +import Data.Time.Clock ( UTCTime ) +import Network.HTTP.Client ( Manager ) + +import Servant.API +import Servant.Client + +-- | Show info about user. Based on https://circleci.com/docs/api/#user. +-- +-- Usage example: +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- {-\# LANGUAGE LambdaCase \#-} +-- +-- import Network.CircleCI +-- +-- main :: IO () +-- main = runCircleCI getUserInfo +-- (AccountAPIToken "e64c674195bbc0d0be3efa2whatever") +-- >>= \\case +-- Left problem -> print problem +-- Right info -> print info +-- @ +getUserInfo :: CircleCIResponse UserInfo -- ^ Info about the signed in user. +getUserInfo = do + AccountAPIToken token <- ask + liftIO . runExceptT $ do + manager <- httpsManager + servantGetUserInfo (Just token) + manager + apiBaseUrl + +-- | User's analytics id. For example, @"6fc20e13-008e-4dc9-b158-ababd33a099d"@. +type AnalyticsId = Text + +-- | Info about user. +data UserInfo = UserInfo { + inBetaProgram :: Bool -- ^ Does user in the CircleCI Beta Program? + , fullName :: Text -- ^ User's full name. + , allEmails :: [Text] -- ^ All email addresses in user's account. + , defaultEmail :: Text -- ^ Default email for notifications. + , basicEmailPreference :: EmailNotification -- ^ User email notifications. + , gitHubAvatarUrl :: Text -- ^ GitHub avatar URL. + , gitHubId :: Integer -- ^ GitHub ID. + , gitHubLogin :: Text -- ^ User's GitHub login. + , gitHubOAuthScopes :: [GitHubOAuth] -- ^ GitHub OAuth scopes. + , accountCreatedAt :: UTCTime -- ^ Date when CircleCI-account was created. + , trialEndDate :: UTCTime -- ^ Trial period end date. + , plan :: Plan -- ^ User's plan pricing. + , parallelism :: Int -- ^ Parallelism for tests. + , containtersNumber :: Int -- ^ Number of user's build containers. + , projects :: [ProjectShortInfo] -- ^ User's projects, short info. + , analyticsId :: AnalyticsId -- ^ Analytics ID. + , pusherId :: Text -- ^ Pusher ID. + , herokuAPIKey :: Maybe Text -- ^ Heroku API key. + } deriving (Show) + +-- How to create UserInfo from JSON. +instance FromJSON UserInfo where + parseJSON (Object o) = UserInfo + <$> o .: "in_beta_program" + <*> o .: "name" + <*> o .: "all_emails" + <*> o .: "selected_email" + <*> (o .: "basic_email_prefs" >>= toEmailPreference) + <*> o .: "avatar_url" + <*> o .: "github_id" + <*> o .: "login" + <*> (o .: "github_oauth_scopes" >>= toGitHubOAuth) + <*> o .: "created_at" + <*> o .: "trial_end" + <*> (o .:? "plan" .!= "" >>= toPlan) + <*> o .: "parallelism" + <*> o .: "containers" + <*> (o .: "projects" >>= toProjectsShortInfo) + <*> o .: "analytics_id" + <*> o .: "pusher_id" + <*> o .:? "heroku_api_key" + parseJSON _ = mzero + +-- | Short info about the project. +data ProjectShortInfo = ProjectShortInfo { + gitHubURL :: Text -- ^ Project's GitHUb URL. + , onDashboard :: Bool -- ^ Does this project on CircleCI Dashboard? + , emailNotification :: EmailNotification -- ^ Email notifications for this project. + } deriving (Show) + +toProjectsShortInfo :: HashMap Text RawProject -> Parser [ProjectShortInfo] +toProjectsShortInfo rawProjects = return + [ProjectShortInfo { gitHubURL = githubUrl + , onDashboard = rawOnDashboard rawProject + , emailNotification = rawEmailNotification rawProject + } + | (githubUrl, rawProject) <- toList rawProjects] + +data RawProject = RawProject { + rawOnDashboard :: Bool + , rawEmailNotification :: EmailNotification + } deriving (Show) + +instance FromJSON RawProject where + parseJSON (Object o) = RawProject + <$> o .: "on_dashboard" + <*> (o .: "emails" >>= toEmailPreference) + parseJSON _ = mzero + +-- | CircleCI plan. For more info please see https://circleci.com/pricing/. +data Plan = Hobbyist -- ^ Hobbyist is a free plan for Linux. + | Plan Text -- ^ Commercial plan. + deriving (Show) + +toPlan :: Text -> Parser Plan +toPlan "" = return Hobbyist +toPlan key = return $ Plan key + +-- | Email notification preference. +data EmailNotification = DefaultNotification + | AllBuildsNotification + | BranchesIHavePushedTo + | WithoutNotification + deriving (Show) + +toEmailPreference :: Text -> Parser EmailNotification +toEmailPreference "default" = return DefaultNotification +toEmailPreference "all" = return AllBuildsNotification +toEmailPreference "smart" = return BranchesIHavePushedTo +toEmailPreference "none" = return WithoutNotification +toEmailPreference _ = return DefaultNotification + +-- | GitHub OAuth mode. +data GitHubOAuth = UserEmailOAuth + | RepoOAuth + deriving (Show) + +toGitHubOAuth :: [Text] -> Parser [GitHubOAuth] +toGitHubOAuth raw = return $ Prelude.map convert raw + where + convert :: Text -> GitHubOAuth + convert "user:email" = UserEmailOAuth + convert "repo" = RepoOAuth + convert _ = RepoOAuth + +------------------------------------------------------------------------------- +-- API types for Servant ------------------------------------------------------ +------------------------------------------------------------------------------- + +-- Complete API for work with user info. +type UserAPI = GetUserInfoCall + +-- Clears build cache. +type GetUserInfoCall = + "me" + :> QueryParam "circle-token" Token + :> Get '[JSON] UserInfo + -- GET: /me?circle-token=:token + +------------------------------------------------------------------------------- +-- API client calls for Servant ----------------------------------------------- +------------------------------------------------------------------------------- + +servantGetUserInfo :: Maybe Token + -> Manager + -> BaseUrl + -> ClientM UserInfo +servantGetUserInfo = client userAPI + +userAPI :: P.Proxy UserAPI +userAPI = P.Proxy +