Support projects

github.cabal

@@ -105,6 +105,7 @@ library
     GitHub.Data.Options
     GitHub.Data.PublicSSHKeys
     GitHub.Data.PullRequests
+    GitHub.Data.Projects
     GitHub.Data.RateLimit
     GitHub.Data.Releases
     GitHub.Data.Repos
@@ -149,6 +150,7 @@ library
     GitHub.Endpoints.Repos.Deployments
     GitHub.Endpoints.Repos.Forks
     GitHub.Endpoints.Repos.Invitations
+    GitHub.Endpoints.Repos.Projects
     GitHub.Endpoints.Repos.Releases
     GitHub.Endpoints.Repos.Statuses
     GitHub.Endpoints.Repos.Webhooks

samples/Repos/ListProjects.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE OverloadedStrings#-}
+module Main(main) where
+
+import qualified GitHub.Endpoints.Repos.Projects as P
+import Data.List
+import GitHub.Data
+import GitHub.Data.Name
+import GitHub.Data.Id
+import GitHub.Data.Request
+import Common
+import qualified GitHub
+import Prelude ()
+
+main = do
+    auth <- getAuth
+    possibleProjects <- GitHub.executeRequestMaybe auth $ P.repoProjectsForR "lambda-coast" "infinite-turtles"  GitHub.FetchAll
+    putStrLn $ either (("Error: " <>) . tshow)
+                      (foldMap ((<> "\n") . tshow))
+                      possibleProjects
+
+
+    possibleProjects <- GitHub.executeRequestMaybe auth $ P.orgProjectsForR "lambda-coast" GitHub.FetchAll
+    putStrLn $ either (("Error: " <>) . tshow)
+                      (foldMap ((<> "\n") . tshow))
+                      possibleProjects
+
+
+    possibleColumns <- GitHub.executeRequestMaybe auth $ P.projectColumnsForR (Id 11963370) GitHub.FetchAll
+    putStrLn $ either (("Error: " <>) . tshow)
+                      (foldMap ((<> "\n") . tshow))
+                      possibleColumns
+
+    possibleCards <- GitHub.executeRequestMaybe auth $ P.columnCardsForR (Id 13371133) GitHub.FetchAll
+    putStrLn $ either (("Error: " <>) . tshow)
+                      (foldMap ((<> "\n") . tshow))
+                      possibleCards

samples/github-samples.cabal

@@ -183,3 +183,10 @@ executable github-teaminfo-for
 --   import:         deps
 --   main-is:        GitDiff.hs
 --   hs-source-dirs: Repos/Commits
+
+executable github-list-projects
+  import:         deps
+  main-is:        ListProjects.hs
+  hs-source-dirs: Repos
+
+

src/GitHub.hs

