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/octohat.cabal b/octohat.cabal new file mode 100644 --- /dev/null +++ b/octohat.cabal @@ -0,0 +1,63 @@ +Name: octohat +Version: 0.1 +Synopsis: A tested, minimal wrapper around GitHub's API. Very incomplete at the moment +License: MIT +Author: Stack Builders +Maintainer: hackage@stackbuilders.com +Stability: Experimental +Category: Network +Build-type: Simple +Cabal-version: >=1.10 + +Library + hs-source-dirs: src + + Build-depends: + aeson == 0.8.* + , base >= 4.5 && < 4.8 + , base-compat == 0.5.* + , base16-bytestring == 0.1.1.* + , base64-bytestring == 1.0.* + , bytestring >= 0.9 + , containers >= 0.4 + , cryptohash == 0.11.* + , dotenv == 0.1.* + , either == 4.3.* + , errors == 1.4.* + , http-client == 0.4.* + , http-types == 0.8.* + , lens >= 4.0 && <= 4.7 + , mtl == 2.* + , text == 1.2.* + , time == 1.4.* + , transformers == 0.3.* + , unordered-containers == 0.2.* + , wreq == 0.3.* + , xmlhtml == 0.2.* + + ghc-options: -Wall + exposed-modules: Network.Octohat.Types + , Network.Octohat.Members + , Network.Octohat.Keys + , Network.Octohat + + other-modules: Network.Octohat.Internal + + default-language: Haskell2010 + +test-suite spec + ghc-options : -Wall + type : exitcode-stdio-1.0 + hs-source-dirs : spec + main-is : Spec.hs + build-depends : base >= 4.5 && <4.8 + , base-compat == 0.5.* + , hspec == 2.1.* + , hspec-expectations == 0.6.* + , text == 1.2.* + , dotenv == 0.1.* + , transformers == 0.3.* + , octohat + other-modules: Network.Octohat.TestData, + Network.Octohat.TestUtil + default-language: Haskell2010 diff --git a/spec/Network/Octohat/TestData.hs b/spec/Network/Octohat/TestData.hs new file mode 100644 --- /dev/null +++ b/spec/Network/Octohat/TestData.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Octohat.TestData ( loadTestOrganizationName + , loadOwnerTeam + , loadTestAccountOne + , loadTestAccountTwo + , loadTestAccountThree + , publicKeyFixture + , publicKeyHostnameFixture + , fingerprintFixture + , fullPublicKeyFixture + ) where + +import Network.Octohat.Types +import Network.Octohat (teamForTeamNameInOrg) +import Network.Octohat.Members (userForUsername) + +import Control.Monad.IO.Class (liftIO) +import Control.Arrow (second) +import System.Environment.Compat (getEnvironment) +import Configuration.Dotenv (loadFile) +import Control.Applicative ((<$>), (<*>)) +import qualified Data.Text as T + +data TestEnvironment = + TestEnvironment { + organization :: T.Text, + accountOne :: T.Text, + accountTwo :: T.Text, + accountThree :: T.Text + } + +readEnv :: [(String, String)] -> Maybe TestEnvironment +readEnv environment = + TestEnvironment <$> lookup "SANDBOX_ORGANIZATION" env + <*> lookup "TEST_ACCOUNT_ONE" env + <*> lookup "TEST_ACCOUNT_TWO" env + <*> lookup "TEST_ACCOUNT_THREE" env + where env = map (second T.pack) environment + +loadEnv :: IO TestEnvironment +loadEnv = do + loadFile False ".github-sandbox" + env <- getEnvironment + case readEnv env of + Just res -> return res + Nothing -> fail "Environment variables not set correctly, please read README.md" + +loadTestOrganizationName :: IO T.Text +loadTestOrganizationName = organization `fmap` loadEnv + +loadOwnerTeam :: GitHub Team +loadOwnerTeam = liftIO (organization `fmap` loadEnv) >>= teamForTeamNameInOrg "Owners" + +loadTestAccountOne :: GitHub Member +loadTestAccountOne = liftIO (accountOne `fmap` loadEnv) >>= userForUsername + +loadTestAccountTwo :: GitHub Member +loadTestAccountTwo = liftIO (accountTwo `fmap` loadEnv) >>= userForUsername + +loadTestAccountThree :: GitHub Member +loadTestAccountThree = liftIO (accountThree `fmap` loadEnv) >>= userForUsername + +publicKeyHostnameFixture :: T.Text +publicKeyHostnameFixture = "octohat@stackbuilders" + +fingerprintFixture :: T.Text +fingerprintFixture = "42:59:20:02:6f:df:b4:4a:1c:0e:fd:1b:86:58:f6:06" + +publicKeyFixture :: T.Text +publicKeyFixture = "AAAAB3NzaC1yc2EAAAADAQABAAABAQC1Dopc3yxLWlzJwFqSoj0nAzRCU93R5DwNlogtRr/7NsnUVf443wl/vpRDRNscR0dV/VeNWYCqiZA0wGrXiVJ7HYi9XaWtHrUutLqrLe47aFFvAIdp15+RHkM0sXr963Kb9XMkmqswyXJ2TaZ0cgZfMNgl1ND248Y8fMDBx8elHwdZvyG2onG5aSVtOuKB4dWnmIb+uSQCN1K2kLYwHvQOjmqCiZ2XOP9u+ScphVdp6x4uAczH67CCRSUhI6U2fxSNf6YaDXyCWcqxj1agHUKdskb5rzxPaz5XZ2BgQscjoVo93M338HLmkyvbuP4yl2X6ZdLfE5mk2ZFfWQogxLGd" + +fullPublicKeyFixture :: T.Text +fullPublicKeyFixture = T.concat ["ssh-rsa ", publicKeyFixture, " ", publicKeyHostnameFixture] diff --git a/spec/Network/Octohat/TestUtil.hs b/spec/Network/Octohat/TestUtil.hs new file mode 100644 --- /dev/null +++ b/spec/Network/Octohat/TestUtil.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Octohat.TestUtil (findUserId, setupToken, removeTeams) where + + +import Network.Octohat.Members +import Network.Octohat.Types +import Network.Octohat.TestData + +import Control.Monad.IO.Class (liftIO) +import Configuration.Dotenv (loadFile) +import qualified Data.Text as T + +findUserId :: T.Text -> GitHub Integer +findUserId username = memberId `fmap` userForUsername username + +deleteAllTeams :: GitHub [DidDelete] +deleteAllTeams = do + testOrganization <- liftIO loadTestOrganizationName + allTeams <- teamsForOrganization testOrganization + let teamsToDelete = map teamId $ filter (\t -> teamName t /= "Owners") allTeams + mapM deleteTeamFromOrganization teamsToDelete + +setupToken :: IO () +setupToken = do + loadFile False ".github-sandbox" + result <- runGitHub deleteAllTeams + case result of + Left _ -> fail "Clean-up failed" + Right _ -> return () + +removeTeams :: () -> IO () +removeTeams _ = do + result <- runGitHub deleteAllTeams + case result of + Left _ -> fail "Clean-up failed" + Right _ -> return () diff --git a/spec/Spec.hs b/spec/Spec.hs new file mode 100644 --- /dev/null +++ b/spec/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/src/Network/Octohat.hs b/src/Network/Octohat.hs new file mode 100644 --- /dev/null +++ b/src/Network/Octohat.hs @@ -0,0 +1,62 @@ +-- | Convenience functions for some common operations with teams. Execute the result of these +-- functions using 'runGitHub' or 'runGitHub'' + +module Network.Octohat ( addUserToTeam + , membersOfTeamInOrganization + , keysOfTeamInOrganization + , teamForTeamNameInOrg) where + +import Control.Error.Safe (tryHead) +import Control.Monad (liftM) +import qualified Data.Text as T + +import Network.Octohat.Keys +import Network.Octohat.Members +import Network.Octohat.Types + + +-- | Gets all the members of the organization +membersOfTeamInOrganization :: T.Text -- ^ GitHub organization name + -> T.Text -- ^ GitHub team name + -> GitHub [Member] +membersOfTeamInOrganization nameOfOrg nameOfTeam = teamId `liftM` teamForTeamNameInOrg nameOfOrg nameOfTeam >>= membersForTeam + +-- | Adds a user with @nameOfUser@ to the team named @nameOfTeam@ within the organization named `nameOfOrg` +addUserToTeam :: T.Text -- ^ GitHub username + -> T.Text -- ^ GitHub organization name + -> T.Text -- ^ GitHub team name + -> GitHub StatusInTeam +addUserToTeam nameOfUser nameOfOrg nameOfTeam = teamId `liftM` teamForTeamNameInOrg nameOfOrg nameOfTeam >>= addMemberToTeam nameOfUser + +-- | Retrieves a list of members in a given team within an organization together with their public keys +keysOfTeamInOrganization :: T.Text -- ^ GitHub organization name + -> T.Text -- ^ GitHub team name + -> GitHub [MemberWithKey] +keysOfTeamInOrganization nameOfOrg nameOfTeam = do + members <- membersOfTeamInOrganization nameOfOrg nameOfTeam + pubKeys <- mapM keysForMember members + let memberFingerprints = publicKeySetToFingerprints pubKeys + return $ makeMembersWithKey members pubKeys memberFingerprints + +teamForTeamNameInOrg :: T.Text -- ^ Team name + -> T.Text -- ^ Organization name + -> GitHub Team +teamForTeamNameInOrg nameOfTeam nameOfOrg = do + teams <- teamsForOrganization nameOfOrg + tryHead NotFound (teamsWithName nameOfTeam teams) + +teamsWithName :: T.Text -> [Team] -> [Team] +teamsWithName nameOfTeam = filter (hasName nameOfTeam) + +hasName :: T.Text -> Team -> Bool +hasName name team = name == teamName team +keysForMember :: Member -> GitHub [PublicKey] +keysForMember = publicKeysForUser . memberLogin + +makeMembersWithKey :: [Member] -> [[PublicKey]] -> [[PublicKeyFingerprint]] -> [MemberWithKey] +makeMembersWithKey = zipWith3 MemberWithKey + +publicKeySetToFingerprints :: [[PublicKey]] -> [[PublicKeyFingerprint]] +publicKeySetToFingerprints = (map.map) fingerprintFor + + diff --git a/src/Network/Octohat/Internal.hs b/src/Network/Octohat/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Octohat/Internal.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Network.Octohat.Internal + ( putRequestTo + , getRequestTo + , postRequestTo + , deleteRequestTo + , composeEndpoint) where + +import Control.Error.Safe +import Control.Lens (set, view) +import Control.Monad.Reader +import Data.Aeson +import Data.List +import Data.Text.Encoding (encodeUtf8) +import Network.Wreq +import qualified Network.Wreq.Types as WT +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T + +import Network.Octohat.Types + +composeEndpoint :: [T.Text] -> T.Text +composeEndpoint pathChunks = T.concat $ intersperse "/" ("https://api.github.com" : pathChunks) + +getResponseEntity :: FromJSON a => Response BSL.ByteString -> Either GitHubReturnStatus a +getResponseEntity resp = + case eitherDecode (view responseBody resp) of + Left errorMessage -> Left (UnexpectedJSON errorMessage) + Right decoded -> Right decoded + +requestOptions :: GitHub Options +requestOptions = do + bearerToken <- ask + let opts = set auth (Just $ oauth2Bearer (encodeUtf8 $ unBearerToken bearerToken)) defaults + let opts' = set checkStatus (Just (\_ _ _ -> Nothing)) opts + let opts'' = set (header "User-Agent") ["octohat v0.1"] opts' + return opts'' + + +postRequestTo :: (ToJSON b, WT.Postable b, FromJSON a) => T.Text -> b -> GitHub a +postRequestTo uri body = do + opts <- requestOptions + response <- liftIO $ postWith opts (T.unpack uri) (toJSON body) + checkForStatus response + tryRight $ getResponseEntity response + +getRequestTo :: FromJSON a => T.Text -> GitHub a +getRequestTo uri = do + opts <- requestOptions + response <- liftIO $ getWith opts (T.unpack uri) + checkForStatus response + tryRight $ getResponseEntity response + +putRequestTo :: FromJSON a => T.Text -> GitHub a +putRequestTo uri = do + opts <- requestOptions + response <- liftIO $ putWith opts (T.unpack uri) EmptyBody + checkForStatus response + tryRight $ getResponseEntity response + +deleteRequestTo :: T.Text -> GitHub DidDelete +deleteRequestTo uri = do + opts <- requestOptions + response <- liftIO $ deleteWith opts (T.unpack uri) + checkForStatus response + return $ isDeleted (viewResponse response) + +checkForStatus :: Response a -> GitHub () +checkForStatus (viewResponse -> 404) = tryAssert NotFound False +checkForStatus (viewResponse -> 403) = tryAssert NotAllowed False +checkForStatus (viewResponse -> 401) = tryAssert RequiresAuthentication False +checkForStatus (viewResponse -> 422) = tryAssert ValidationFailed False +checkForStatus (viewResponse -> 500) = tryAssert InternalError False +checkForStatus (viewResponse -> 400) = tryAssert InvalidJSON False +checkForStatus (viewResponse -> _) = tryAssert AllOk True + +viewResponse :: Response a -> Int +viewResponse = view (responseStatus . statusCode) + +isDeleted :: Int -> DidDelete +isDeleted 204 = Deleted +isDeleted 200 = Deleted +isDeleted _ = NotDeleted diff --git a/src/Network/Octohat/Keys.hs b/src/Network/Octohat/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Network/Octohat/Keys.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Octohat.Keys (fingerprintFor) where + +import qualified Data.List as L +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base16 as B16 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Crypto.Hash.MD5 as MD5 -- eww + +import Network.Octohat.Types + +type RSAPublicKey = T.Text +type Fingerprint = T.Text + +-- | Computes a fingerprint from its Base 64 encoded representation. Assumes leading @ssh-rsa @ (mind the space) +-- prefix and no user@hostname suffix +fingerprintFor :: PublicKey -> PublicKeyFingerprint +fingerprintFor PublicKey{..} = PublicKeyFingerprint publicKeyId (digestToHex publicKey) + +digestToHex :: RSAPublicKey -> Fingerprint +digestToHex = T.concat . + L.intersperse ":" . + T.chunksOf 2 . + T.toLower . + TE.decodeUtf8 . + B16.encode . + MD5.hash . + B64.decodeLenient . + TE.encodeUtf8 . + T.replace "ssh-rsa " "" diff --git a/src/Network/Octohat/Members.hs b/src/Network/Octohat/Members.hs new file mode 100644 --- /dev/null +++ b/src/Network/Octohat/Members.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Execute the result of these functions using 'runGitHub' or 'runGitHub'' + +module Network.Octohat.Members + ( membersForOrganization + , membersForTeam + , teamsForOrganization + , addMemberToTeam + , deleteMemberFromTeam + , deleteTeamFromOrganization + , publicKeysForUser + , addTeamToOrganization + , userForUsername + , addPublicKey + ) where + +import Network.Octohat.Internal +import Network.Octohat.Types + +import qualified Data.Text as T +import Data.Monoid ((<>)) + +-- | Takes a new team name, the description of a team and the organization where to create the team +-- and creates a new team. Regular GitHub authorization/authentication applies. +addTeamToOrganization :: T.Text -- ^ Name of new team + -> T.Text -- ^ Description of new team + -> T.Text -- ^ Organization name where the team will be created + -> GitHub Team +addTeamToOrganization nameOfNewTeam descOfTeam orgName = + postRequestTo (composeEndpoint ["orgs", orgName, "teams"]) (TeamCreateRequest nameOfNewTeam descOfTeam) + +-- | Deletes a team from an organization using its team ID. +deleteTeamFromOrganization :: Integer -- ^ ID of Team to delete + -> GitHub DidDelete +deleteTeamFromOrganization idOfTeam = deleteRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam]) + +-- | Returns a list of members of an organization with the given name. +membersForOrganization :: T.Text -- ^ The organization name + -> GitHub [Member] +membersForOrganization nameOfOrg = getRequestTo (composeEndpoint ["orgs", nameOfOrg, "members"]) + +-- | Returns a list of members of a team with the given team ID. +membersForTeam :: Integer -- ^ The team ID + -> GitHub [Member] +membersForTeam idOfTeam = getRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "members"]) + +-- | Returns a list of teams for the organization with the given name +teamsForOrganization :: T.Text -- ^ The organization name + -> GitHub [Team] +teamsForOrganization nameOfOrg = getRequestTo (composeEndpoint ["orgs", nameOfOrg, "teams"]) + +-- | Adds a member to a team, might invite or add the member. Refer to 'StatusInTeam' +addMemberToTeam :: T.Text -- ^ The GitHub username to add to a team + -> Integer -- ^ The Team ID + -> GitHub StatusInTeam +addMemberToTeam nameOfUser idOfTeam = + putRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "memberships", nameOfUser]) + +-- | Deletes a member with the given name from a team with the given ID. Might or might not delete +deleteMemberFromTeam :: T.Text -- ^ GitHub username + -> Integer -- ^ GitHub team ID + -> GitHub DidDelete +deleteMemberFromTeam nameOfUser idOfTeam = + deleteRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "memberships", nameOfUser]) + +-- | Returns the public keys of the user with the given name +publicKeysForUser :: T.Text -- ^ GitHub username + -> GitHub [PublicKey] +publicKeysForUser nameOfUser = getRequestTo (composeEndpoint ["users", nameOfUser, "keys"]) + +-- | Finds a user ID given their username +userForUsername :: T.Text -- ^ GitHub username + -> GitHub Member +userForUsername username = getRequestTo (composeEndpoint ["users", username]) + +-- | Add a key for the currently authenticated user +addPublicKey :: T.Text -- ^ Base64 RSA Key (ssh-rsa AA..) + -> T.Text -- ^ Key title, e.g @octocat@stackbuilders@ + -> GitHub PublicKey +addPublicKey newKey newTitle = + postRequestTo (composeEndpoint ["user", "keys"]) (AddPublicKeyRequest ("ssh-rsa " <> newKey) newTitle) diff --git a/src/Network/Octohat/Types.hs b/src/Network/Octohat/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Octohat/Types.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module Network.Octohat.Types ( Member(..) + , MemberWithKey(..) + , Team(..) + , BearerToken(..) + , StatusInTeam(..) + , EmptyBody(..) + , DidDelete(..) + , PublicKey(..) + , PublicKeyFingerprint(..) + , TeamCreateRequest(..) + , GitHubReturnStatus(..) + , DidAddKey(..) + , AddPublicKeyRequest(..) + , runGitHub + , runGitHub' + , GitHub) where +import Control.Applicative +import Control.Monad.Reader (ReaderT(..)) +import Control.Monad.Trans.Either +import Data.Aeson +import Data.Aeson.TH +import Data.Char (toLower) +import Network.HTTP.Client +import Network.Wreq.Types +import System.Environment.Compat (lookupEnv) +import qualified Data.HashMap.Strict as HS +import qualified Data.Text as T + +-- | Represents a user in GitHub. Contains no more than login and user ID +data Member = + Member { memberLogin :: T.Text + , memberId :: Integer + } deriving (Show, Eq) + +-- | Represents a team in GitHub. Contains the team's ID, the team's name and an optional description +data Team = + Team { teamId :: Integer + , teamName :: T.Text + , teamDescription :: Maybe T.Text + } deriving (Show, Eq) + +-- | Represents a request to create a new team within an organization. The rest of the paramaters +-- are passed in the URL. Refer to +data TeamCreateRequest = + TeamCreateRequest { newTeamName :: T.Text + , newTeamDescription :: T.Text + } deriving (Show, Eq) + +-- | Represents a GitHub user with its public keys and fingerprints. A GitHub user might or might not +-- have any public keys +data MemberWithKey = + MemberWithKey { member :: Member + , memberKey :: [PublicKey] + , memberKeyFingerprint :: [PublicKeyFingerprint] + } deriving (Show, Eq) + +-- | Represents a PublicKey within GitHub. It includes its ID and the public key encoded as base 64 +data PublicKey = + PublicKey { publicKeyId :: Integer + , publicKey :: T.Text + } deriving (Show, Eq) + +-- | Represents a Fingerprint. The `fingerprintId` field should match the fingerprint's public key ID +-- within GitHub +data PublicKeyFingerprint = + PublicKeyFingerprint { fingerprintId :: Integer + , publicKeyFingerprint :: T.Text + } deriving (Show, Eq) + +-- | Some Wreq functions expect a body, but often GitHub's API will request no body. The PUT verb +-- and its implementation in Wreq is an example of this. +data EmptyBody = EmptyBody deriving (Show, Eq) + +-- | When adding a user to a team GitHub will add it immediately if the user already belongs to the +-- to the organization the team is in. Otherwise it will send an email for the user to accept the +-- request to join the team. Functions related adding or removing teams will return either Active +-- or Pending correspondingly. +data StatusInTeam = Active | Pending deriving (Show, Eq) + + +-- | Sum type to represent the success or failure of deletion of a resource within GitHub's API +data DidDelete = Deleted | NotDeleted deriving (Show, Eq) + +instance FromJSON PublicKey where + parseJSON (Object o) = PublicKey <$> o .: "id" <*> o .: "key" + parseJSON _ = fail "Could not find public keys in document" + +data DidAddKey = KeyAdded | KeyNotAdded + +data AddPublicKeyRequest = + AddPublicKeyRequest { + addPublicKeyRequestKey :: T.Text, + addPublicKeyRequestTitle :: T.Text + } + +instance FromJSON StatusInTeam where + parseJSON (Object o) = + case HS.lookup "state" o of + Just "active" -> pure Active + Just "pending" -> pure Pending + Just _ -> fail "\"state\" key not \"active\" or \"pending\"" + Nothing -> (fail . maybe "No error message from GitHub" show) (HS.lookup "message" o) + parseJSON _ = fail "Expected a membership document, got something else" + +$(deriveJSON defaultOptions { fieldLabelModifier = drop 6 . map toLower } ''Member) +$(deriveJSON defaultOptions { fieldLabelModifier = drop 4 . map toLower } ''Team) +$(deriveJSON defaultOptions { fieldLabelModifier = drop 7 . map toLower } ''TeamCreateRequest) +$(deriveJSON defaultOptions { fieldLabelModifier = drop 19 . map toLower } ''AddPublicKeyRequest) + +-- | Error codes GitHub might return when attempting to use an API endpoint +data GitHubReturnStatus = InvalidJSON -- ^ GitHub could not parse the JSON document sent + | ValidationFailed -- ^ Validation failed, an example of this error + -- is trying to create teams with the same name + -- within one organization + | InternalError -- ^ In case GitHub returns 500 Internal Server Error + -- to some request + | NotFound -- ^ When a resource has not been found. It does not + -- imply the resource does not exist + | NotAllowed -- ^ Usually returned after GitHub replies with 403 Forbidden. + -- The user might not have permission to access/modify + -- that resource + | AllOk -- ^ This should never be returned + | RequiresAuthentication -- ^ Accesing this resource requires authentication + | UnexpectedJSON String -- ^ This library has failed to fulfill its purpose and could not + -- handle GitHub's response + deriving (Show, Eq) + +-- | Instance that does not add anything to the body or headers of a PUT request +instance Putable EmptyBody where + putPayload EmptyBody req = return $ req {requestBody = RequestBodyLBS ""} + +instance Postable TeamCreateRequest where + postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)} + +instance Postable AddPublicKeyRequest where + postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)} + +-- | GitHub's OAuth 2.0 bearer token. This is simply added in an +-- Authorization header +newtype BearerToken = BearerToken { unBearerToken :: T.Text } + +-- | The monad transformer where all operations run. Supports initial configuration +-- through a Reader monad and the possibility of failure through Either +type GitHub = EitherT GitHubReturnStatus (ReaderT BearerToken IO) + +-- | Executes a computation built within the GitHub monad returning an Either within +-- the IO data type using the provided token +runGitHub' :: GitHub a -> BearerToken -> IO (Either GitHubReturnStatus a) +runGitHub' comp = runReaderT (runEitherT comp) + +-- | Executes a computation built within the GitHub monad returning an Either within +-- the IO data type. Reads an API token from an environment variable named GITHUB_TOKEN +runGitHub :: GitHub a -> IO (Either GitHubReturnStatus a) +runGitHub comp = do + maybeToken <- lookupEnv "GITHUB_TOKEN" + case maybeToken of + Just acquiredToken -> runGitHub' comp (BearerToken $ T.pack acquiredToken) + Nothing -> fail "Couldn't find GITHUB_TOKEN in environment"