src/Network/CircleCI/CheckoutKey.hs
{-|
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