@@ -413,6 +413,13 @@ module GitHub (
     -- | See <https://developer.github.com/v3/rate_limit/>
     rateLimitR,
 
+    -- ** Projects
+    -- | See <https://docs.github.com/en/rest/reference/projects>
+    repoProjectsForR,
+    orgProjectsForR,
+    projectColumnsForR,
+    columnCardsForR,
+
     -- * Data definitions
     module GitHub.Data,
     -- * Request handling
@@ -452,6 +459,7 @@ import GitHub.Endpoints.Repos.DeployKeys
 import GitHub.Endpoints.Repos.Deployments
 import GitHub.Endpoints.Repos.Forks
 import GitHub.Endpoints.Repos.Invitations
+import GitHub.Endpoints.Repos.Projects
 import GitHub.Endpoints.Repos.Releases
 import GitHub.Endpoints.Repos.Statuses
 import GitHub.Endpoints.Repos.Webhooks

src/GitHub/Data.hs

@@ -16,6 +16,8 @@ module GitHub.Data (
     mkTeamName,
     mkOrganizationName,
     mkRepoName,
+    mkProjectName,
+    mkColumnName,
     mkCommitName,
     fromUserName,
     fromOrganizationName,
@@ -30,6 +32,9 @@ module GitHub.Data (
     mkRepoId,
     fromUserId,
     fromOrganizationId,
+    mkProjectId,
+    mkColumnId,
+    mkCardId,
     -- * IssueNumber
     IssueNumber (..),
     -- * Module re-exports
@@ -53,6 +58,7 @@ module GitHub.Data (
     module GitHub.Data.RateLimit,
     module GitHub.Data.Releases,
     module GitHub.Data.Repos,
+    module GitHub.Data.Projects,
     module GitHub.Data.Request,
     module GitHub.Data.Reviews,
     module GitHub.Data.Search,
@@ -88,6 +94,7 @@ import GitHub.Data.PullRequests
 import GitHub.Data.RateLimit
 import GitHub.Data.Releases
 import GitHub.Data.Repos
+import GitHub.Data.Projects
 import GitHub.Data.Request
 import GitHub.Data.Reviews
 import GitHub.Data.Search
@@ -127,6 +134,21 @@ mkRepoId = Id
 mkRepoName :: Text -> Name Repo
 mkRepoName = N
 
+mkProjectId :: Int -> Id Project
+mkProjectId = Id
+
+mkProjectName :: Text -> Name Project
+mkProjectName = N
+
+mkColumnId :: Int -> Id Column
+mkColumnId = Id
+
+mkColumnName :: Text -> Name Column
+mkColumnName = N
+
+mkCardId :: Int -> Id Card
+mkCardId = Id
+
 mkCommitName :: Text -> Name Commit
 mkCommitName = N
 

src/GitHub/Data/Projects.hs

@@ -0,0 +1,130 @@
+-----------------------------------------------------------------------------
+-- |
+-- License     :  BSD-3-Clause
+-- Maintainer  :  Oleg Grenrus <[email protected]>
+--
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module GitHub.Data.Projects where
+
+import GitHub.Data.Definitions
+import GitHub.Data.Name
+import GitHub.Data.Id          (Id)
+import GitHub.Data.URL         (URL)
+import GitHub.Internal.Prelude
+import Prelude ()
+
+import Data.Tagged (Tagged (..))
+-- import qualified GitHub.Request as GH
+
+import qualified Data.Text as T
+
+data ProjectState = ProjectStateOpen | ProjectStateClosed
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData ProjectState where rnf = genericRnf
+instance Binary ProjectState
+
+instance FromJSON ProjectState where
+  parseJSON = withText "ProjecState" $ \t -> case T.toLower t of
+    "open" -> pure ProjectStateOpen
+    "closed" -> pure ProjectStateClosed
+    _ -> fail $ "Unknown ProjectState: " <> T.unpack t
+
+data Project = Project
+  {
+    projectOwnerUrl:: !URL
+  , projectUrl:: !URL
+  , projectHtmlUrl:: !URL
+  , projectColumnsUrl:: !URL
+  , projectId :: !(Id Project)
+  , projectName :: !(Name Project)
+  , projectBody :: !(Maybe Text)
+  , projectNumber :: !Int
+  , projectState :: !ProjectState
+  , projectCreator :: !SimpleUser
+  , projectCreatedAt :: !UTCTime
+  , projectUpdatedAt :: !UTCTime
+  }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData Project where rnf = genericRnf
+instance Binary Project
+
+instance FromJSON Project where
+    parseJSON = withObject "Project" $ \o -> Project
+        <$> o .: "owner_url"
+        <*> o .: "url"
+        <*> o .: "html_url"
+        <*> o .: "columns_url"
+        <*> o .: "id"
+        <*> o .: "name"
+        <*> o .:? "body"
+        <*> o .: "number"
+        <*> o .: "state"
+        <*> o .: "creator"
+        <*> o .: "created_at"
+        <*> o .: "updated_at"
+
+
+data Column = Column
+  {
+    columnUrl :: !URL,
+    columnProjectUrl :: !URL,
+    columnCardsUrl :: !URL,
+    columnId :: !(Id Column),
+    columnName :: !(Name Column),
+    columnCreatedAt :: !UTCTime,
+    columntUpdatedAt :: !UTCTime
+  }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData Column where rnf = genericRnf
+
+instance Binary Column
+
+instance FromJSON Column where
+  parseJSON = withObject "Column" $ \o ->
+    Column
+      <$> o .: "url"
+      <*> o .: "project_url"
+      <*> o .: "cards_url"
+      <*> o .: "id"
+      <*> o .: "name"
+      <*> o .: "created_at"
+      <*> o .: "updated_at"
+
+
+data Card = Card
+  { cardUrl :: !URL,
+    cardId :: !(Id Column),
+    cardNote:: !(Maybe T.Text),
+    cardCreator:: !(SimpleUser),
+    cardCreatedAt :: !UTCTime,
+    cardUpdatedAt :: !UTCTime,
+    archived:: !Bool,
+    cardColumnUrl:: !URL,
+    cardContentUrl:: !(Maybe URL),
+    cardProjectUrl:: !URL
+  }
+  deriving (Show, Data, Typeable, Eq, Ord, Generic)
+
+instance NFData Card where rnf = genericRnf
+
+instance Binary Card
+
+instance FromJSON Card where
+  parseJSON = withObject "Card" $ \o ->
+    Card
+      <$> o .: "url"
+      <*> o .: "id"
+      <*> o .:? "note"
+      <*> o .: "creator"
+      <*> o .: "created_at"
+      <*> o .: "updated_at"
+      <*> o .: "archived"
+      <*> o .: "column_url"
+      <*> o .:? "content_url"
+      <*> o .: "project_url"

src/GitHub/Endpoints/Repos/Projects.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- License     :  BSD-3-Clause
+-- Maintainer  :  Oleg Grenrus <[email protected]>
+--
+-- The repo commits API as described on
+-- <https://docs.github.com/en/rest/reference/projects>
+module GitHub.Endpoints.Repos.Projects (
+    repoProjectsForR
+  , orgProjectsForR
+  , projectColumnsForR
+  , columnCardsForR
+  ) where
+
+import GitHub.Data
+import GitHub.Data.Request
+import GitHub.Request
+import GitHub.Data.Projects
+import GitHub.Internal.Prelude
+import Prelude ()
+
+-- | List projects for a repository
+-- See <https ://docs.github.com/en/rest/reference/projects#list-repository-projects
+repoProjectsForR :: Name Owner -> Name Repo -> FetchCount -> GenRequest ('MtPreview Inertia) k (Vector Project)
+repoProjectsForR user repo =
+    PagedQuery ["repos", toPathPart user, toPathPart repo, "projects"] []
+
+
+orgProjectsForR :: Name Owner -> FetchCount -> GenRequest ( 'MtPreview Inertia) k (Vector Project)
+orgProjectsForR user =
+  PagedQuery ["orgs", toPathPart user, "projects"] []
+
+
+projectColumnsForR :: (Id Project) -> FetchCount -> GenRequest ( 'MtPreview Inertia) k (Vector Column)
+projectColumnsForR project_id =
+  PagedQuery ["projects", toPathPart project_id, "columns"] []
+
+
+columnCardsForR :: (Id Column) -> FetchCount -> GenRequest ( 'MtPreview Inertia) k (Vector Card)
+columnCardsForR column_id =
+  PagedQuery ["projects", "columns", toPathPart column_id, "cards"] []

src/GitHub/Request.hs

@@ -68,6 +68,10 @@ module GitHub.Request (
     -- They change accordingly, to make use of the library simpler.
     withOpenSSL,
     tlsManagerSettings,
+
+
+    -- preview types
+    Inertia
     ) where
 
 import GitHub.Internal.Prelude
@@ -386,6 +390,16 @@ instance PreviewAccept p => Accept ('MtPreview p) where
 instance PreviewParseResponse p a => ParseResponse ('MtPreview p) a where
     parseResponse = previewParseResponse
 
+
+data Inertia
+
+instance PreviewAccept Inertia where
+  previewContentType = Tagged "application/vnd.github.inertia-preview+json"
+
+instance FromJSON a => PreviewParseResponse Inertia a where
+  previewParseResponse _ res = Tagged (parseResponseJSON res)
+
+
 -------------------------------------------------------------------------------
 -- Status
 -------------------------------------------------------------------------------