module Network.Octohat.Types ( Member(..)
, MemberWithKey(..)
, Team(..)
, TeamPermission(..)
, Repo(..)
, Organization(..)
, BearerToken(..)
, OrganizationName(..)
, TeamName(..)
, StatusInTeam(..)
, EmptyBody(..)
, DidDelete(..)
, PublicKey(..)
, PublicKeyFingerprint(..)
, TeamCreateRequest(..)
, GitHubReturnStatus(..)
, DidAddKey(..)
, AddPublicKeyRequest(..)
, Links(..)
, Pagination(..)
, runGitHub
, runGitHub'
, GitHub) where
import Control.Applicative
import Control.Monad.Reader (ReaderT(..))
import Control.Monad.State (StateT(..), evalStateT)
#if MIN_VERSION_errors(2,0,0)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
#else
import Control.Monad.Trans.Either
#endif
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
data Member =
Member { memberLogin :: T.Text
, memberId :: Integer
} deriving (Show, Eq)
data TeamPermission = OwnerAccess
| PullAccess
| PushAccess
| AdminAccess
deriving (Show,Eq)
data Team =
Team { teamId :: Integer
, teamName :: T.Text
, teamDescription :: Maybe T.Text
, teamPermission :: TeamPermission
} deriving (Show, Eq)
data TeamCreateRequest =
TeamCreateRequest { newTeamName :: T.Text
, newTeamDescription :: T.Text
, newTeamPermission :: TeamPermission
} deriving (Show, Eq)
data Organization =
Organization
{ orgLogin :: T.Text
, orgDescription :: Maybe T.Text
} deriving (Show, Eq)
data Repo =
Repo { repoName :: T.Text
, repoDescription :: Maybe T.Text
, repoPrivate :: Bool
} deriving (Show, Eq)
data MemberWithKey =
MemberWithKey { member :: Member
, memberKey :: [PublicKey]
, memberKeyFingerprint :: [PublicKeyFingerprint]
} deriving (Show, Eq)
data PublicKey =
PublicKey { publicKeyId :: Integer
, publicKey :: T.Text
} deriving (Show, Eq)
data PublicKeyFingerprint =
PublicKeyFingerprint { fingerprintId :: Integer
, publicKeyFingerprint :: T.Text
} deriving (Show, Eq)
data EmptyBody = EmptyBody deriving (Show, Eq)
data StatusInTeam = Active | Pending deriving (Show, Eq)
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"
instance FromJSON TeamPermission where
parseJSON (String p) =
case p of
"pull" -> pure PullAccess
"push" -> pure PushAccess
"admin" -> pure AdminAccess
"owner" -> pure OwnerAccess
_ -> fail "Expected a valid team permission ?"
parseJSON _ = fail "Expected a team permssion, got something else"
instance ToJSON TeamPermission where
toJSON p =
case p of
PullAccess -> String "pull"
PushAccess -> String "push"
AdminAccess -> String "admin"
OwnerAccess -> String "owner"
$(deriveJSON defaultOptions { fieldLabelModifier = drop 6 . map toLower } ''Member)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 4 . map toLower } ''Team)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 4 . map toLower } ''Repo)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 3 . map toLower } ''Organization)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 7 . map toLower } ''TeamCreateRequest)
$(deriveJSON defaultOptions { fieldLabelModifier = drop 19 . map toLower } ''AddPublicKeyRequest)
data GitHubReturnStatus = InvalidJSON
| ValidationFailed
| InternalError
| NotFound
| NotAllowed
| AllOk
| RequiresAuthentication
| UnexpectedJSON String
deriving (Show, Eq)
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)}
newtype BearerToken = BearerToken { unBearerToken :: T.Text } deriving Show
newtype OrganizationName = OrganizationName { unOrganizationName :: T.Text } deriving Show
newtype TeamName = TeamName { unTeamName :: T.Text } deriving Show
data Links = Links { linkNext :: Maybe Link, linkLast :: Maybe Link
, linkFirst :: Maybe Link, linkPrev :: Maybe Link } deriving Show
data Pagination = Pagination { perPage :: Int, page :: Int, links :: Links, recurse :: Bool } deriving Show
defPagination :: Pagination
defPagination = Pagination 30 1 (Links Nothing Nothing Nothing Nothing) True
#if MIN_VERSION_errors(2,0,0)
type GitHub = ExceptT GitHubReturnStatus (ReaderT BearerToken (StateT Pagination IO))
#else
type GitHub = EitherT GitHubReturnStatus (ReaderT BearerToken (StateT Pagination IO))
#endif
runGitHub' :: GitHub a -> BearerToken -> IO (Either GitHubReturnStatus a)
#if MIN_VERSION_errors(2,0,0)
runGitHub' comp token = evalStateT (runReaderT (runExceptT comp) token) defPagination
#else
runGitHub' comp token = evalStateT (runReaderT (runEitherT comp) token) defPagination
#endif
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"