diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Mike Burns + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Mike Burns nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER 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. diff --git a/github-data.cabal b/github-data.cabal new file mode 100644 --- /dev/null +++ b/github-data.cabal @@ -0,0 +1,117 @@ +name: github-data +version: 0.18 +synopsis: Access to the GitHub API, v3. +description: + The GitHub API provides programmatic access to the full + GitHub Web site, from Issues to Gists to repos down to the underlying git data + like references and trees. This library wraps all of that, exposing a basic but + Haskell-friendly set of functions and data structures. + . + For supported endpoints see "GitHub" module. + . + > import qualified GitHub as GH + > + > main :: IO () + > main = do + > possibleUser <- GH.executeRequest' $ GH.userInfoR "phadej" + > print possibleUser + . + For more of an overview please see the README: +license: BSD3 +license-file: LICENSE +author: Mike Burns, John Wiegley, Oleg Grenrus +maintainer: M Farkas-Dyck +homepage: https://github.com/strake/github.hs +copyright: Copyright 2012-2013 Mike Burns, Copyright 2013-2015 John Wiegley, Copyright 2016 Oleg Grenrus +category: Network +build-type: Simple +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 +cabal-version: >=1.10 + +flag aeson-compat + description: Whether to use aeson-compat or aeson-extra + default: True + manual: False + +source-repository head + type: git + location: git://github.com/phadej/github.git + +Library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + default-extensions: + DataKinds + DeriveDataTypeable + DeriveGeneric + OverloadedStrings + ScopedTypeVariables + other-extensions: + CPP + FlexibleContexts + FlexibleInstances + GADTs + KindSignatures + StandaloneDeriving + exposed-modules: + GitHub.Auth + GitHub.Data + GitHub.Data.Activities + GitHub.Data.Comments + GitHub.Data.Content + GitHub.Data.Definitions + GitHub.Data.DeployKeys + GitHub.Data.Email + GitHub.Data.Events + GitHub.Data.Gists + GitHub.Data.GitData + GitHub.Data.Id + GitHub.Data.Issues + GitHub.Data.Milestone + GitHub.Data.Name + GitHub.Data.Options + GitHub.Data.PullRequests + GitHub.Data.Releases + GitHub.Data.Repos + GitHub.Data.Request + GitHub.Data.Reviews + GitHub.Data.Search + GitHub.Data.Statuses + GitHub.Data.Teams + GitHub.Data.URL + GitHub.Data.Webhooks + other-modules: + GitHub.Internal.Prelude + + -- Packages needed in order to build this package. + build-depends: base >=4.7 && <4.11, + aeson >=0.7.0.6 && <1.3, + base-compat >=0.9.1 && <0.10, + base16-bytestring >=0.1.1.6 && <0.2, + binary >=0.7.1.0 && <0.10, + binary-orphans >=0.1.0.0 && <0.2, + bytestring >=0.10.4.0 && <0.11, + containers >=0.5.5.1 && <0.6, + deepseq >=1.3.0.2 && <1.5, + deepseq-generics >=0.1.1.2 && <0.3, + exceptions >=0.8.0.2 && <0.9, + hashable >=1.2.3.3 && <1.3, + http-client >=0.4.8.1 && <0.6, + http-types >=0.8.6 && <0.12, + iso8601-time >=0.1.4 && <0.2, + network-uri >=2.6.0.3 && <2.7, + text >=1.2.0.6 && <1.3, + time >=1.4 && <1.9, + transformers >=0.3.0.0 && <0.6, + transformers-compat >=0.4.0.3 && <0.6, + unordered-containers >=0.2 && <0.3, + vector >=0.10.12.3 && <0.13, + vector-instances >=3.3.0.1 && <3.5, + + tls >=1.3.5 + + if flag(aeson-compat) + build-depends: aeson-compat >=0.3.0.0 && <0.4 + else + build-depends: aeson-extra >=0.2.0.0 && <0.3 diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Auth.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Auth where + +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.ByteString as BS + +type Token = BS.ByteString + +-- | The Github auth data type +data Auth + = BasicAuth BS.ByteString BS.ByteString + | OAuth Token -- ^ token + | EnterpriseOAuth Text -- custom API endpoint without + -- trailing slash + Token -- token + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Auth where rnf = genericRnf +instance Binary Auth +instance Hashable Auth diff --git a/src/GitHub/Data.hs b/src/GitHub/Data.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- This module re-exports the @GitHub.Data.@ and "Github.Auth" submodules. +module GitHub.Data ( + -- * Tagged types + -- ** Name + Name, + mkName, + untagName, + mkOwnerName, + mkUserName, + mkTeamName, + mkOrganizationName, + mkRepoName, + mkCommitName, + fromUserName, + fromOrganizationName, + -- ** Id + Id, + mkId, + untagId, + mkOwnerId, + mkUserId, + mkTeamId, + mkOrganizationId, + mkRepoId, + fromUserId, + fromOrganizationId, + -- * Module re-exports + module GitHub.Auth, + module GitHub.Data.Activities, + module GitHub.Data.Comments, + module GitHub.Data.Content, + module GitHub.Data.Definitions, + module GitHub.Data.DeployKeys, + module GitHub.Data.Email, + module GitHub.Data.Events, + module GitHub.Data.Gists, + module GitHub.Data.GitData, + module GitHub.Data.Issues, + module GitHub.Data.Milestone, + module GitHub.Data.Options, + module GitHub.Data.PullRequests, + module GitHub.Data.Releases, + module GitHub.Data.Repos, + module GitHub.Data.Request, + module GitHub.Data.Reviews, + module GitHub.Data.Search, + module GitHub.Data.Statuses, + module GitHub.Data.Teams, + module GitHub.Data.URL, + module GitHub.Data.Webhooks + ) where + +import GitHub.Internal.Prelude +import Prelude () + +import GitHub.Auth +import GitHub.Data.Activities +import GitHub.Data.Comments +import GitHub.Data.Content +import GitHub.Data.Definitions +import GitHub.Data.DeployKeys +import GitHub.Data.Email +import GitHub.Data.Events +import GitHub.Data.Gists +import GitHub.Data.GitData +import GitHub.Data.Id +import GitHub.Data.Issues +import GitHub.Data.Milestone +import GitHub.Data.Name +import GitHub.Data.Options +import GitHub.Data.PullRequests +import GitHub.Data.Releases +import GitHub.Data.Repos +import GitHub.Data.Request +import GitHub.Data.Reviews +import GitHub.Data.Search +import GitHub.Data.Statuses +import GitHub.Data.Teams +import GitHub.Data.URL +import GitHub.Data.Webhooks + +mkOwnerId :: Int -> Id Owner +mkOwnerId = Id + +mkOwnerName :: Text -> Name Owner +mkOwnerName = N + +mkUserId :: Int -> Id User +mkUserId = Id + +mkUserName :: Text -> Name User +mkUserName = N + +mkTeamId :: Int -> Id Team +mkTeamId = Id + +mkTeamName :: Text -> Name Team +mkTeamName = N + +mkOrganizationId :: Int -> Id Organization +mkOrganizationId = Id + +mkOrganizationName :: Text -> Name Organization +mkOrganizationName = N + +mkRepoId :: Int -> Id Repo +mkRepoId = Id + +mkRepoName :: Text -> Name Repo +mkRepoName = N + +mkCommitName :: Text -> Name Commit +mkCommitName = N + +fromOrganizationName :: Name Organization -> Name Owner +fromOrganizationName = N . untagName + +fromUserName :: Name User -> Name Owner +fromUserName = N . untagName + +fromOrganizationId :: Id Organization -> Id Owner +fromOrganizationId = Id . untagId + +fromUserId :: Id User -> Id Owner +fromUserId = Id . untagId diff --git a/src/GitHub/Data/Activities.hs b/src/GitHub/Data/Activities.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Activities.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Activities where + +import GitHub.Data.Repos (Repo) +import GitHub.Internal.Prelude +import Prelude () + +data RepoStarred = RepoStarred + { repoStarredStarredAt :: !UTCTime + , repoStarredRepo :: !Repo + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoStarred where rnf = genericRnf +instance Binary RepoStarred + +-- JSON Instances +instance FromJSON RepoStarred where + parseJSON = withObject "RepoStarred" $ \o -> RepoStarred + <$> o .: "starred_at" + <*> o .: "repo" + diff --git a/src/GitHub/Data/Comments.hs b/src/GitHub/Data/Comments.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Comments.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Comments where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Comment = Comment + { commentPosition :: !(Maybe Int) + , commentLine :: !(Maybe Int) + , commentBody :: !Text + , commentCommitId :: !(Maybe Text) + , commentUpdatedAt :: !UTCTime + , commentHtmlUrl :: !(Maybe URL) + , commentUrl :: !URL + , commentCreatedAt :: !(Maybe UTCTime) + , commentPath :: !(Maybe Text) + , commentUser :: !SimpleUser + , commentId :: !(Id Comment) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Comment where rnf = genericRnf +instance Binary Comment + +instance FromJSON Comment where + parseJSON = withObject "Comment" $ \o -> Comment + <$> o .:? "position" + <*> o .:? "line" + <*> o .: "body" + <*> o .:? "commit_id" + <*> o .: "updated_at" + <*> o .:? "html_url" + <*> o .: "url" + <*> o .: "created_at" + <*> o .:? "path" + <*> o .: "user" + <*> o .: "id" + +data NewComment = NewComment + { newCommentBody :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewComment where rnf = genericRnf +instance Binary NewComment + +instance ToJSON NewComment where + toJSON (NewComment b) = object [ "body" .= b ] + +data EditComment = EditComment + { editCommentBody :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData EditComment where rnf = genericRnf +instance Binary EditComment + +instance ToJSON EditComment where + toJSON (EditComment b) = object [ "body" .= b ] diff --git a/src/GitHub/Data/Content.hs b/src/GitHub/Data/Content.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Content.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Content where + +import Data.Aeson.Types (Pair) +import Data.Maybe (maybe) +import GitHub.Data.GitData +import GitHub.Data.URL +import GitHub.Internal.Prelude +import Prelude () + +data Content + = ContentFile !ContentFileData + | ContentDirectory !(Vector ContentItem) + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Content where rnf = genericRnf +instance Binary Content + +data ContentFileData = ContentFileData { + contentFileInfo :: !ContentInfo + ,contentFileEncoding :: !Text + ,contentFileSize :: !Int + ,contentFileContent :: !Text +} deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentFileData where rnf = genericRnf +instance Binary ContentFileData + +-- | An item in a directory listing. +data ContentItem = ContentItem { + contentItemType :: !ContentItemType + ,contentItemInfo :: !ContentInfo +} deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentItem where rnf = genericRnf +instance Binary ContentItem + +data ContentItemType = ItemFile | ItemDir + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentItemType where rnf = genericRnf +instance Binary ContentItemType + +-- | Information common to both kinds of Content: files and directories. +data ContentInfo = ContentInfo { + contentName :: !Text + ,contentPath :: !Text + ,contentSha :: !Text + ,contentUrl :: !URL + ,contentGitUrl :: !URL + ,contentHtmlUrl :: !URL +} deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentInfo where rnf = genericRnf +instance Binary ContentInfo + +data ContentResultInfo = ContentResultInfo + { contentResultInfo :: !ContentInfo + , contentResultSize :: !Int + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentResultInfo where rnf = genericRnf +instance Binary ContentResultInfo + +data ContentResult = ContentResult + { contentResultContent :: !ContentResultInfo + , contentResultCommit :: !GitCommit + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ContentResult where rnf = genericRnf +instance Binary ContentResult + +data Author = Author + { authorName :: !Text + , authorEmail :: !Text + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData Author where rnf = genericRnf +instance Binary Author + +data CreateFile = CreateFile + { createFilePath :: !Text + , createFileMessage :: !Text + , createFileContent :: !Text + , createFileBranch :: !(Maybe Text) + , createFileAuthor :: !(Maybe Author) + , createFileCommitter :: !(Maybe Author) + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData CreateFile where rnf = genericRnf +instance Binary CreateFile + +data UpdateFile = UpdateFile + { updateFilePath :: !Text + , updateFileMessage :: !Text + , updateFileContent :: !Text + , updateFileSHA :: !Text + , updateFileBranch :: !(Maybe Text) + , updateFileAuthor :: !(Maybe Author) + , updateFileCommitter :: !(Maybe Author) + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData UpdateFile where rnf = genericRnf +instance Binary UpdateFile + +data DeleteFile = DeleteFile + { deleteFilePath :: !Text + , deleteFileMessage :: !Text + , deleteFileSHA :: !Text + , deleteFileBranch :: !(Maybe Text) + , deleteFileAuthor :: !(Maybe Author) + , deleteFileCommitter :: !(Maybe Author) + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData DeleteFile where rnf = genericRnf +instance Binary DeleteFile + +instance FromJSON Content where + parseJSON o@(Object _) = ContentFile <$> parseJSON o + parseJSON (Array os) = ContentDirectory <$> traverse parseJSON os + parseJSON _ = fail "Could not build a Content" + +instance FromJSON ContentFileData where + parseJSON = withObject "ContentFileData" $ \o -> + ContentFileData <$> parseJSON (Object o) + <*> o .: "encoding" + <*> o .: "size" + <*> o .: "content" + +instance FromJSON ContentItem where + parseJSON = withObject "ContentItem" $ \o -> + ContentItem <$> o .: "type" + <*> parseJSON (Object o) + +instance FromJSON ContentItemType where + parseJSON = withText "ContentItemType" $ \t -> + case t of + "file" -> return ItemFile + "dir" -> return ItemDir + _ -> fail $ "Invalid ContentItemType: " ++ unpack t + +instance FromJSON ContentInfo where + parseJSON = withObject "ContentInfo" $ \o -> + ContentInfo <$> o .: "name" + <*> o .: "path" + <*> o .: "sha" + <*> o .: "url" + <*> o .: "git_url" + <*> o .: "html_url" + +instance FromJSON ContentResultInfo where + parseJSON = withObject "ContentResultInfo" $ \o -> + ContentResultInfo <$> parseJSON (Object o) + <*> o .: "size" + +instance FromJSON ContentResult where + parseJSON = withObject "ContentResult" $ \o -> + ContentResult <$> o .: "content" + <*> o .: "commit" + +instance ToJSON Author where + toJSON Author {..} = object + [ "name" .= authorName + , "email" .= authorEmail + ] + +instance ToJSON CreateFile where + toJSON CreateFile {..} = object $ + [ "path" .= createFilePath + , "message" .= createFileMessage + , "content" .= createFileContent + ] + ++ "branch" .=? createFileBranch + ++ "author" .=? createFileAuthor + ++ "committer" .=? createFileCommitter + +instance ToJSON UpdateFile where + toJSON UpdateFile {..} = object $ + [ "path" .= updateFilePath + , "message" .= updateFileMessage + , "content" .= updateFileContent + , "sha" .= updateFileSHA + ] + ++ "branch" .=? updateFileBranch + ++ "author" .=? updateFileAuthor + ++ "committer" .=? updateFileCommitter + +instance ToJSON DeleteFile where + toJSON DeleteFile {..} = object $ + [ "path" .= deleteFilePath + , "message" .= deleteFileMessage + , "sha" .= deleteFileSHA + ] + ++ "branch" .=? deleteFileBranch + ++ "author" .=? deleteFileAuthor + ++ "committer" .=? deleteFileCommitter + +(.=?) :: ToJSON v => Text -> Maybe v -> [Pair] +name .=? value = maybe [] (pure . (name .=)) value diff --git a/src/GitHub/Data/Definitions.hs b/src/GitHub/Data/Definitions.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Definitions.hs @@ -0,0 +1,258 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Definitions where + +import GitHub.Internal.Prelude +import Prelude () + +import Control.Monad (mfilter) +import Data.Aeson.Types (Parser) +import Network.HTTP.Client (HttpException) + +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.Text as T + +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.URL (URL) + +-- | Errors have been tagged according to their source, so you can more easily +-- dispatch and handle them. +data Error + = HTTPError !HttpException -- ^ A HTTP error occurred. The actual caught error is included. + | ParseError !Text -- ^ An error in the parser itself. + | JsonError !Text -- ^ The JSON is malformed or unexpected. + | UserError !Text -- ^ Incorrect input. + deriving (Show, Typeable) + +instance E.Exception Error + +-- | Type of the repository owners. +data OwnerType = OwnerUser | OwnerOrganization + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable, Data) + +instance NFData OwnerType +instance Binary OwnerType + +data SimpleUser = SimpleUser + { simpleUserId :: !(Id User) + , simpleUserLogin :: !(Name User) + , simpleUserAvatarUrl :: !URL + , simpleUserUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData SimpleUser where rnf = genericRnf +instance Binary SimpleUser + +data SimpleOrganization = SimpleOrganization + { simpleOrganizationId :: !(Id Organization) + , simpleOrganizationLogin :: !(Name Organization) + , simpleOrganizationUrl :: !URL + , simpleOrganizationAvatarUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData SimpleOrganization where rnf = genericRnf +instance Binary SimpleOrganization + +-- | Sometimes we don't know the type of the owner, e.g. in 'Repo' +data SimpleOwner = SimpleOwner + { simpleOwnerId :: !(Id Owner) + , simpleOwnerLogin :: !(Name Owner) + , simpleOwnerUrl :: !URL + , simpleOwnerAvatarUrl :: !URL + , simpleOwnerType :: !OwnerType + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData SimpleOwner where rnf = genericRnf +instance Binary SimpleOwner + +data User = User + { userId :: !(Id User) + , userLogin :: !(Name User) + , userName :: !(Maybe Text) + , userType :: !OwnerType -- ^ Should always be 'OwnerUser' + , userCreatedAt :: !UTCTime + , userPublicGists :: !Int + , userAvatarUrl :: !URL + , userFollowers :: !Int + , userFollowing :: !Int + , userHireable :: !(Maybe Bool) + , userBlog :: !(Maybe Text) + , userBio :: !(Maybe Text) + , userPublicRepos :: !Int + , userLocation :: !(Maybe Text) + , userCompany :: !(Maybe Text) + , userEmail :: !(Maybe Text) + , userUrl :: !URL + , userHtmlUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData User where rnf = genericRnf +instance Binary User + +data Organization = Organization + { organizationId :: !(Id Organization) + , organizationLogin :: !(Name Organization) + , organizationName :: !(Maybe Text) + , organizationType :: !OwnerType -- ^ Should always be 'OwnerOrganization' + , organizationBlog :: !(Maybe Text) + , organizationLocation :: !(Maybe Text) + , organizationFollowers :: !Int + , organizationCompany :: !(Maybe Text) + , organizationAvatarUrl :: !URL + , organizationPublicGists :: !Int + , organizationHtmlUrl :: !URL + , organizationEmail :: !(Maybe Text) + , organizationFollowing :: !Int + , organizationPublicRepos :: !Int + , organizationUrl :: !URL + , organizationCreatedAt :: !UTCTime + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Organization where rnf = genericRnf +instance Binary Organization + +-- | In practic, you cam't have concrete values of 'Owner'. +newtype Owner = Owner (Either User Organization) + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Owner where rnf = genericRnf +instance Binary Owner + +fromOwner :: Owner -> Either User Organization +fromOwner (Owner owner) = owner + +-- JSON instances + +instance FromJSON OwnerType where + parseJSON = withText "Owner type" $ \t -> + case t of + "User" -> pure $ OwnerUser + "Organization" -> pure $ OwnerOrganization + _ -> fail $ "Unknown owner type: " ++ T.unpack t + +instance FromJSON SimpleUser where + parseJSON = withObject "SimpleUser" $ \obj -> do + SimpleUser + <$> obj .: "id" + <*> obj .: "login" + <*> obj .: "avatar_url" + <*> obj .: "url" + +instance FromJSON SimpleOrganization where + parseJSON = withObject "SimpleOrganization" $ \obj -> + SimpleOrganization + <$> obj .: "id" + <*> obj .: "login" + <*> obj .: "url" + <*> obj .: "avatar_url" + +instance FromJSON SimpleOwner where + parseJSON = withObject "SimpleOwner" $ \obj -> do + SimpleOwner + <$> obj .: "id" + <*> obj .: "login" + <*> obj .: "url" + <*> obj .: "avatar_url" + <*> obj .: "type" + +parseUser :: Object -> Parser User +parseUser obj = User + <$> obj .: "id" + <*> obj .: "login" + <*> obj .:? "name" + <*> obj .: "type" + <*> obj .: "created_at" + <*> obj .: "public_gists" + <*> obj .: "avatar_url" + <*> obj .: "followers" + <*> obj .: "following" + <*> obj .:? "hireable" + <*> obj .:? "blog" + <*> obj .:? "bio" + <*> obj .: "public_repos" + <*> obj .:? "location" + <*> obj .:? "company" + <*> obj .:? "email" + <*> obj .: "url" + <*> obj .: "html_url" + +parseOrganization :: Object -> Parser Organization +parseOrganization obj = Organization + <$> obj .: "id" + <*> obj .: "login" + <*> obj .:? "name" + <*> obj .: "type" + <*> obj .:? "blog" + <*> obj .:? "location" + <*> obj .: "followers" + <*> obj .:? "company" + <*> obj .: "avatar_url" + <*> obj .: "public_gists" + <*> obj .: "html_url" + <*> obj .:? "email" + <*> obj .: "following" + <*> obj .: "public_repos" + <*> obj .: "url" + <*> obj .: "created_at" + +instance FromJSON User where + parseJSON = mfilter ((== OwnerUser) . userType) . withObject "User" parseUser + +instance FromJSON Organization where + parseJSON = withObject "Organization" parseOrganization + +instance FromJSON Owner where + parseJSON = withObject "Owner" $ \obj -> do + t <- obj .: "type" + case t of + OwnerUser -> Owner . Left <$> parseUser obj + OwnerOrganization -> Owner . Right <$> parseOrganization obj + +-- | Filter members returned in the list. +data OrgMemberFilter + = OrgMemberFilter2faDisabled -- ^ Members without two-factor authentication enabled. Available for organization owners. + | OrgMemberFilterAll -- ^ All members the authenticated user can see. + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) + +-- | Filter members returned by their role. +data OrgMemberRole + = OrgMemberRoleAll -- ^ All members of the organization, regardless of role. + | OrgMemberRoleAdmin -- ^ Organization owners. + | OrgMemberRoleMember -- ^ Non-owner organization members. + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) + +-- | Request query string +type QueryString = [(BS.ByteString, Maybe BS.ByteString)] + +-- | Count of elements +type Count = Int + +------------------------------------------------------------------------------- +-- IssueLabel +------------------------------------------------------------------------------- + +data IssueLabel = IssueLabel + { labelColor :: !Text + , labelUrl :: !URL + , labelName :: !(Name IssueLabel) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData IssueLabel where rnf = genericRnf +instance Binary IssueLabel + +instance FromJSON IssueLabel where + parseJSON = withObject "IssueLabel" $ \o -> IssueLabel + <$> o .: "color" + <*> o .: "url" + <*> o .: "name" diff --git a/src/GitHub/Data/DeployKeys.hs b/src/GitHub/Data/DeployKeys.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/DeployKeys.hs @@ -0,0 +1,52 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Todd Mohney +-- +module GitHub.Data.DeployKeys where + +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data RepoDeployKey = RepoDeployKey + { repoDeployKeyId :: !(Id RepoDeployKey) + , repoDeployKeyKey :: !Text + , repoDeployKeyUrl :: !URL + , repoDeployKeyTitle :: !Text + , repoDeployKeyVerified :: !Bool + , repoDeployKeyCreatedAt :: !UTCTime + , repoDeployKeyReadOnly :: !Bool + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON RepoDeployKey where + parseJSON = withObject "RepoDeployKey" $ \o -> RepoDeployKey + <$> o .: "id" + <*> o .: "key" + <*> o .: "url" + <*> o .: "title" + <*> o .: "verified" + <*> o .: "created_at" + <*> o .: "read_only" + +data NewRepoDeployKey = NewRepoDeployKey + { newRepoDeployKeyKey :: !Text + , newRepoDeployKeyTitle :: !Text + , newRepoDeployKeyReadOnly :: !Bool + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance ToJSON NewRepoDeployKey where + toJSON (NewRepoDeployKey key title readOnly) = object + [ "key" .= key + , "title" .= title + , "read_only" .= readOnly + ] + +instance FromJSON NewRepoDeployKey where + parseJSON = withObject "RepoDeployKey" $ \o -> NewRepoDeployKey + <$> o .: "key" + <*> o .: "title" + <*> o .: "read_only" diff --git a/src/GitHub/Data/Email.hs b/src/GitHub/Data/Email.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Email.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Email where + +import GitHub.Internal.Prelude +import Prelude () + +data EmailVisibility + = EmailVisibilityPrivate + | EmailVisibilityPublic + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData EmailVisibility where rnf = genericRnf +instance Binary EmailVisibility + +instance FromJSON EmailVisibility where + parseJSON (String "private") = pure EmailVisibilityPrivate + parseJSON (String "public") = pure EmailVisibilityPublic + parseJSON _ = fail "Could not build an EmailVisibility" + +data Email = Email + { emailAddress :: !Text + , emailVerified :: !Bool + , emailPrimary :: !Bool + , emailVisibility :: !(Maybe EmailVisibility) + } deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Email where rnf = genericRnf +instance Binary Email + +instance FromJSON Email where + parseJSON = withObject "Email" $ \o -> Email + <$> o .: "email" + <*> o .: "verified" + <*> o .: "primary" + <*> o .:? "visibility" diff --git a/src/GitHub/Data/Events.hs b/src/GitHub/Data/Events.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Events.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Events where + +import GitHub.Data.Definitions +import GitHub.Internal.Prelude +import Prelude () + +-- | Events. +-- +-- /TODO:/ +-- +-- * missing repo, org, payload, id +data Event = Event + -- { eventId :: !(Id Event) -- id can be encoded as string. + { eventActor :: !SimpleUser + , eventCreatedAt :: !UTCTime + , eventPublic :: !Bool + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Event where rnf = genericRnf +instance Binary Event + +instance FromJSON Event where + parseJSON = withObject "Event" $ \obj -> Event + -- <$> obj .: "id" + <$> obj .: "actor" + <*> obj .: "created_at" + <*> obj .: "public" diff --git a/src/GitHub/Data/Gists.hs b/src/GitHub/Data/Gists.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Gists.hs @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Gists where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.Repos (Language) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Gist = Gist + { gistUser :: !SimpleUser + , gistGitPushUrl :: !URL + , gistUrl :: !URL + , gistDescription :: !(Maybe Text) + , gistCreatedAt :: !UTCTime + , gistPublic :: !Bool + , gistComments :: !Int + , gistUpdatedAt :: !UTCTime + , gistHtmlUrl :: !URL + , gistId :: !(Name Gist) + , gistFiles :: !(HashMap Text GistFile) + , gistGitPullUrl :: !URL + } deriving (Show, Data, Typeable, Eq, Generic) + +instance NFData Gist where rnf = genericRnf +instance Binary Gist + +instance FromJSON Gist where + parseJSON = withObject "Gist" $ \o -> Gist + <$> o .: "owner" + <*> o .: "git_push_url" + <*> o .: "url" + <*> o .:? "description" + <*> o .: "created_at" + <*> o .: "public" + <*> o .: "comments" + <*> o .: "updated_at" + <*> o .: "html_url" + <*> o .: "id" + <*> o .: "files" + <*> o .: "git_push_url" + +data GistFile = GistFile + { gistFileType :: !Text + , gistFileRawUrl :: !URL + , gistFileSize :: !Int + , gistFileLanguage :: !(Maybe Language) + , gistFileFilename :: !Text + , gistFileContent :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Generic) + +instance NFData GistFile where rnf = genericRnf +instance Binary GistFile + +instance FromJSON GistFile where + parseJSON = withObject "GistFile" $ \o -> GistFile + <$> o .: "type" + <*> o .: "raw_url" + <*> o .: "size" + <*> o .:? "language" + <*> o .: "filename" + <*> o .:? "content" + +data GistComment = GistComment + { gistCommentUser :: !SimpleUser + , gistCommentUrl :: !URL + , gistCommentCreatedAt :: !UTCTime + , gistCommentBody :: !Text + , gistCommentUpdatedAt :: !UTCTime + , gistCommentId :: !(Id GistComment) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GistComment where rnf = genericRnf +instance Binary GistComment + +instance FromJSON GistComment where + parseJSON = withObject "GistComment" $ \o -> GistComment + <$> o .: "user" + <*> o .: "url" + <*> o .: "created_at" + <*> o .: "body" + <*> o .: "updated_at" + <*> o .: "id" diff --git a/src/GitHub/Data/GitData.hs b/src/GitHub/Data/GitData.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/GitData.hs @@ -0,0 +1,317 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.GitData where + +import GitHub.Data.Definitions +import GitHub.Data.Name (Name) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.Vector as V + +-- | The options for querying commits. +data CommitQueryOption + = CommitQuerySha !Text + | CommitQueryPath !Text + | CommitQueryAuthor !Text + | CommitQuerySince !UTCTime + | CommitQueryUntil !UTCTime + deriving (Show, Eq, Ord, Generic, Typeable, Data) + +data Stats = Stats + { statsAdditions :: !Int + , statsTotal :: !Int + , statsDeletions :: !Int + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Stats where rnf = genericRnf +instance Binary Stats + +data Commit = Commit + { commitSha :: !(Name Commit) + , commitParents :: !(Vector Tree) + , commitUrl :: !URL + , commitGitCommit :: !GitCommit + , commitCommitter :: !(Maybe SimpleUser) + , commitAuthor :: !(Maybe SimpleUser) + , commitFiles :: !(Vector File) + , commitStats :: !(Maybe Stats) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Commit where rnf = genericRnf +instance Binary Commit + +data Tree = Tree + { treeSha :: !(Name Tree) + , treeUrl :: !URL + , treeGitTrees :: !(Vector GitTree) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Tree where rnf = genericRnf +instance Binary Tree + +data GitTree = GitTree + { gitTreeType :: !Text + , gitTreeSha :: !(Name GitTree) + -- Can be empty for submodule + , gitTreeUrl :: !(Maybe URL) + , gitTreeSize :: !(Maybe Int) + , gitTreePath :: !Text + , gitTreeMode :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GitTree where rnf = genericRnf +instance Binary GitTree + +data GitCommit = GitCommit + { gitCommitMessage :: !Text + , gitCommitUrl :: !URL + , gitCommitCommitter :: !GitUser + , gitCommitAuthor :: !GitUser + , gitCommitTree :: !Tree + , gitCommitSha :: !(Maybe (Name GitCommit)) + , gitCommitParents :: !(Vector Tree) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GitCommit where rnf = genericRnf +instance Binary GitCommit + +data Blob = Blob + { blobUrl :: !URL + , blobEncoding :: !Text + , blobContent :: !Text + , blobSha :: !(Name Blob) + , blobSize :: !Int + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Blob where rnf = genericRnf +instance Binary Blob + +data Tag = Tag + { tagName :: !Text + , tagZipballUrl :: !URL + , tagTarballUrl :: !URL + , tagCommit :: !BranchCommit + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Tag where rnf = genericRnf +instance Binary Tag + +data Branch = Branch + { branchName :: !Text + , branchCommit :: !BranchCommit + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Branch where rnf = genericRnf + +data BranchCommit = BranchCommit + { branchCommitSha :: !Text + , branchCommitUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData BranchCommit where rnf = genericRnf +instance Binary BranchCommit + +data Diff = Diff + { diffStatus :: !Text + , diffBehindBy :: !Int + , diffPatchUrl :: !URL + , diffUrl :: !URL + , diffBaseCommit :: !Commit + , diffCommits :: !(Vector Commit) + , diffTotalCommits :: !Int + , diffHtmlUrl :: !URL + , diffFiles :: !(Vector File) + , diffAheadBy :: !Int + , diffDiffUrl :: !URL + , diffPermalinkUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Diff where rnf = genericRnf +instance Binary Diff + +data NewGitReference = NewGitReference + { newGitReferenceRef :: !Text + , newGitReferenceSha :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewGitReference where rnf = genericRnf +instance Binary NewGitReference + +data GitReference = GitReference + { gitReferenceObject :: !GitObject + , gitReferenceUrl :: !URL + , gitReferenceRef :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GitReference where rnf = genericRnf +instance Binary GitReference + +data GitObject = GitObject + { gitObjectType :: !Text + , gitObjectSha :: !Text + , gitObjectUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GitObject where rnf = genericRnf +instance Binary GitObject + +data GitUser = GitUser + { gitUserName :: !Text + , gitUserEmail :: !Text + , gitUserDate :: !UTCTime + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData GitUser where rnf = genericRnf +instance Binary GitUser + +data File = File + { fileBlobUrl :: !URL + , fileStatus :: !Text + , fileRawUrl :: !URL + , fileAdditions :: !Int + , fileSha :: !Text + , fileChanges :: !Int + , filePatch :: !(Maybe Text) + , fileFilename :: !Text + , fileDeletions :: !Int + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData File where rnf = genericRnf +instance Binary File + +-- JSON instances + +instance FromJSON Stats where + parseJSON = withObject "Stats" $ \o -> Stats + <$> o .: "additions" + <*> o .: "total" + <*> o .: "deletions" + +instance FromJSON Commit where + parseJSON = withObject "Commit" $ \o -> Commit + <$> o .: "sha" + <*> o .: "parents" + <*> o .: "url" + <*> o .: "commit" + <*> o .:? "committer" + <*> o .:? "author" + <*> o .:? "files" .!= V.empty + <*> o .:? "stats" + +instance FromJSON Tree where + parseJSON = withObject "Tree" $ \o -> Tree + <$> o .: "sha" + <*> o .: "url" + <*> o .:? "tree" .!= V.empty + +instance FromJSON GitTree where + parseJSON = withObject "GitTree" $ \o -> GitTree + <$> o .: "type" + <*> o .: "sha" + <*> o .:? "url" + <*> o .:? "size" + <*> o .: "path" + <*> o .: "mode" + +instance FromJSON GitCommit where + parseJSON = withObject "GitCommit" $ \o -> GitCommit + <$> o .: "message" + <*> o .: "url" + <*> o .: "committer" + <*> o .: "author" + <*> o .: "tree" + <*> o .:? "sha" + <*> o .:? "parents" .!= V.empty + +instance FromJSON GitUser where + parseJSON = withObject "GitUser" $ \o -> GitUser + <$> o .: "name" + <*> o .: "email" + <*> o .: "date" + +instance FromJSON File where + parseJSON = withObject "File" $ \o -> File + <$> o .: "blob_url" + <*> o .: "status" + <*> o .: "raw_url" + <*> o .: "additions" + <*> o .: "sha" + <*> o .: "changes" + <*> o .:? "patch" + <*> o .: "filename" + <*> o .: "deletions" + +instance ToJSON NewGitReference where + toJSON (NewGitReference r s) = object [ "ref" .= r, "sha" .= s ] + +instance FromJSON GitReference where + parseJSON = withObject "GitReference" $ \o -> GitReference + <$> o .: "object" + <*> o .: "url" + <*> o .: "ref" + +instance FromJSON GitObject where + parseJSON = withObject "GitObject" $ \o -> GitObject + <$> o .: "type" + <*> o .: "sha" + <*> o .: "url" + +instance FromJSON Diff where + parseJSON = withObject "Diff" $ \o -> Diff + <$> o .: "status" + <*> o .: "behind_by" + <*> o .: "patch_url" + <*> o .: "url" + <*> o .: "base_commit" + <*> o .:? "commits" .!= V.empty + <*> o .: "total_commits" + <*> o .: "html_url" + <*> o .:? "files" .!= V.empty + <*> o .: "ahead_by" + <*> o .: "diff_url" + <*> o .: "permalink_url" + +instance FromJSON Blob where + parseJSON = withObject "Blob" $ \o -> Blob + <$> o .: "url" + <*> o .: "encoding" + <*> o .: "content" + <*> o .: "sha" + <*> o .: "size" + +instance FromJSON Tag where + parseJSON = withObject "Tag" $ \o -> Tag + <$> o .: "name" + <*> o .: "zipball_url" + <*> o .: "tarball_url" + <*> o .: "commit" + +instance FromJSON Branch where + parseJSON = withObject "Branch" $ \o -> Branch + <$> o .: "name" + <*> o .: "commit" + +instance FromJSON BranchCommit where + parseJSON = withObject "BranchCommit" $ \o -> BranchCommit + <$> o .: "sha" + <*> o .: "url" diff --git a/src/GitHub/Data/Id.hs b/src/GitHub/Data/Id.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Id.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Id ( + Id(..), + mkId, + untagId, + ) where + +import GitHub.Internal.Prelude +import Prelude () + +-- | Numeric identifier. +newtype Id entity = Id Int + deriving (Eq, Ord, Show, Generic, Typeable, Data) + +-- | Smart constructor for 'Id'. +mkId :: proxy entity -> Int -> Id entity +mkId _ = Id + +untagId :: Id entity -> Int +untagId (Id name) = name + +instance Hashable (Id entity) +instance Binary (Id entity) + +instance NFData (Id entity) where + rnf (Id s) = rnf s + +instance FromJSON (Id entity) where + parseJSON = fmap Id . parseJSON + +instance ToJSON (Id entity) where + toJSON = toJSON . untagId diff --git a/src/GitHub/Data/Issues.hs b/src/GitHub/Data/Issues.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Issues.hs @@ -0,0 +1,203 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Issues where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Milestone (Milestone) +import GitHub.Data.Name (Name) +import GitHub.Data.Options (IssueState) +import GitHub.Data.PullRequests +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Issue = Issue + { issueClosedAt :: !(Maybe UTCTime) + , issueUpdatedAt :: !UTCTime + , issueEventsUrl :: !URL + , issueHtmlUrl :: !(Maybe URL) + , issueClosedBy :: !(Maybe SimpleUser) + , issueLabels :: (Vector IssueLabel) + , issueNumber :: !Int + , issueAssignees :: !(Vector SimpleUser) + , issueUser :: !SimpleUser + , issueTitle :: !Text + , issuePullRequest :: !(Maybe PullRequestReference) + , issueUrl :: !URL + , issueCreatedAt :: !UTCTime + , issueBody :: !(Maybe Text) + , issueState :: !IssueState + , issueId :: !(Id Issue) + , issueComments :: !Int + , issueMilestone :: !(Maybe Milestone) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Issue where rnf = genericRnf +instance Binary Issue + +data NewIssue = NewIssue + { newIssueTitle :: !Text + , newIssueBody :: !(Maybe Text) + , newIssueAssignee :: !(Maybe Text) + , newIssueMilestone :: !(Maybe (Id Milestone)) + , newIssueLabels :: !(Maybe (Vector (Name IssueLabel))) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewIssue where rnf = genericRnf +instance Binary NewIssue + +data EditIssue = EditIssue + { editIssueTitle :: !(Maybe Text) + , editIssueBody :: !(Maybe Text) + , editIssueAssignee :: !(Maybe (Name User)) + , editIssueState :: !(Maybe IssueState) + , editIssueMilestone :: !(Maybe (Id Milestone)) + , editIssueLabels :: !(Maybe (Vector (Name IssueLabel))) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData EditIssue where rnf = genericRnf +instance Binary EditIssue + +data IssueComment = IssueComment + { issueCommentUpdatedAt :: !UTCTime + , issueCommentUser :: !SimpleUser + , issueCommentUrl :: !URL + , issueCommentHtmlUrl :: !URL + , issueCommentCreatedAt :: !UTCTime + , issueCommentBody :: !Text + , issueCommentId :: !Int + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData IssueComment where rnf = genericRnf +instance Binary IssueComment + +data EventType + = Mentioned -- ^ The actor was @mentioned in an issue body. + | Subscribed -- ^ The actor subscribed to receive notifications for an issue. + | Unsubscribed -- ^ The issue was unsubscribed from by the actor. + | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened. + | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged. + | Assigned -- ^ The issue was assigned to the actor. + | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax. + | Reopened -- ^ The issue was reopened by the actor. + | ActorUnassigned -- ^ The issue was unassigned to the actor + | Labeled -- ^ A label was added to the issue. + | Unlabeled -- ^ A label was removed from the issue. + | Milestoned -- ^ The issue was added to a milestone. + | Demilestoned -- ^ The issue was removed from a milestone. + | Renamed -- ^ The issue title was changed. + | Locked -- ^ The issue was locked by the actor. + | Unlocked -- ^ The issue was unlocked by the actor. + | HeadRefDeleted -- ^ The pull request’s branch was deleted. + | HeadRefRestored -- ^ The pull request’s branch was restored. + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData EventType where rnf = genericRnf +instance Binary EventType + +-- | Issue event +data IssueEvent = IssueEvent + { issueEventActor :: !SimpleUser + , issueEventType :: !EventType + , issueEventCommitId :: !(Maybe Text) + , issueEventUrl :: !URL + , issueEventCreatedAt :: !UTCTime + , issueEventId :: !Int + , issueEventIssue :: !(Maybe Issue) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData IssueEvent where rnf = genericRnf +instance Binary IssueEvent + +instance FromJSON IssueEvent where + parseJSON = withObject "Event" $ \o -> IssueEvent + <$> o .: "actor" + <*> o .: "event" + <*> o .:? "commit_id" + <*> o .: "url" + <*> o .: "created_at" + <*> o .: "id" + <*> o .:? "issue" + +instance FromJSON EventType where + parseJSON (String "closed") = pure Closed + parseJSON (String "reopened") = pure Reopened + parseJSON (String "subscribed") = pure Subscribed + parseJSON (String "merged") = pure Merged + parseJSON (String "referenced") = pure Referenced + parseJSON (String "mentioned") = pure Mentioned + parseJSON (String "assigned") = pure Assigned + parseJSON (String "unsubscribed") = pure Unsubscribed + parseJSON (String "unassigned") = pure ActorUnassigned + parseJSON (String "labeled") = pure Labeled + parseJSON (String "unlabeled") = pure Unlabeled + parseJSON (String "milestoned") = pure Milestoned + parseJSON (String "demilestoned") = pure Demilestoned + parseJSON (String "renamed") = pure Renamed + parseJSON (String "locked") = pure Locked + parseJSON (String "unlocked") = pure Unlocked + parseJSON (String "head_ref_deleted") = pure HeadRefDeleted + parseJSON (String "head_ref_restored") = pure HeadRefRestored + parseJSON _ = fail "Could not build an EventType" + +instance FromJSON IssueComment where + parseJSON = withObject "IssueComment" $ \o -> IssueComment + <$> o .: "updated_at" + <*> o .: "user" + <*> o .: "url" + <*> o .: "html_url" + <*> o .: "created_at" + <*> o .: "body" + <*> o .: "id" + +instance FromJSON Issue where + parseJSON = withObject "Issue" $ \o -> Issue + <$> o .:? "closed_at" + <*> o .: "updated_at" + <*> o .: "events_url" + <*> o .: "html_url" + <*> o .:? "closed_by" + <*> o .: "labels" + <*> o .: "number" + <*> o .: "assignees" + <*> o .: "user" + <*> o .: "title" + <*> o .:? "pull_request" + <*> o .: "url" + <*> o .: "created_at" + <*> o .: "body" + <*> o .: "state" + <*> o .: "id" + <*> o .: "comments" + <*> o .:? "milestone" + +instance ToJSON NewIssue where + toJSON (NewIssue t b a m ls) = object + [ "title" .= t + , "body" .= b + , "assignee" .= a + , "milestone" .= m + , "labels" .= ls + ] + +instance ToJSON EditIssue where + toJSON (EditIssue t b a s m ls) = object $ filter notNull $ + [ "title" .= t + , "body" .= b + , "assignee" .= a + , "state" .= s + , "milestone" .= m + , "labels" .= ls + ] + where + notNull (_, Null) = False + notNull (_, _) = True diff --git a/src/GitHub/Data/Milestone.hs b/src/GitHub/Data/Milestone.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Milestone.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Milestone where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Milestone = Milestone + { milestoneCreator :: !SimpleUser + , milestoneDueOn :: !(Maybe UTCTime) + , milestoneOpenIssues :: !Int + , milestoneNumber :: !(Id Milestone) + , milestoneClosedIssues :: !Int + , milestoneDescription :: !(Maybe Text) + , milestoneTitle :: !Text + , milestoneUrl :: !URL + , milestoneCreatedAt :: !UTCTime + , milestoneState :: !Text + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Milestone where rnf = genericRnf +instance Binary Milestone + +instance FromJSON Milestone where + parseJSON = withObject "Milestone" $ \o -> Milestone + <$> o .: "creator" + <*> o .: "due_on" + <*> o .: "open_issues" + <*> o .: "number" + <*> o .: "closed_issues" + <*> o .: "description" + <*> o .: "title" + <*> o .: "url" + <*> o .: "created_at" + <*> o .: "state" diff --git a/src/GitHub/Data/Name.hs b/src/GitHub/Data/Name.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Name.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Name ( + Name(..), + mkName, + untagName, + ) where + +import Prelude () +import GitHub.Internal.Prelude + +#if MIN_VERSION_aeson(1,0,0) +import Data.Aeson.Types + (FromJSONKey (..), ToJSONKey (..), fromJSONKeyCoerce, toJSONKeyText) +#endif + +newtype Name entity = N Text + deriving (Eq, Ord, Show, Generic, Typeable, Data) + +-- | Smart constructor for 'Name' +mkName :: proxy entity -> Text -> Name entity +mkName _ = N + +untagName :: Name entity -> Text +untagName (N name) = name + +instance Hashable (Name entity) +instance Binary (Name entity) + +instance NFData (Name entity) where + rnf (N s) = rnf s + +instance FromJSON (Name entity) where + parseJSON = fmap N . parseJSON + +instance ToJSON (Name entity) where + toJSON = toJSON . untagName + +instance IsString (Name entity) where + fromString = N . fromString + +#if MIN_VERSION_aeson(1,0,0) +-- | @since 0.15.0.0 +instance ToJSONKey (Name entity) where + toJSONKey = toJSONKeyText untagName + +-- | @since 0.15.0.0 +instance FromJSONKey (Name entity) where + fromJSONKey = fromJSONKeyCoerce +#endif diff --git a/src/GitHub/Data/Options.hs b/src/GitHub/Data/Options.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Options.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- Module with modifiers for pull requests' and issues' listings. +module GitHub.Data.Options ( + -- * Common modifiers + stateOpen, + stateClosed, + stateAll, + sortAscending, + sortDescending, + sortByCreated, + sortByUpdated, + -- * Pull Requests + PullRequestMod, + prModToQueryString, + optionsBase, + optionsNoBase, + optionsHead, + optionsNoHead, + sortByPopularity, + sortByLongRunning, + -- * Issues + IssueMod, + issueModToQueryString, + sortByComments, + optionsLabels, + optionsSince, + optionsSinceAll, + optionsAssignedIssues, + optionsCreatedIssues, + optionsMentionedIssues, + optionsSubscribedIssues, + optionsAllIssues, + -- * Repo issues + IssueRepoMod, + issueRepoModToQueryString, + optionsIrrelevantMilestone, + optionsAnyMilestone, + optionsNoMilestone, + optionsIrrelevantAssignee, + optionsAnyAssignee, + optionsNoAssignee, + -- * Data + IssueState (..), + MergeableState (..), + -- * Internal + HasState, + HasDirection, + HasCreatedUpdated, + HasComments, + HasLabels, + HasSince, + ) where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id, untagId) +import GitHub.Data.Milestone (Milestone) +import GitHub.Data.Name (Name, untagName) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +------------------------------------------------------------------------------- +-- Data +------------------------------------------------------------------------------- + +-- | 'GitHub.Data.Issues.Issue' or 'GitHub.Data.PullRequests.PullRequest' state +data IssueState + = StateOpen + | StateClosed + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance ToJSON IssueState where + toJSON StateOpen = String "open" + toJSON StateClosed = String "closed" + +instance FromJSON IssueState where + parseJSON (String "open") = pure StateOpen + parseJSON (String "closed") = pure StateClosed + parseJSON v = typeMismatch "IssueState" v + +instance NFData IssueState where rnf = genericRnf +instance Binary IssueState + +-- | 'GitHub.Data.PullRequests.PullRequest' mergeable_state +data MergeableState + = StateUnknown + | StateClean + | StateDirty + | StateUnstable + | StateBlocked + | StateBehind + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance ToJSON MergeableState where + toJSON StateUnknown = String "unknown" + toJSON StateClean = String "clean" + toJSON StateDirty = String "dirty" + toJSON StateUnstable = String "unstable" + toJSON StateBlocked = String "blocked" + toJSON StateBehind = String "behind" + +instance FromJSON MergeableState where + parseJSON (String "unknown") = pure StateUnknown + parseJSON (String "clean") = pure StateClean + parseJSON (String "dirty") = pure StateDirty + parseJSON (String "unstable") = pure StateUnstable + parseJSON (String "blocked") = pure StateBlocked + parseJSON (String "behind") = pure StateBehind + parseJSON v = typeMismatch "MergeableState" v + +instance NFData MergeableState where rnf = genericRnf +instance Binary MergeableState + +data SortDirection + = SortAscending + | SortDescending + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData SortDirection where rnf = genericRnf +instance Binary SortDirection + +-- PR + +data SortPR + = SortPRCreated + | SortPRUpdated + | SortPRPopularity + | SortPRLongRunning + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData SortPR where rnf = genericRnf +instance Binary SortPR + +-- Issue +data IssueFilter + = IssueFilterAssigned + | IssueFilterCreated + | IssueFilterMentioned + | IssueFilterSubscribed + | IssueFilterAll + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData IssueFilter where rnf = genericRnf +instance Binary IssueFilter + +data SortIssue + = SortIssueCreated + | SortIssueUpdated + | SortIssueComments + deriving + (Eq, Ord, Show, Enum, Bounded, Generic, Typeable, Data) + +instance NFData SortIssue where rnf = genericRnf +instance Binary SortIssue + +data FilterBy a + = FilterAny + | FilterNone + | FilterBy a + | FilterNotSpecified + -- ^ e.g. for milestones "any" means "any milestone". + -- I.e. won't show issues without mileston specified + deriving + (Eq, Ord, Show, Generic, Typeable, Data) + +------------------------------------------------------------------------------- +-- Classes +------------------------------------------------------------------------------- + +class HasState mod where + state :: Maybe IssueState -> mod + +stateOpen :: HasState mod => mod +stateOpen = state (Just StateOpen) + +stateClosed :: HasState mod => mod +stateClosed = state (Just StateClosed) + +stateAll :: HasState mod => mod +stateAll = state Nothing + +instance HasState PullRequestMod where + state s = PRMod $ \opts -> + opts { pullRequestOptionsState = s } + +instance HasState IssueMod where + state s = IssueMod $ \opts -> + opts { issueOptionsState = s } + +instance HasState IssueRepoMod where + state s = IssueRepoMod $ \opts -> + opts { issueRepoOptionsState = s } + + +class HasDirection mod where + sortDir :: SortDirection -> mod + +sortAscending :: HasDirection mod => mod +sortAscending = sortDir SortAscending + +sortDescending :: HasDirection mod => mod +sortDescending = sortDir SortDescending + +instance HasDirection PullRequestMod where + sortDir x = PRMod $ \opts -> + opts { pullRequestOptionsDirection = x } + +instance HasDirection IssueMod where + sortDir x = IssueMod $ \opts -> + opts { issueOptionsDirection = x } + +instance HasDirection IssueRepoMod where + sortDir x = IssueRepoMod $ \opts -> + opts { issueRepoOptionsDirection = x } + + +class HasCreatedUpdated mod where + sortByCreated :: mod + sortByUpdated :: mod + +instance HasCreatedUpdated PullRequestMod where + sortByCreated = PRMod $ \opts -> + opts { pullRequestOptionsSort = SortPRCreated } + sortByUpdated = PRMod $ \opts -> + opts { pullRequestOptionsSort = SortPRUpdated } + +instance HasCreatedUpdated IssueMod where + sortByCreated = IssueMod $ \opts -> + opts { issueOptionsSort = SortIssueCreated } + sortByUpdated = IssueMod $ \opts -> + opts { issueOptionsSort = SortIssueUpdated } + +instance HasCreatedUpdated IssueRepoMod where + sortByCreated = IssueRepoMod $ \opts -> + opts { issueRepoOptionsSort = SortIssueCreated } + sortByUpdated = IssueRepoMod $ \opts -> + opts { issueRepoOptionsSort = SortIssueUpdated } + +------------------------------------------------------------------------------- +-- Pull Request +------------------------------------------------------------------------------- + +-- | See . +data PullRequestOptions = PullRequestOptions + { pullRequestOptionsState :: !(Maybe IssueState) + , pullRequestOptionsHead :: !(Maybe Text) + , pullRequestOptionsBase :: !(Maybe Text) + , pullRequestOptionsSort :: !SortPR + , pullRequestOptionsDirection :: !SortDirection + } + deriving + (Eq, Ord, Show, Generic, Typeable, Data) + +defaultPullRequestOptions :: PullRequestOptions +defaultPullRequestOptions = PullRequestOptions + { pullRequestOptionsState = Just StateOpen + , pullRequestOptionsHead = Nothing + , pullRequestOptionsBase = Nothing + , pullRequestOptionsSort = SortPRCreated + , pullRequestOptionsDirection = SortDescending + } + +-- | See . +newtype PullRequestMod = PRMod (PullRequestOptions -> PullRequestOptions) + +instance Semigroup PullRequestMod where + PRMod f <> PRMod g = PRMod (g . f) + +instance Monoid PullRequestMod where + mempty = PRMod id + mappend = (<>) + +toPullRequestOptions :: PullRequestMod -> PullRequestOptions +toPullRequestOptions (PRMod f) = f defaultPullRequestOptions + +prModToQueryString :: PullRequestMod -> QueryString +prModToQueryString = pullRequestOptionsToQueryString . toPullRequestOptions + +pullRequestOptionsToQueryString :: PullRequestOptions -> QueryString +pullRequestOptionsToQueryString (PullRequestOptions st head_ base sort dir) = + [ mk "state" state' + , mk "sort" sort' + , mk "direction" direction' + ] ++ catMaybes + [ mk "head" <$> head' + , mk "base" <$> base' + ] + where + mk k v = (k, Just v) + state' = case st of + Nothing -> "all" + Just StateOpen -> "open" + Just StateClosed -> "closed" + sort' = case sort of + SortPRCreated -> "created" + SortPRUpdated -> "updated" + SortPRPopularity -> "popularity" + SortPRLongRunning -> "long-running" + direction' = case dir of + SortDescending -> "desc" + SortAscending -> "asc" + head' = fmap TE.encodeUtf8 head_ + base' = fmap TE.encodeUtf8 base + +------------------------------------------------------------------------------- +-- Pull request modifiers +------------------------------------------------------------------------------- + +optionsBase :: Text -> PullRequestMod +optionsBase x = PRMod $ \opts -> + opts { pullRequestOptionsBase = Just x } + +optionsNoBase :: PullRequestMod +optionsNoBase = PRMod $ \opts -> + opts { pullRequestOptionsBase = Nothing } + +optionsHead :: Text -> PullRequestMod +optionsHead x = PRMod $ \opts -> + opts { pullRequestOptionsHead = Just x } + +optionsNoHead :: PullRequestMod +optionsNoHead = PRMod $ \opts -> + opts { pullRequestOptionsHead = Nothing } + +sortByPopularity :: PullRequestMod +sortByPopularity = PRMod $ \opts -> + opts { pullRequestOptionsSort = SortPRPopularity } + +sortByLongRunning :: PullRequestMod +sortByLongRunning = PRMod $ \opts -> + opts { pullRequestOptionsSort = SortPRLongRunning } + +------------------------------------------------------------------------------- +-- Issues +------------------------------------------------------------------------------- + +-- | See . +data IssueOptions = IssueOptions + { issueOptionsFilter :: !IssueFilter + , issueOptionsState :: !(Maybe IssueState) + , issueOptionsLabels :: ![Name IssueLabel] -- TODO: change to newtype + , issueOptionsSort :: !SortIssue + , issueOptionsDirection :: !SortDirection + , issueOptionsSince :: !(Maybe UTCTime) + } + deriving + (Eq, Ord, Show, Generic, Typeable, Data) + +defaultIssueOptions :: IssueOptions +defaultIssueOptions = IssueOptions + { issueOptionsFilter = IssueFilterAssigned + , issueOptionsState = Just StateOpen + , issueOptionsLabels = [] + , issueOptionsSort = SortIssueCreated + , issueOptionsDirection = SortDescending + , issueOptionsSince = Nothing + } + +-- | See . +newtype IssueMod = IssueMod (IssueOptions -> IssueOptions) + +instance Semigroup IssueMod where + IssueMod f <> IssueMod g = IssueMod (g . f) + +instance Monoid IssueMod where + mempty = IssueMod id + mappend = (<>) + +toIssueOptions :: IssueMod -> IssueOptions +toIssueOptions (IssueMod f) = f defaultIssueOptions + +issueModToQueryString :: IssueMod -> QueryString +issueModToQueryString = issueOptionsToQueryString . toIssueOptions + +issueOptionsToQueryString :: IssueOptions -> QueryString +issueOptionsToQueryString (IssueOptions filt st labels sort dir since) = + [ mk "state" state' + , mk "sort" sort' + , mk "direction" direction' + , mk "filter" filt' + ] ++ catMaybes + [ mk "labels" <$> labels' + , mk "since" <$> since' + ] + where + mk k v = (k, Just v) + filt' = case filt of + IssueFilterAssigned -> "assigned" + IssueFilterCreated -> "created" + IssueFilterMentioned -> "mentioned" + IssueFilterSubscribed -> "subscribed" + IssueFilterAll -> "all" + state' = case st of + Nothing -> "all" + Just StateOpen -> "open" + Just StateClosed -> "closed" + sort' = case sort of + SortIssueCreated -> "created" + SortIssueUpdated -> "updated" + SortIssueComments -> "comments" + direction' = case dir of + SortDescending -> "desc" + SortAscending -> "asc" + + since' = fmap (TE.encodeUtf8 . T.pack . show) since + labels' = TE.encodeUtf8 . T.intercalate "," . fmap untagName <$> nullToNothing labels + +nullToNothing :: Foldable f => f a -> Maybe (f a) +nullToNothing xs + | null xs = Nothing + | otherwise = Just xs + +------------------------------------------------------------------------------- +-- Issues modifiers +------------------------------------------------------------------------------- + +class HasComments mod where + sortByComments :: mod + +instance HasComments IssueMod where + sortByComments = IssueMod $ \opts -> + opts { issueOptionsSort = SortIssueComments } + +instance HasComments IssueRepoMod where + sortByComments = IssueRepoMod $ \opts -> + opts { issueRepoOptionsSort = SortIssueComments } + + +class HasLabels mod where + optionsLabels :: Foldable f => f (Name IssueLabel) -> mod + +instance HasLabels IssueMod where + optionsLabels lbls = IssueMod $ \opts -> + opts { issueOptionsLabels = toList lbls } + +instance HasLabels IssueRepoMod where + optionsLabels lbls = IssueRepoMod $ \opts -> + opts { issueRepoOptionsLabels = toList lbls } + + +class HasSince mod where + optionsSince :: UTCTime -> mod + optionsSinceAll :: mod + +instance HasSince IssueMod where + optionsSince since = IssueMod $ \opts -> + opts { issueOptionsSince = Just since } + optionsSinceAll = IssueMod $ \opts -> + opts { issueOptionsSince = Nothing } + +instance HasSince IssueRepoMod where + optionsSince since = IssueRepoMod $ \opts -> + opts { issueRepoOptionsSince = Just since } + optionsSinceAll = IssueRepoMod $ \opts -> + opts { issueRepoOptionsSince = Nothing } + +------------------------------------------------------------------------------- +-- Only issues modifiers +------------------------------------------------------------------------------- + +optionsAssignedIssues, optionsCreatedIssues, optionsMentionedIssues, + optionsSubscribedIssues, optionsAllIssues :: IssueMod +optionsAssignedIssues = issueFilter IssueFilterAssigned +optionsCreatedIssues = issueFilter IssueFilterCreated +optionsMentionedIssues = issueFilter IssueFilterMentioned +optionsSubscribedIssues = issueFilter IssueFilterSubscribed +optionsAllIssues = issueFilter IssueFilterAll + +issueFilter :: IssueFilter -> IssueMod +issueFilter f = IssueMod $ \opts -> + opts { issueOptionsFilter = f } + +------------------------------------------------------------------------------- +-- Issues repo +------------------------------------------------------------------------------- + +data IssueRepoOptions = IssueRepoOptions + { issueRepoOptionsMilestone :: !(FilterBy (Id Milestone)) + , issueRepoOptionsState :: !(Maybe IssueState) + , issueRepoOptionsAssignee :: !(FilterBy (Name User)) + , issueRepoOptionsCreator :: !(Maybe (Name User)) + , issueRepoOptionsMentioned :: !(Maybe (Name User)) + , issueRepoOptionsLabels :: ![Name IssueLabel] + , issueRepoOptionsSort :: !SortIssue + , issueRepoOptionsDirection :: !SortDirection + , issueRepoOptionsSince :: !(Maybe UTCTime) + } + deriving + (Eq, Ord, Show, Generic, Typeable, Data) + +defaultIssueRepoOptions :: IssueRepoOptions +defaultIssueRepoOptions = IssueRepoOptions + { issueRepoOptionsMilestone = FilterNotSpecified + , issueRepoOptionsState = (Just StateOpen) + , issueRepoOptionsAssignee = FilterNotSpecified + , issueRepoOptionsCreator = Nothing + , issueRepoOptionsMentioned = Nothing + , issueRepoOptionsLabels = [] + , issueRepoOptionsSort = SortIssueCreated + , issueRepoOptionsDirection = SortDescending + , issueRepoOptionsSince = Nothing + } + +-- | See . +newtype IssueRepoMod = IssueRepoMod (IssueRepoOptions -> IssueRepoOptions) + +instance Semigroup IssueRepoMod where + IssueRepoMod f <> IssueRepoMod g = IssueRepoMod (g . f) + +instance Monoid IssueRepoMod where + mempty = IssueRepoMod id + mappend = (<>) + +toIssueRepoOptions :: IssueRepoMod -> IssueRepoOptions +toIssueRepoOptions (IssueRepoMod f) = f defaultIssueRepoOptions + +issueRepoModToQueryString :: IssueRepoMod -> QueryString +issueRepoModToQueryString = issueRepoOptionsToQueryString . toIssueRepoOptions + +issueRepoOptionsToQueryString :: IssueRepoOptions -> QueryString +issueRepoOptionsToQueryString IssueRepoOptions {..} = + [ mk "state" state' + , mk "sort" sort' + , mk "direction" direction' + ] ++ catMaybes + [ mk "milestone" <$> milestone' + , mk "assignee" <$> assignee' + , mk "labels" <$> labels' + , mk "since" <$> since' + , mk "creator" <$> creator' + , mk "mentioned" <$> mentioned' + ] + where + mk k v = (k, Just v) + filt f x = case x of + FilterAny -> Just "*" + FilterNone -> Just "none" + FilterBy x' -> Just $ TE.encodeUtf8 $ f x' + FilterNotSpecified -> Nothing + + milestone' = filt (T.pack . show . untagId) issueRepoOptionsMilestone + assignee' = filt untagName issueRepoOptionsAssignee + + state' = case issueRepoOptionsState of + Nothing -> "all" + Just StateOpen -> "open" + Just StateClosed -> "closed" + sort' = case issueRepoOptionsSort of + SortIssueCreated -> "created" + SortIssueUpdated -> "updated" + SortIssueComments -> "comments" + direction' = case issueRepoOptionsDirection of + SortDescending -> "desc" + SortAscending -> "asc" + + since' = TE.encodeUtf8 . T.pack . show <$> issueRepoOptionsSince + labels' = TE.encodeUtf8 . T.intercalate "," . fmap untagName <$> nullToNothing issueRepoOptionsLabels + creator' = TE.encodeUtf8 . untagName <$> issueRepoOptionsCreator + mentioned' = TE.encodeUtf8 . untagName <$> issueRepoOptionsMentioned + +------------------------------------------------------------------------------- +-- Issues repo modifiers +------------------------------------------------------------------------------- + +-- | Don't care about milestones. +-- +-- 'optionsAnyMilestone' means there should be some milestone, but it can be any. +-- +-- See +optionsIrrelevantMilestone :: IssueRepoMod +optionsIrrelevantMilestone = IssueRepoMod $ \opts -> + opts { issueRepoOptionsMilestone = FilterNotSpecified } + +optionsAnyMilestone :: IssueRepoMod +optionsAnyMilestone = IssueRepoMod $ \opts -> + opts { issueRepoOptionsMilestone = FilterAny } + +optionsNoMilestone :: IssueRepoMod +optionsNoMilestone = IssueRepoMod $ \opts -> + opts { issueRepoOptionsMilestone = FilterNone } + +optionsIrrelevantAssignee :: IssueRepoMod +optionsIrrelevantAssignee = IssueRepoMod $ \opts -> + opts { issueRepoOptionsAssignee = FilterNotSpecified } + +optionsAnyAssignee :: IssueRepoMod +optionsAnyAssignee = IssueRepoMod $ \opts -> + opts { issueRepoOptionsAssignee = FilterAny } + +optionsNoAssignee :: IssueRepoMod +optionsNoAssignee = IssueRepoMod $ \opts -> + opts { issueRepoOptionsAssignee = FilterNone } diff --git a/src/GitHub/Data/PullRequests.hs b/src/GitHub/Data/PullRequests.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/PullRequests.hs @@ -0,0 +1,328 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.PullRequests ( + SimplePullRequest(..), + PullRequest(..), + EditPullRequest(..), + CreatePullRequest(..), + PullRequestLinks(..), + PullRequestCommit(..), + PullRequestEvent(..), + PullRequestEventType(..), + PullRequestReference(..), + MergeResult(..), + statusMerge, + ) where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Options (IssueState (..), MergeableState (..)) +import GitHub.Data.Repos (Repo) +import GitHub.Data.Request (StatusMap) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.Text as T + +data SimplePullRequest = SimplePullRequest + { simplePullRequestClosedAt :: !(Maybe UTCTime) + , simplePullRequestCreatedAt :: !UTCTime + , simplePullRequestUser :: !SimpleUser + , simplePullRequestPatchUrl :: !URL + , simplePullRequestState :: !IssueState + , simplePullRequestNumber :: !Int + , simplePullRequestHtmlUrl :: !URL + , simplePullRequestUpdatedAt :: !UTCTime + , simplePullRequestBody :: !(Maybe Text) + , simplePullRequestAssignees :: (Vector SimpleUser) + , simplePullRequestRequestedReviewers :: (Vector SimpleUser) + , simplePullRequestIssueUrl :: !URL + , simplePullRequestDiffUrl :: !URL + , simplePullRequestUrl :: !URL + , simplePullRequestLinks :: !PullRequestLinks + , simplePullRequestMergedAt :: !(Maybe UTCTime) + , simplePullRequestTitle :: !Text + , simplePullRequestId :: !(Id PullRequest) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData SimplePullRequest where rnf = genericRnf +instance Binary SimplePullRequest + +data PullRequest = PullRequest + { pullRequestClosedAt :: !(Maybe UTCTime) + , pullRequestCreatedAt :: !UTCTime + , pullRequestUser :: !SimpleUser + , pullRequestPatchUrl :: !URL + , pullRequestState :: !IssueState + , pullRequestNumber :: !Int + , pullRequestHtmlUrl :: !URL + , pullRequestUpdatedAt :: !UTCTime + , pullRequestBody :: !(Maybe Text) + , pullRequestAssignees :: (Vector SimpleUser) + , pullRequestRequestedReviewers :: (Vector SimpleUser) + , pullRequestIssueUrl :: !URL + , pullRequestDiffUrl :: !URL + , pullRequestUrl :: !URL + , pullRequestLinks :: !PullRequestLinks + , pullRequestMergedAt :: !(Maybe UTCTime) + , pullRequestTitle :: !Text + , pullRequestId :: !(Id PullRequest) + , pullRequestMergedBy :: !(Maybe SimpleUser) + , pullRequestChangedFiles :: !Int + , pullRequestHead :: !PullRequestCommit + , pullRequestComments :: !Count + , pullRequestDeletions :: !Count + , pullRequestAdditions :: !Count + , pullRequestReviewComments :: !Count + , pullRequestBase :: !PullRequestCommit + , pullRequestCommits :: !Count + , pullRequestMerged :: !Bool + , pullRequestMergeable :: !(Maybe Bool) + , pullRequestMergeableState :: !MergeableState + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullRequest where rnf = genericRnf +instance Binary PullRequest + +data EditPullRequest = EditPullRequest + { editPullRequestTitle :: !(Maybe Text) + , editPullRequestBody :: !(Maybe Text) + , editPullRequestState :: !(Maybe IssueState) + , editPullRequestBase :: !(Maybe Text) + , editPullRequestMaintainerCanModify + :: !(Maybe Bool) + } + deriving (Show, Generic) + +instance NFData EditPullRequest where rnf = genericRnf +instance Binary EditPullRequest + +data CreatePullRequest + = CreatePullRequest + { createPullRequestTitle :: !Text + , createPullRequestBody :: !Text + , createPullRequestHead :: !Text + , createPullRequestBase :: !Text + } + | CreatePullRequestIssue + { createPullRequestIssueNum :: !Int + , createPullRequestHead :: !Text + , createPullRequestBase :: !Text + } + deriving (Show, Generic) + +instance NFData CreatePullRequest where rnf = genericRnf +instance Binary CreatePullRequest + +data PullRequestLinks = PullRequestLinks + { pullRequestLinksReviewComments :: !URL + , pullRequestLinksComments :: !URL + , pullRequestLinksHtml :: !URL + , pullRequestLinksSelf :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullRequestLinks where rnf = genericRnf +instance Binary PullRequestLinks + +data PullRequestCommit = PullRequestCommit + { pullRequestCommitLabel :: !Text + , pullRequestCommitRef :: !Text + , pullRequestCommitSha :: !Text + , pullRequestCommitUser :: !SimpleUser + , pullRequestCommitRepo :: !(Maybe Repo) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullRequestCommit where rnf = genericRnf +instance Binary PullRequestCommit + +data PullRequestEvent = PullRequestEvent + { pullRequestEventAction :: !PullRequestEventType + , pullRequestEventNumber :: !Int + , pullRequestEventPullRequest :: !PullRequest + , pullRequestRepository :: !Repo + , pullRequestSender :: !SimpleUser + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullRequestEvent where rnf = genericRnf +instance Binary PullRequestEvent + +data PullRequestEventType + = PullRequestOpened + | PullRequestClosed + | PullRequestSynchronized + | PullRequestReopened + | PullRequestAssigned + | PullRequestUnassigned + | PullRequestLabeled + | PullRequestUnlabeled + | PullRequestReviewRequested + | PullRequestReviewRequestRemoved + | PullRequestEdited + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PullRequestEventType where rnf = genericRnf +instance Binary PullRequestEventType + +data PullRequestReference = PullRequestReference + { pullRequestReferenceHtmlUrl :: !(Maybe URL) + , pullRequestReferencePatchUrl :: !(Maybe URL) + , pullRequestReferenceDiffUrl :: !(Maybe URL) + } + deriving (Eq, Ord, Show, Generic, Typeable, Data) + +instance NFData PullRequestReference where rnf = genericRnf +instance Binary PullRequestReference + + +------------------------------------------------------------------------------- +-- JSON instances +------------------------------------------------------------------------------- + +instance FromJSON SimplePullRequest where + parseJSON = withObject "SimplePullRequest" $ \o -> SimplePullRequest + <$> o .:? "closed_at" + <*> o .: "created_at" + <*> o .: "user" + <*> o .: "patch_url" + <*> o .: "state" + <*> o .: "number" + <*> o .: "html_url" + <*> o .: "updated_at" + <*> o .:? "body" + <*> o .: "assignees" + <*> o .:? "requested_reviewers" .!= mempty + <*> o .: "issue_url" + <*> o .: "diff_url" + <*> o .: "url" + <*> o .: "_links" + <*> o .:? "merged_at" + <*> o .: "title" + <*> o .: "id" + +instance ToJSON EditPullRequest where + toJSON (EditPullRequest t b s base mcm) = + object $ filter notNull + [ "title" .= t + , "body" .= b + , "state" .= s + , "base" .= base + , "maintainer_can_modify" + .= mcm + ] + where + notNull (_, Null) = False + notNull (_, _) = True + +instance ToJSON CreatePullRequest where + toJSON (CreatePullRequest t b headPR basePR) = + object [ "title" .= t, "body" .= b, "head" .= headPR, "base" .= basePR ] + toJSON (CreatePullRequestIssue issueNum headPR basePR) = + object [ "issue" .= issueNum, "head" .= headPR, "base" .= basePR] + +instance FromJSON PullRequest where + parseJSON = withObject "PullRequest" $ \o -> PullRequest + <$> o .:? "closed_at" + <*> o .: "created_at" + <*> o .: "user" + <*> o .: "patch_url" + <*> o .: "state" + <*> o .: "number" + <*> o .: "html_url" + <*> o .: "updated_at" + <*> o .:? "body" + <*> o .: "assignees" + <*> o .:? "requested_reviewers" .!= mempty + <*> o .: "issue_url" + <*> o .: "diff_url" + <*> o .: "url" + <*> o .: "_links" + <*> o .:? "merged_at" + <*> o .: "title" + <*> o .: "id" + <*> o .:? "merged_by" + <*> o .: "changed_files" + <*> o .: "head" + <*> o .: "comments" + <*> o .: "deletions" + <*> o .: "additions" + <*> o .: "review_comments" + <*> o .: "base" + <*> o .: "commits" + <*> o .: "merged" + <*> o .:? "mergeable" + <*> o .: "mergeable_state" + +instance FromJSON PullRequestLinks where + parseJSON = withObject "PullRequestLinks" $ \o -> PullRequestLinks + <$> fmap getHref (o .: "review_comments") + <*> fmap getHref (o .: "comments") + <*> fmap getHref (o .: "html") + <*> fmap getHref (o .: "self") + +instance FromJSON PullRequestCommit where + parseJSON = withObject "PullRequestCommit" $ \o -> PullRequestCommit + <$> o .: "label" + <*> o .: "ref" + <*> o .: "sha" + <*> o .: "user" + <*> o .: "repo" + +instance FromJSON PullRequestEvent where + parseJSON = withObject "PullRequestEvent" $ \o -> PullRequestEvent + <$> o .: "action" + <*> o .: "number" + <*> o .: "pull_request" + <*> o .: "repository" + <*> o .: "sender" + +instance FromJSON PullRequestEventType where + parseJSON (String "opened") = pure PullRequestOpened + parseJSON (String "closed") = pure PullRequestClosed + parseJSON (String "synchronize") = pure PullRequestSynchronized + parseJSON (String "reopened") = pure PullRequestReopened + parseJSON (String "assigned") = pure PullRequestAssigned + parseJSON (String "unassigned") = pure PullRequestUnassigned + parseJSON (String "labeled") = pure PullRequestLabeled + parseJSON (String "unlabeled") = pure PullRequestUnlabeled + parseJSON (String "review_requested") = pure PullRequestReviewRequested + parseJSON (String "review_request_removed") = pure PullRequestReviewRequestRemoved + parseJSON (String "edited") = pure PullRequestEdited + parseJSON (String s) = fail $ "Unknown action type " <> T.unpack s + parseJSON v = typeMismatch "Could not build a PullRequestEventType" v + +instance FromJSON PullRequestReference where + parseJSON = withObject "PullRequestReference" $ \o -> PullRequestReference + <$> o .:? "html_url" + <*> o .:? "patch_url" + <*> o .:? "diff_url" + +-- Helpers + +newtype Href a = Href { getHref :: a } + +instance FromJSON a => FromJSON (Href a) where + parseJSON = withObject "href object" $ + \obj -> Href <$> obj .: "href" + +-- | Pull request merge results +data MergeResult + = MergeSuccessful + | MergeCannotPerform + | MergeConflict + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +statusMerge :: StatusMap MergeResult +statusMerge = + [ (200, MergeSuccessful) + , (405, MergeCannotPerform) + , (409, MergeConflict) + ] diff --git a/src/GitHub/Data/Releases.hs b/src/GitHub/Data/Releases.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Releases.hs @@ -0,0 +1,85 @@ +module GitHub.Data.Releases where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Release = Release + { releaseUrl :: !URL + , releaseHtmlUrl :: !URL + , releaseAssetsurl :: !URL + , releaseUploadUrl :: !URL + , releaseTarballUrl :: !URL + , releaseZipballUrl :: !URL + , releaseId :: !(Id Release) + , releaseTagName :: !Text + , releaseTargetCommitish :: !Text + , releaseName :: !Text + , releaseBody :: !Text + , releaseDraft :: !Bool + , releasePrerelease :: !Bool + , releaseCreatedAt :: !UTCTime + , releasePublishedAt :: !(Maybe UTCTime) + , releaseAuthor :: !SimpleUser + , releaseAssets :: !(Vector ReleaseAsset) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON Release where + parseJSON = withObject "Event" $ \o -> Release + <$> o .: "url" + <*> o .: "html_url" + <*> o .: "assets_url" + <*> o .: "upload_url" + <*> o .: "tarball_url" + <*> o .: "zipball_url" + <*> o .: "id" + <*> o .: "tag_name" + <*> o .: "target_commitish" + <*> o .: "name" + <*> o .: "body" + <*> o .: "draft" + <*> o .: "prerelease" + <*> o .: "created_at" + <*> o .:? "published_at" + <*> o .: "author" + <*> o .: "assets" + +instance NFData Release where rnf = genericRnf +instance Binary Release + +data ReleaseAsset = ReleaseAsset + { releaseAssetUrl :: !URL + , releaseAssetBrowserDownloadUrl :: !Text + , releaseAssetId :: !(Id ReleaseAsset) + , releaseAssetName :: !Text + , releaseAssetLabel :: !(Maybe Text) + , releaseAssetState :: !Text + , releaseAssetContentType :: !Text + , releaseAssetSize :: !Int + , releaseAssetDownloadCount :: !Int + , releaseAssetCreatedAt :: !UTCTime + , releaseAssetUpdatedAt :: !UTCTime + , releaseAssetUploader :: !SimpleUser + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON ReleaseAsset where + parseJSON = withObject "Event" $ \o -> ReleaseAsset + <$> o .: "url" + <*> o .: "browser_download_url" + <*> o .: "id" + <*> o .: "name" + <*> o .:? "label" + <*> o .: "state" + <*> o .: "content_type" + <*> o .: "size" + <*> o .: "download_count" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "uploader" + +instance NFData ReleaseAsset where rnf = genericRnf +instance Binary ReleaseAsset diff --git a/src/GitHub/Data/Repos.hs b/src/GitHub/Data/Repos.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Repos.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +#define UNSAFE 1 +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- This module also exports +-- @'FromJSON' a => 'FromJSON' ('HM.HashMap' 'Language' a)@ +-- orphan-ish instance for @aeson < 1@ +module GitHub.Data.Repos where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.Request (IsPathPart (..)) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.HashMap.Strict as HM +#if MIN_VERSION_aeson(1,0,0) +import Data.Aeson.Types (FromJSONKey (..), fromJSONKeyCoerce) +#else +#ifdef UNSAFE +import Unsafe.Coerce (unsafeCoerce) +#endif +#endif + +data Repo = Repo + { repoSshUrl :: !(Maybe URL) + , repoDescription :: !(Maybe Text) + , repoCreatedAt :: !(Maybe UTCTime) + , repoHtmlUrl :: !URL + , repoSvnUrl :: !(Maybe URL) + , repoForks :: !(Maybe Int) + , repoHomepage :: !(Maybe Text) + , repoFork :: !(Maybe Bool) + , repoGitUrl :: !(Maybe URL) + , repoPrivate :: !Bool + , repoArchived :: !Bool + , repoCloneUrl :: !(Maybe URL) + , repoSize :: !(Maybe Int) + , repoUpdatedAt :: !(Maybe UTCTime) + , repoWatchers :: !(Maybe Int) + , repoOwner :: !SimpleOwner + , repoName :: !(Name Repo) + , repoLanguage :: !(Maybe Language) + , repoDefaultBranch :: !(Maybe Text) + , repoPushedAt :: !(Maybe UTCTime) -- ^ this is Nothing for new repositories + , repoId :: !(Id Repo) + , repoUrl :: !URL + , repoOpenIssues :: !(Maybe Int) + , repoHasWiki :: !(Maybe Bool) + , repoHasIssues :: !(Maybe Bool) + , repoHasDownloads :: !(Maybe Bool) + , repoParent :: !(Maybe RepoRef) + , repoSource :: !(Maybe RepoRef) + , repoHooksUrl :: !URL + , repoStargazersCount :: !Int + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Repo where rnf = genericRnf +instance Binary Repo + +data RepoRef = RepoRef + { repoRefOwner :: !SimpleOwner + , repoRefRepo :: !(Name Repo) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoRef where rnf = genericRnf +instance Binary RepoRef + +data NewRepo = NewRepo + { newRepoName :: !(Name Repo) + , newRepoDescription :: !(Maybe Text) + , newRepoHomepage :: !(Maybe Text) + , newRepoPrivate :: !(Maybe Bool) + , newRepoHasIssues :: !(Maybe Bool) + , newRepoHasWiki :: !(Maybe Bool) + , newRepoAutoInit :: !(Maybe Bool) + } deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData NewRepo where rnf = genericRnf +instance Binary NewRepo + +newRepo :: Name Repo -> NewRepo +newRepo name = NewRepo name Nothing Nothing Nothing Nothing Nothing Nothing + +data EditRepo = EditRepo + { editName :: !(Maybe (Name Repo)) + , editDescription :: !(Maybe Text) + , editHomepage :: !(Maybe Text) + , editPublic :: !(Maybe Bool) + , editHasIssues :: !(Maybe Bool) + , editHasWiki :: !(Maybe Bool) + , editHasDownloads :: !(Maybe Bool) + } + deriving (Eq, Ord, Show, Data, Typeable, Generic) + +instance NFData EditRepo where rnf = genericRnf +instance Binary EditRepo + +-- | Filter the list of the user's repos using any of these constructors. +data RepoPublicity + = RepoPublicityAll -- ^ All repos accessible to the user. + | RepoPublicityOwner -- ^ Only repos owned by the user. + | RepoPublicityPublic -- ^ Only public repos. + | RepoPublicityPrivate -- ^ Only private repos. + | RepoPublicityMember -- ^ Only repos to which the user is a member but not an owner. + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) + +-- | The value is the number of bytes of code written in that language. +type Languages = HM.HashMap Language Int + +-- | A programming language. +newtype Language = Language Text + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +getLanguage :: Language -> Text +getLanguage (Language l) = l + +instance NFData Language where rnf = genericRnf +instance Binary Language +instance Hashable Language where + hashWithSalt salt (Language l) = hashWithSalt salt l +instance IsString Language where + fromString = Language . fromString + +data Contributor + -- | An existing Github user, with their number of contributions, avatar + -- URL, login, URL, ID, and Gravatar ID. + = KnownContributor !Int !URL !(Name User) !URL !(Id User) !Text + -- | An unknown Github user with their number of contributions and recorded name. + | AnonymousContributor !Int !Text + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Contributor where rnf = genericRnf +instance Binary Contributor + +contributorToSimpleUser :: Contributor -> Maybe SimpleUser +contributorToSimpleUser (AnonymousContributor _ _) = Nothing +contributorToSimpleUser (KnownContributor _contributions avatarUrl name url uid _gravatarid) = + Just $ SimpleUser uid name avatarUrl url + +-- JSON instances + +instance FromJSON Repo where + parseJSON = withObject "Repo" $ \o -> Repo <$> o .:? "ssh_url" + <*> o .: "description" + <*> o .:? "created_at" + <*> o .: "html_url" + <*> o .:? "svn_url" + <*> o .:? "forks" + <*> o .:? "homepage" + <*> o .: "fork" + <*> o .:? "git_url" + <*> o .: "private" + <*> o .:? "archived" .!= False + <*> o .:? "clone_url" + <*> o .:? "size" + <*> o .:? "updated_at" + <*> o .:? "watchers" + <*> o .: "owner" + <*> o .: "name" + <*> o .:? "language" + <*> o .:? "default_branch" + <*> o .:? "pushed_at" + <*> o .: "id" + <*> o .: "url" + <*> o .:? "open_issues" + <*> o .:? "has_wiki" + <*> o .:? "has_issues" + <*> o .:? "has_downloads" + <*> o .:? "parent" + <*> o .:? "source" + <*> o .: "hooks_url" + <*> o .: "stargazers_count" + +instance ToJSON NewRepo where + toJSON (NewRepo { newRepoName = name + , newRepoDescription = description + , newRepoHomepage = homepage + , newRepoPrivate = private + , newRepoHasIssues = hasIssues + , newRepoHasWiki = hasWiki + , newRepoAutoInit = autoInit + }) = object + [ "name" .= name + , "description" .= description + , "homepage" .= homepage + , "private" .= private + , "has_issues" .= hasIssues + , "has_wiki" .= hasWiki + , "auto_init" .= autoInit + ] + +instance ToJSON EditRepo where + toJSON (EditRepo { editName = name + , editDescription = description + , editHomepage = homepage + , editPublic = public + , editHasIssues = hasIssues + , editHasWiki = hasWiki + , editHasDownloads = hasDownloads + }) = object + [ "name" .= name + , "description" .= description + , "homepage" .= homepage + , "public" .= public + , "has_issues" .= hasIssues + , "has_wiki" .= hasWiki + , "has_downloads" .= hasDownloads + ] + +instance FromJSON RepoRef where + parseJSON = withObject "RepoRef" $ \o -> RepoRef + <$> o .: "owner" + <*> o .: "name" + +instance FromJSON Contributor where + parseJSON = withObject "Contributor" $ \o -> do + t <- o .: "type" + case (t :: Text) of + "Anonymous" -> AnonymousContributor + <$> o .: "contributions" + <*> o .: "name" + _ -> KnownContributor + <$> o .: "contributions" + <*> o .: "avatar_url" + <*> o .: "login" + <*> o .: "url" + <*> o .: "id" + <*> o .: "gravatar_id" + +instance FromJSON Language where + parseJSON = withText "Language" (pure . Language) + +instance ToJSON Language where + toJSON = toJSON . getLanguage + +#if MIN_VERSION_aeson(1,0,0) +instance FromJSONKey Language where + fromJSONKey = fromJSONKeyCoerce +#else +instance FromJSON a => FromJSON (HM.HashMap Language a) where + parseJSON = fmap mapKeyLanguage . parseJSON + where + mapKeyLanguage :: HM.HashMap Text a -> HM.HashMap Language a +#ifdef UNSAFE + mapKeyLanguage = unsafeCoerce +#else + mapKeyLanguage = mapKey Language + mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> HM.HashMap k1 a -> HM.HashMap k2 a + mapKey f = HM.fromList . map (first f) . HM.toList +#endif +#endif + +data ArchiveFormat + = ArchiveFormatTarball -- ^ ".tar.gz" format + | ArchiveFormatZipball -- ^ ".zip" format + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) + +instance IsPathPart ArchiveFormat where + toPathPart af = case af of + ArchiveFormatTarball -> "tarball" + ArchiveFormatZipball -> "zipball" diff --git a/src/GitHub/Data/Request.hs b/src/GitHub/Data/Request.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Request.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Request ( + -- * Request + Request (..), + SimpleRequest (..), + -- * Smart constructors + query, pagedQuery, command, + -- * Auxiliary types + RW(..), + StatusMap, + statusOnlyOk, + CommandMethod(..), + toMethod, + FetchCount(..), + Paths, + IsPathPart(..), + QueryString, + Count, + ) where + +import GitHub.Data.Definitions (Count, QueryString) +import GitHub.Data.Id (Id, untagId) +import GitHub.Data.Name (Name, untagName) +import GitHub.Internal.Prelude + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import qualified Network.HTTP.Types as Types +import qualified Network.HTTP.Types.Method as Method +import Network.URI (URI) +------------------------------------------------------------------------------ +-- Auxillary types +------------------------------------------------------------------------------ + +type Paths = [Text] + +class IsPathPart a where + toPathPart :: a -> Text + +instance IsPathPart (Name a) where + toPathPart = untagName + +instance IsPathPart (Id a) where + toPathPart = T.pack . show . untagId + +-- | Http method of requests with body. +data CommandMethod a where + Post :: CommandMethod a + Patch :: CommandMethod a + Put :: CommandMethod a + Put' :: CommandMethod () + Delete :: CommandMethod () + deriving (Typeable) + +deriving instance Eq (CommandMethod a) +deriving instance Ord (CommandMethod a) + +instance Show (CommandMethod a) where + showsPrec _ Post = showString "Post" + showsPrec _ Patch = showString "Patch" + showsPrec _ Put = showString "Put" + showsPrec _ Put' = showString "Put'" + showsPrec _ Delete = showString "Delete" + +instance Hashable (CommandMethod a) where + hashWithSalt salt Post = hashWithSalt salt (0 :: Int) + hashWithSalt salt Patch = hashWithSalt salt (1 :: Int) + hashWithSalt salt Put = hashWithSalt salt (2 :: Int) + hashWithSalt salt Put' = hashWithSalt salt (3 :: Int) + hashWithSalt salt Delete = hashWithSalt salt (4 :: Int) + +toMethod :: CommandMethod a -> Method.Method +toMethod Post = Method.methodPost +toMethod Patch = Method.methodPatch +toMethod Put = Method.methodPut +toMethod Put' = Method.methodPut +toMethod Delete = Method.methodDelete + +-- | 'PagedQuery' returns just some results, using this data we can specify how +-- many pages we want to fetch. +data FetchCount = FetchAtLeast !Word | FetchAll + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +-- | This instance is there mostly for 'fromInteger'. +instance Num FetchCount where + fromInteger = FetchAtLeast . fromInteger + + FetchAtLeast a + FetchAtLeast b = FetchAtLeast (a * b) + _ + _ = FetchAll + + FetchAtLeast a * FetchAtLeast b = FetchAtLeast (a * b) + _ * _ = FetchAll + + abs = error "abs @FetchCount: not implemented" + signum = error "signum @FetchCount: not implemented" + negate = error "negate @FetchCount: not implemented" + +instance Hashable FetchCount +instance Binary FetchCount +instance NFData FetchCount where rnf = genericRnf + +------------------------------------------------------------------------------ +-- Github request +------------------------------------------------------------------------------ + +-- | Type used as with @DataKinds@ to tag whether requests need authentication +-- or aren't read-only. +data RW + = RO -- ^ /Read-only/, doesn't necessarily requires authentication + | RA -- ^ /Read autenticated/ + | RW -- ^ /Read-write/, requires authentication + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic) + +{- +data SRO (rw :: RW) where + ROO :: SRO 'RO + ROA :: SRO 'RA + +-- | This class is used to describe read-only (but pontentially +class IReadOnly (rw :: RW) where iro :: SRO rw +instance IReadOnly 'RO where iro = ROO +instance IReadOnly 'RA where iro = ROA +-} + +-- | Github request data type. +-- +-- * @k@ describes whether authentication is required. It's required for non-@GET@ requests. +-- * @a@ is the result type +-- +-- /Note:/ 'Request' is not 'Functor' on purpose. +data Request (k :: RW) a where + SimpleQuery :: FromJSON a => SimpleRequest k a -> Request k a + StatusQuery :: StatusMap a -> SimpleRequest k () -> Request k a + HeaderQuery :: FromJSON a => Types.RequestHeaders -> SimpleRequest k a -> Request k a + RedirectQuery :: SimpleRequest k () -> Request k URI + deriving (Typeable) + +data SimpleRequest (k :: RW) a where + Query :: Paths -> QueryString -> SimpleRequest k a + PagedQuery :: Paths -> QueryString -> FetchCount -> SimpleRequest k (Vector a) + Command :: CommandMethod a -> Paths -> LBS.ByteString -> SimpleRequest 'RW a + deriving (Typeable) + +------------------------------------------------------------------------------- +-- Status Map +------------------------------------------------------------------------------- + +-- TODO: Change to 'Map' ? +type StatusMap a = [(Int, a)] + +statusOnlyOk :: StatusMap Bool +statusOnlyOk = + [ (204, True) + , (404, False) + ] + +------------------------------------------------------------------------------- +-- Smart constructors +------------------------------------------------------------------------------- + +query :: FromJSON a => Paths -> QueryString -> Request k a +query ps qs = SimpleQuery (Query ps qs) + +pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request k (Vector a) +pagedQuery ps qs fc = SimpleQuery (PagedQuery ps qs fc) + +command :: FromJSON a => CommandMethod a -> Paths -> LBS.ByteString -> Request 'RW a +command m ps body = SimpleQuery (Command m ps body) + +------------------------------------------------------------------------------- +-- Instances +------------------------------------------------------------------------------- + +deriving instance Eq a => Eq (Request k a) +deriving instance Eq a => Eq (SimpleRequest k a) + +deriving instance Ord a => Ord (Request k a) +deriving instance Ord a => Ord (SimpleRequest k a) + +instance Show (SimpleRequest k a) where + showsPrec d r = showParen (d > appPrec) $ case r of + Query ps qs -> showString "Query " + . showsPrec (appPrec + 1) ps + . showString " " + . showsPrec (appPrec + 1) qs + PagedQuery ps qs l -> showString "PagedQuery " + . showsPrec (appPrec + 1) ps + . showString " " + . showsPrec (appPrec + 1) qs + . showString " " + . showsPrec (appPrec + 1) l + Command m ps body -> showString "Command " + . showsPrec (appPrec + 1) m + . showString " " + . showsPrec (appPrec + 1) ps + . showString " " + . showsPrec (appPrec + 1) body + where + appPrec = 10 :: Int + +instance Show (Request k a) where + showsPrec d r = showParen (d > appPrec) $ case r of + SimpleQuery req -> showString "SimpleQuery " + . showsPrec (appPrec + 1) req + StatusQuery m req -> showString "Status " + . showsPrec (appPrec + 1) (map fst m) -- !!! printing only keys + . showString " " + . showsPrec (appPrec + 1) req + HeaderQuery m req -> showString "Header " + . showsPrec (appPrec + 1) m + . showString " " + . showsPrec (appPrec + 1) req + RedirectQuery req -> showString "Redirect " + . showsPrec (appPrec + 1) req + where + appPrec = 10 :: Int + +instance Hashable (SimpleRequest k a) where + hashWithSalt salt (Query ps qs) = + salt `hashWithSalt` (0 :: Int) + `hashWithSalt` ps + `hashWithSalt` qs + hashWithSalt salt (PagedQuery ps qs l) = + salt `hashWithSalt` (1 :: Int) + `hashWithSalt` ps + `hashWithSalt` qs + `hashWithSalt` l + hashWithSalt salt (Command m ps body) = + salt `hashWithSalt` (2 :: Int) + `hashWithSalt` m + `hashWithSalt` ps + `hashWithSalt` body + +instance Hashable (Request k a) where + hashWithSalt salt (SimpleQuery req) = + salt `hashWithSalt` (0 :: Int) + `hashWithSalt` req + hashWithSalt salt (StatusQuery sm req) = + salt `hashWithSalt` (1 :: Int) + `hashWithSalt` map fst sm + `hashWithSalt` req + hashWithSalt salt (HeaderQuery h req) = + salt `hashWithSalt` (2 :: Int) + `hashWithSalt` h + `hashWithSalt` req + hashWithSalt salt (RedirectQuery req) = + salt `hashWithSalt` (3 :: Int) + `hashWithSalt` req diff --git a/src/GitHub/Data/Reviews.hs b/src/GitHub/Data/Reviews.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Reviews.hs @@ -0,0 +1,97 @@ +module GitHub.Data.Reviews where + +import Data.Text (Text) +import GitHub.Data.Definitions (SimpleUser) +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data ReviewState + = ReviewStatePending + | ReviewStateApproved + | ReviewStateDismissed + | ReviewStateCommented + | ReviewStateChangesRequested + deriving (Show, Enum, Bounded, Eq, Ord, Generic) + +instance NFData ReviewState where + rnf = genericRnf + +instance Binary ReviewState + +instance FromJSON ReviewState where + parseJSON (String "APPROVED") = pure ReviewStateApproved + parseJSON (String "PENDING") = pure ReviewStatePending + parseJSON (String "DISMISSED") = pure ReviewStateDismissed + parseJSON (String "COMMENTED") = pure ReviewStateCommented + parseJSON (String "CHANGES_REQUESTED") = pure ReviewStateChangesRequested + parseJSON _ = fail "Unexpected ReviewState" + +data Review = Review + { reviewBody :: !Text + , reviewCommitId :: !Text + , reviewState :: ReviewState + , reviewSubmittedAt :: !UTCTime + , reviewPullRequestUrl :: !URL + , reviewHtmlUrl :: !Text + , reviewUser :: !SimpleUser + , reviewId :: !(Id Review) + } deriving (Show, Generic) + +instance NFData Review where + rnf = genericRnf + +instance Binary Review + +instance FromJSON Review where + parseJSON = + withObject "Review" $ \o -> + Review <$> o .: "body" <*> o .: "commit_id" <*> o .: "state" <*> + o .: "submitted_at" <*> + o .: "pull_request_url" <*> + o .: "html_url" <*> + o .: "user" <*> + o .: "id" + +data ReviewComment = ReviewComment + { reviewCommentId :: !(Id ReviewComment) + , reviewCommentUser :: !SimpleUser + , reviewCommentBody :: !Text + , reviewCommentUrl :: !URL + , reviewCommentPullRequestReviewId :: !(Id Review) + , reviewCommentDiffHunk :: !Text + , reviewCommentPath :: !Text + , reviewCommentPosition :: !Int + , reviewCommentOriginalPosition :: !Int + , reviewCommentCommitId :: !Text + , reviewCommentOriginalCommitId :: !Text + , reviewCommentCreatedAt :: !UTCTime + , reviewCommentUpdatedAt :: !UTCTime + , reviewCommentHtmlUrl :: !URL + , reviewCommentPullRequestUrl :: !URL + } deriving (Show, Generic) + +instance NFData ReviewComment where + rnf = genericRnf + +instance Binary ReviewComment + +instance FromJSON ReviewComment where + parseJSON = + withObject "ReviewComment" $ \o -> ReviewComment + <$> o .: "id" + <*> o .: "user" + <*> o .: "body" + <*> o .: "url" + <*> o .: "pull_request_review_id" + <*> o .: "diff_hunk" + <*> o .: "path" + <*> o .: "position" + <*> o .: "original_position" + <*> o .: "commit_id" + <*> o .: "original_commit_id" + <*> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "html_url" + <*> o .: "pull_request_url" diff --git a/src/GitHub/Data/Search.hs b/src/GitHub/Data/Search.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Search.hs @@ -0,0 +1,51 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Search where + +import GitHub.Data.Repos (Repo) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.Vector as V + +data SearchResult entity = SearchResult + { searchResultTotalCount :: !Int + , searchResultResults :: !(Vector entity) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData entity => NFData (SearchResult entity) where rnf = genericRnf +instance Binary entity => Binary (SearchResult entity) + +instance FromJSON entity => FromJSON (SearchResult entity) where + parseJSON = withObject "SearchResult" $ \o -> SearchResult + <$> o .: "total_count" + <*> o .:? "items" .!= V.empty + +data Code = Code + { codeName :: !Text + , codePath :: !Text + , codeSha :: !Text + , codeUrl :: !URL + , codeGitUrl :: !URL + , codeHtmlUrl :: !URL + , codeRepo :: !Repo + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Code where rnf = genericRnf +instance Binary Code + +instance FromJSON Code where + parseJSON = withObject "Code" $ \o -> Code + <$> o .: "name" + <*> o .: "path" + <*> o .: "sha" + <*> o .: "url" + <*> o .: "git_url" + <*> o .: "html_url" + <*> o .: "repository" diff --git a/src/GitHub/Data/Statuses.hs b/src/GitHub/Data/Statuses.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Statuses.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module GitHub.Data.Statuses where + +import GitHub.Data.Definitions +import GitHub.Data.Name (Name) +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import GitHub.Data.GitData (Commit) +import GitHub.Data.Repos (RepoRef) + + +data StatusState + = StatusPending + | StatusSuccess + | StatusError + | StatusFailure + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData StatusState where rnf = genericRnf +instance Binary StatusState + +instance FromJSON StatusState where + parseJSON (String "pending") = pure StatusPending + parseJSON (String "success") = pure StatusSuccess + parseJSON (String "error") = pure StatusError + parseJSON (String "failure") = pure StatusFailure + parseJSON _ = fail "Could not build a StatusState" + +instance ToJSON StatusState where + toJSON StatusPending = String "pending" + toJSON StatusSuccess = String "success" + toJSON StatusError = String "error" + toJSON StatusFailure = String "failure" + + +data Status = Status + { statusCreatedAt :: !UTCTime + , statusUpdatedAt :: !UTCTime + , statusState :: !StatusState + , statusTargetUrl :: !(Maybe URL) + , statusDescription :: !(Maybe Text) + , statusId :: !(Id Status) + , statusUrl :: !URL + , statusContext :: !(Maybe Text) + , statusCreator :: !(Maybe SimpleUser) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON Status where + parseJSON = withObject "Status" $ \o -> Status + <$> o .: "created_at" + <*> o .: "updated_at" + <*> o .: "state" + <*> o .:? "target_url" + <*> o .:? "description" + <*> o .: "id" + <*> o .: "url" + <*> o .:? "context" + <*> o .:? "creator" + + +data NewStatus = NewStatus + { newStatusState :: !StatusState + , newStatusTargetUrl :: !(Maybe URL) + , newStatusDescription :: !(Maybe Text) + , newStatusContext :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData NewStatus where rnf = genericRnf +instance Binary NewStatus + +instance ToJSON NewStatus where + toJSON (NewStatus s t d c) = object $ filter notNull $ + [ "state" .= s + , "target_url" .= t + , "description" .= d + , "context" .= c + ] + where + notNull (_, Null) = False + notNull (_, _) = True + + +data CombinedStatus = CombinedStatus + { combinedStatusState :: !StatusState + , combinedStatusSha :: !(Name Commit) + , combinedStatusTotalCount :: !Int + , combinedStatusStatuses :: !(Vector Status) + , combinedStatusRepository :: !RepoRef + , combinedStatusCommitUrl :: !URL + , combinedStatusUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance FromJSON CombinedStatus where + parseJSON = withObject "CombinedStatus" $ \o -> CombinedStatus + <$> o .: "state" + <*> o .: "sha" + <*> o .: "total_count" + <*> o .: "statuses" + <*> o .: "repository" + <*> o .: "commit_url" + <*> o .: "url" diff --git a/src/GitHub/Data/Teams.hs b/src/GitHub/Data/Teams.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Teams.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Teams where + +import GitHub.Data.Definitions +import GitHub.Data.Id (Id) +import GitHub.Data.Name (Name) +import GitHub.Data.Repos (Repo) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +data Privacy + = PrivacyClosed + | PrivacySecret + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData Privacy where rnf = genericRnf +instance Binary Privacy + +data Permission + = PermissionPull + | PermissionPush + | PermissionAdmin + deriving (Show, Data, Enum, Bounded, Typeable, Eq, Ord, Generic) + +instance NFData Permission where rnf = genericRnf +instance Binary Permission + +data AddTeamRepoPermission = AddTeamRepoPermission + { addTeamRepoPermission :: !Permission + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData AddTeamRepoPermission where rnf = genericRnf +instance Binary AddTeamRepoPermission + +data SimpleTeam = SimpleTeam + { simpleTeamId :: !(Id Team) + , simpleTeamUrl :: !URL + , simpleTeamName :: !Text -- TODO (0.15.0): unify this and 'simpleTeamSlug' as in 'Team'. + , simpleTeamSlug :: !(Name Team) + , simpleTeamDescription :: !(Maybe Text) + , simpleTeamPrivacy :: !(Maybe Privacy) + , simpleTeamPermission :: !Permission + , simpleTeamMembersUrl :: !URL + , simpleTeamRepositoriesUrl :: !URL + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData SimpleTeam where rnf = genericRnf +instance Binary SimpleTeam + +data Team = Team + { teamId :: !(Id Team) + , teamUrl :: !URL + , teamName :: !Text + , teamSlug :: !(Name Team) + , teamDescription :: !(Maybe Text) + , teamPrivacy :: !(Maybe Privacy) + , teamPermission :: !Permission + , teamMembersUrl :: !URL + , teamRepositoriesUrl :: !URL + , teamMembersCount :: !Int + , teamReposCount :: !Int + , teamOrganization :: !SimpleOrganization + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Team where rnf = genericRnf +instance Binary Team + +data CreateTeam = CreateTeam + { createTeamName :: !(Name Team) + , createTeamDescription :: !(Maybe Text) + , createTeamRepoNames :: !(Vector (Name Repo)) + -- , createTeamPrivacy :: Privacy + , createTeamPermission :: Permission + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CreateTeam where rnf = genericRnf +instance Binary CreateTeam + +data EditTeam = EditTeam + { editTeamName :: !(Name Team) + , editTeamDescription :: !(Maybe Text) + -- , editTeamPrivacy :: Privacy + , editTeamPermission :: !Permission + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData EditTeam where rnf = genericRnf +instance Binary EditTeam + +data Role + = RoleMaintainer + | RoleMember + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData Role +instance Binary Role + +data ReqState + = StatePending + | StateActive + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData ReqState where rnf = genericRnf +instance Binary ReqState + +data TeamMembership = TeamMembership + { teamMembershipUrl :: !URL + , teamMembershipRole :: !Role + , teamMembershipReqState :: !ReqState + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData TeamMembership where rnf = genericRnf +instance Binary TeamMembership + +data CreateTeamMembership = CreateTeamMembership { + createTeamMembershipRole :: !Role +} deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData CreateTeamMembership where rnf = genericRnf +instance Binary CreateTeamMembership + +-- JSON Instances + +instance FromJSON SimpleTeam where + parseJSON = withObject "SimpleTeam" $ \o -> SimpleTeam + <$> o .: "id" + <*> o .: "url" + <*> o .: "name" + <*> o .: "slug" + <*> o .:?"description" .!= Nothing + <*> o .:?"privacy" .!= Nothing + <*> o .: "permission" + <*> o .: "members_url" + <*> o .: "repositories_url" + +instance FromJSON Team where + parseJSON = withObject "Team" $ \o -> Team + <$> o .: "id" + <*> o .: "url" + <*> o .: "name" + <*> o .: "slug" + <*> o .:?"description" .!= Nothing + <*> o .:?"privacy" .!= Nothing + <*> o .: "permission" + <*> o .: "members_url" + <*> o .: "repositories_url" + <*> o .: "members_count" + <*> o .: "repos_count" + <*> o .: "organization" + +instance ToJSON CreateTeam where + toJSON (CreateTeam name desc repo_names {-privacy-} permissions) = + object [ "name" .= name + , "description" .= desc + , "repo_names" .= repo_names + {-, "privacy" .= privacy-} + , "permissions" .= permissions ] + +instance ToJSON EditTeam where + toJSON (EditTeam name desc {-privacy-} permissions) = + object [ "name" .= name + , "description" .= desc + {-, "privacy" .= privacy-} + , "permissions" .= permissions ] + +instance FromJSON TeamMembership where + parseJSON = withObject "TeamMembership" $ \o -> TeamMembership + <$> o .: "url" + <*> o .: "role" + <*> o .: "state" + +instance FromJSON CreateTeamMembership where + parseJSON = withObject "CreateTeamMembership" $ \o -> CreateTeamMembership + <$> o .: "role" + +instance ToJSON CreateTeamMembership where + toJSON (CreateTeamMembership { createTeamMembershipRole = role }) = + object [ "role" .= role ] + +instance FromJSON AddTeamRepoPermission where + parseJSON = withObject "AddTeamRepoPermission" $ \o -> AddTeamRepoPermission + <$> o .: "permission" + +instance ToJSON AddTeamRepoPermission where + toJSON (AddTeamRepoPermission { addTeamRepoPermission = permission}) = + object [ "permission" .= permission ] + +instance FromJSON Role where + parseJSON = withText "Attribute" $ \attr -> case attr of + "maintainer" -> return RoleMaintainer + "member" -> return RoleMember + _ -> fail $ "Unknown Role: " ++ show attr + +instance ToJSON Role where + toJSON RoleMaintainer = String "maintainer" + toJSON RoleMember = String "member" + +instance ToJSON Permission where + toJSON PermissionPull = "pull" + toJSON PermissionPush = "push" + toJSON PermissionAdmin = "admin" + +instance FromJSON Permission where + parseJSON = withText "Permission Attribute" $ \attr -> case attr of + "pull" -> return PermissionPull + "push" -> return PermissionPush + "admin" -> return PermissionAdmin + _ -> fail $ "Unknown Permission Attribute: " ++ show attr + +instance FromJSON Privacy where + parseJSON = withText "Privacy Attribute" $ \attr -> case attr of + "secret" -> return PrivacySecret + "closed" -> return PrivacyClosed + _ -> fail $ "Unknown Privacy Attribute: " ++ show attr + +instance ToJSON Privacy where + toJSON PrivacySecret = String "secret" + toJSON PrivacyClosed = String "closed" + +instance FromJSON ReqState where + parseJSON = withText "ReqState" $ \attr -> case attr of + "active" -> return StateActive + "pending" -> return StatePending + _ -> fail $ "Unknown ReqState: " ++ show attr + +instance ToJSON ReqState where + toJSON StateActive = String "active" + toJSON StatePending = String "pending" + +-- | Filters members returned by their role in the team. +data TeamMemberRole + = TeamMemberRoleAll -- ^ all members of the team. + | TeamMemberRoleMaintainer -- ^ team maintainers + | TeamMemberRoleMember -- ^ normal members of the team. + deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic) diff --git a/src/GitHub/Data/URL.hs b/src/GitHub/Data/URL.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/URL.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.URL ( + URL(..), + getUrl, + ) where + +import GitHub.Internal.Prelude +import Prelude () + +-- | Data representing URLs in responses. +-- +-- /N.B./ syntactical validity is not verified. +newtype URL = URL Text + deriving (Eq, Ord, Show, Generic, Typeable, Data) + +getUrl :: URL -> Text +getUrl (URL url) = url + +instance NFData URL where rnf = genericRnf +instance Binary URL + +instance ToJSON URL where + toJSON (URL url) = toJSON url + +instance FromJSON URL where + parseJSON = withText "URL" (pure . URL) diff --git a/src/GitHub/Data/Webhooks.hs b/src/GitHub/Data/Webhooks.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Data/Webhooks.hs @@ -0,0 +1,201 @@ +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +module GitHub.Data.Webhooks where + +import GitHub.Data.Id (Id) +import GitHub.Data.URL (URL) +import GitHub.Internal.Prelude +import Prelude () + +import qualified Data.Map as M + +data RepoWebhook = RepoWebhook + { repoWebhookUrl :: !URL + , repoWebhookTestUrl :: !URL + , repoWebhookId :: !(Id RepoWebhook) + , repoWebhookName :: !Text + , repoWebhookActive :: !Bool + , repoWebhookEvents :: !(Vector RepoWebhookEvent) + , repoWebhookConfig :: !(M.Map Text Text) + , repoWebhookLastResponse :: !RepoWebhookResponse + , repoWebhookUpdatedAt :: !UTCTime + , repoWebhookCreatedAt :: !UTCTime + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoWebhook where rnf = genericRnf +instance Binary RepoWebhook + +data RepoWebhookEvent + = WebhookWildcardEvent + | WebhookCommitCommentEvent + | WebhookCreateEvent + | WebhookDeleteEvent + | WebhookDeploymentEvent + | WebhookDeploymentStatusEvent + | WebhookForkEvent + | WebhookGollumEvent + | WebhookIssueCommentEvent + | WebhookIssuesEvent + | WebhookMemberEvent + | WebhookPageBuildEvent + | WebhookPingEvent + | WebhookPublicEvent + | WebhookPullRequestReviewCommentEvent + | WebhookPullRequestEvent + | WebhookPushEvent + | WebhookReleaseEvent + | WebhookStatusEvent + | WebhookTeamAddEvent + | WebhookWatchEvent + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoWebhookEvent where rnf = genericRnf +instance Binary RepoWebhookEvent + +data RepoWebhookResponse = RepoWebhookResponse + { repoWebhookResponseCode :: !(Maybe Int) + , repoWebhookResponseStatus :: !Text + , repoWebhookResponseMessage :: !(Maybe Text) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData RepoWebhookResponse where rnf = genericRnf +instance Binary RepoWebhookResponse + +data PingEvent = PingEvent + { pingEventZen :: !Text + , pingEventHook :: !RepoWebhook + , pingEventHookId :: !(Id RepoWebhook) + } + deriving (Show, Data, Typeable, Eq, Ord, Generic) + +instance NFData PingEvent where rnf = genericRnf +instance Binary PingEvent + +data NewRepoWebhook = NewRepoWebhook + { newRepoWebhookName :: !Text + , newRepoWebhookConfig :: !(M.Map Text Text) + , newRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent)) + , newRepoWebhookActive :: !(Maybe Bool) + } + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +instance NFData NewRepoWebhook where rnf = genericRnf +instance Binary NewRepoWebhook + +data EditRepoWebhook = EditRepoWebhook + { editRepoWebhookConfig :: !(Maybe (M.Map Text Text)) + , editRepoWebhookEvents :: !(Maybe (Vector RepoWebhookEvent)) + , editRepoWebhookAddEvents :: !(Maybe (Vector RepoWebhookEvent)) + , editRepoWebhookRemoveEvents :: !(Maybe (Vector RepoWebhookEvent)) + , editRepoWebhookActive :: !(Maybe Bool) + } + deriving (Eq, Ord, Show, Typeable, Data, Generic) + +instance NFData EditRepoWebhook where rnf = genericRnf +instance Binary EditRepoWebhook + +-- JSON instances + +instance FromJSON RepoWebhookEvent where + parseJSON (String "*") = pure WebhookWildcardEvent + parseJSON (String "commit_comment") = pure WebhookCommitCommentEvent + parseJSON (String "create") = pure WebhookCreateEvent + parseJSON (String "delete") = pure WebhookDeleteEvent + parseJSON (String "deployment") = pure WebhookDeploymentEvent + parseJSON (String "deployment_status") = pure WebhookDeploymentStatusEvent + parseJSON (String "fork") = pure WebhookForkEvent + parseJSON (String "gollum") = pure WebhookGollumEvent + parseJSON (String "issue_comment") = pure WebhookIssueCommentEvent + parseJSON (String "issues") = pure WebhookIssuesEvent + parseJSON (String "member") = pure WebhookMemberEvent + parseJSON (String "page_build") = pure WebhookPageBuildEvent + parseJSON (String "ping") = pure WebhookPingEvent + parseJSON (String "public") = pure WebhookPublicEvent + parseJSON (String "pull_request_review_comment") = pure WebhookPullRequestReviewCommentEvent + parseJSON (String "pull_request") = pure WebhookPullRequestEvent + parseJSON (String "push") = pure WebhookPushEvent + parseJSON (String "release") = pure WebhookReleaseEvent + parseJSON (String "status") = pure WebhookStatusEvent + parseJSON (String "team_add") = pure WebhookTeamAddEvent + parseJSON (String "watch") = pure WebhookWatchEvent + parseJSON _ = fail "Could not build a Webhook event" + +instance ToJSON RepoWebhookEvent where + toJSON WebhookWildcardEvent = String "*" + toJSON WebhookCommitCommentEvent = String "commit_comment" + toJSON WebhookCreateEvent = String "create" + toJSON WebhookDeleteEvent = String "delete" + toJSON WebhookDeploymentEvent = String "deployment" + toJSON WebhookDeploymentStatusEvent = String "deployment_status" + toJSON WebhookForkEvent = String "fork" + toJSON WebhookGollumEvent = String "gollum" + toJSON WebhookIssueCommentEvent = String "issue_comment" + toJSON WebhookIssuesEvent = String "issues" + toJSON WebhookMemberEvent = String "member" + toJSON WebhookPageBuildEvent = String "page_build" + toJSON WebhookPingEvent = String "ping" + toJSON WebhookPublicEvent = String "public" + toJSON WebhookPullRequestReviewCommentEvent = String "pull_request_review_comment" + toJSON WebhookPullRequestEvent = String "pull_request" + toJSON WebhookPushEvent = String "push" + toJSON WebhookReleaseEvent = String "release" + toJSON WebhookStatusEvent = String "status" + toJSON WebhookTeamAddEvent = String "team_add" + toJSON WebhookWatchEvent = String "watch" + +instance FromJSON RepoWebhook where + parseJSON = withObject "RepoWebhook" $ \o -> RepoWebhook + <$> o .: "url" + <*> o .: "test_url" + <*> o .: "id" + <*> o .: "name" + <*> o .: "active" + <*> o .: "events" + <*> o .: "config" + <*> o .: "last_response" + <*> o .: "updated_at" + <*> o .: "created_at" + +instance FromJSON RepoWebhookResponse where + parseJSON = withObject "RepoWebhookResponse" $ \o -> RepoWebhookResponse + <$> o .: "code" + <*> o .: "status" + <*> o .: "message" + +instance ToJSON NewRepoWebhook where + toJSON (NewRepoWebhook { newRepoWebhookName = name + , newRepoWebhookConfig = config + , newRepoWebhookEvents = events + , newRepoWebhookActive = active + + }) = object + [ "name" .= name + , "config" .= config + , "events" .= events + , "active" .= active + ] + +instance ToJSON EditRepoWebhook where + toJSON (EditRepoWebhook { editRepoWebhookConfig = config + , editRepoWebhookEvents = events + , editRepoWebhookAddEvents = addEvents + , editRepoWebhookRemoveEvents = removeEvents + , editRepoWebhookActive = active + }) = object + [ "config" .= config + , "events" .= events + , "add_events" .= addEvents + , "remove_events" .= removeEvents + , "active" .= active + ] + +instance FromJSON PingEvent where + parseJSON = withObject "PingEvent" $ \o -> PingEvent + <$> o .: "zen" + <*> o .: "hook" + <*> o .: "hook_id" diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/GitHub/Internal/Prelude.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE NoImplicitPrelude #-} +----------------------------------------------------------------------------- +-- | +-- License : BSD-3-Clause +-- Maintainer : Oleg Grenrus +-- +-- This module may change between minor releases. Do not rely on it contents. +module GitHub.Internal.Prelude ( + module Prelude.Compat, + -- * Commonly used types + UTCTime, + HashMap, + Text, pack, unpack, + Vector, + -- * Commonly used typeclasses + Binary, + Data, Typeable, + Generic, + Hashable(..), + IsString(..), + NFData(..), genericRnf, + Semigroup(..), + -- * Aeson + FromJSON(..), ToJSON(..), Value(..), Object, + encode, + withText, withObject, (.:), (.:?), (.!=), (.=), object, typeMismatch, + -- * Control.Applicative + (<|>), + -- * Data.Maybe + catMaybes, + -- * Data.List + intercalate, toList, + -- * Data.Time.ISO8601 + formatISO8601, + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (..)) +import Control.DeepSeq.Generics (genericRnf) +import Data.Aeson.Compat + (FromJSON (..), Object, ToJSON (..), Value (..), encode, object, + withObject, withText, (.!=), (.:), (.:?), (.=)) +import Data.Aeson.Types (typeMismatch) +import Data.Binary (Binary) +import Data.Binary.Orphans () +import Data.Data (Data, Typeable) +import Data.Foldable (toList) +import Data.Hashable (Hashable (..)) +import Data.HashMap.Strict (HashMap) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Data.Semigroup (Semigroup (..)) +import Data.String (IsString (..)) +import Data.Text (Text, pack, unpack) +import Data.Time (UTCTime) +import Data.Time.ISO8601 (formatISO8601) +import Data.Vector (Vector) +import Data.Vector.Instances () +import GHC.Generics (Generic) +import Prelude.Compat