Refactor Request

github.cabal

@@ -167,6 +167,7 @@ library
  , iso8601-time >=0.1.5 && <0.2
  , network-uri >=2.6.1.0 && <2.7
  , semigroups >=0.18.5 && <0.19
+ , tagged
  , tls >=1.4.1
  , transformers-compat >=0.6 && <0.7
  , unordered-containers >=0.2.9.0 && <0.3

samples/Operational/Operational.hs

@@ -1,28 +1,32 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Main (main) where
 
 import Common
 import Prelude ()
 
-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Control.Monad.Operational
+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
 import Network.HTTP.Client (Manager, newManager)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
 
 import qualified GitHub as GH
 
-type GithubMonad a = Program (GH.Request 'GH.RA) a
+data R a where
+ R :: FromJSON a => GH.Request 'GH.RA a -> R a
+
+type GithubMonad a = Program R a
 
 runMonad :: Manager -> GH.Auth -> GithubMonad a -> ExceptT GH.Error IO a
 runMonad mgr auth m = case view m of
  Return a -> return a
- req :>>= k -> do
+ R req :>>= k -> do
  b <- ExceptT $ GH.executeRequestWithMgr mgr auth req
  runMonad mgr auth (k b)
 
-githubRequest :: GH.Request 'GH.RA a -> GithubMonad a
-githubRequest = singleton
+githubRequest :: FromJSON a => GH.Request 'GH.RA a -> GithubMonad a
+githubRequest = singleton . R
 
 main :: IO ()
 main = do

src/GitHub/Data/PullRequests.hs

@@ -14,14 +14,12 @@ module GitHub.Data.PullRequests (
  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 ()
@@ -319,10 +317,3 @@ data MergeResult
  | MergeCannotPerform
  | MergeConflict
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
-
-statusMerge :: StatusMap MergeResult
-statusMerge =
- [ (200, MergeSuccessful)
- , (405, MergeCannotPerform)
- , (409, MergeConflict)
- ]

src/GitHub/Data/Request.hs

@@ -10,17 +10,16 @@
 --
 module GitHub.Data.Request (
  -- * Request
- Request (..),
- SimpleRequest (..),
+ Request,
+ GenRequest (..),
  -- * Smart constructors
  query, pagedQuery, command,
  -- * Auxiliary types
  RW(..),
- StatusMap,
- statusOnlyOk,
  CommandMethod(..),
  toMethod,
  FetchCount(..),
+ MediaType (..),
  Paths,
  IsPathPart(..),
  QueryString,
@@ -34,12 +33,10 @@ 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
+-- Path parts
 ------------------------------------------------------------------------------
 
 type Paths = [Text]
@@ -56,41 +53,30 @@ instance IsPathPart (Id a) where
 instance IsPathPart IssueNumber where
  toPathPart = T.pack . show . unIssueNumber
 
+-------------------------------------------------------------------------------
+-- Command Method
+-------------------------------------------------------------------------------
+
 -- | Http method of requests with body.
-data CommandMethod a where
- Post :: CommandMethod a
- Patch :: CommandMethod a
- Put :: CommandMethod a
-
- -- | Put requests, where we don't care about response's body
- 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
+data CommandMethod
+ = Post
+ | Patch
+ | Put
+ | Delete
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)
+
+instance Hashable CommandMethod
+
+toMethod :: CommandMethod -> Method.Method
 toMethod Post = Method.methodPost
 toMethod Patch = Method.methodPatch
 toMethod Put = Method.methodPut
-toMethod Put' = Method.methodPut
 toMethod Delete = Method.methodDelete
 
+-------------------------------------------------------------------------------
+-- Fetch count
+-------------------------------------------------------------------------------
+
 -- | 'PagedQuery' returns just some results, using this data we can specify how
 -- many pages we want to fetch.
 data FetchCount = FetchAtLeast !Word | FetchAll
@@ -115,15 +101,31 @@ instance Hashable FetchCount
 instance Binary FetchCount
 instance NFData FetchCount where rnf = genericRnf
 
+-------------------------------------------------------------------------------
+-- MediaType
+-------------------------------------------------------------------------------
+
+data MediaType
+ = MtJSON -- ^ @application/vnd.github.v3+json@
+ | MtRaw -- ^ @application/vnd.github.v3.raw@ <https://developer.github.com/v3/media/#raw-1>
+ | MtDiff -- ^ @application/vnd.github.v3.diff@ <https://developer.github.com/v3/media/#diff>
+ | MtPatch -- ^ @application/vnd.github.v3.patch@ <https://developer.github.com/v3/media/#patch>
+ | MtSha -- ^ @application/vnd.github.v3.sha@ <https://developer.github.com/v3/media/#sha>
+ | MtStar -- ^ @application/vnd.github.v3.star+json@ <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
+ | MtRedirect -- ^ <https://developer.github.com/v3/repos/contents/#get-archive-link>
+ | MtStatus -- ^ Parse status
+ | MtUnit -- ^ Always succeeds
+ deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)
+
 ------------------------------------------------------------------------------
--- Github request
+-- RW
 ------------------------------------------------------------------------------
 
 -- | 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/
+ | RA -- ^ /Read authenticated/
  | RW -- ^ /Read-write/, requires authentication
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable, Data, Generic)
 
@@ -138,102 +140,54 @@ instance IReadOnly 'RO where iro = ROO
 instance IReadOnly 'RA where iro = ROA
 -}
 
+-------------------------------------------------------------------------------
+-- GitHub Request
+-------------------------------------------------------------------------------
+
 -- | Github request data type.
 --
--- * @k@ describes whether authentication is required. It's required for non-@GET@ requests.
+-- * @rw@ describes whether authentication is required. It's required for non-@GET@ requests.
+-- * @mt@ describes the media type, i.e. how the response should be interpreted.
 -- * @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
-
- -- | Redirect query is /some/ query where we expect status 302 response with @Location@ header.
- RedirectQuery :: SimpleRequest k () -> Request k URI
+data GenRequest (mt :: MediaType) (rw :: RW) a where
+ Query :: Paths -> QueryString -> GenRequest mt rw a
+ PagedQuery :: Paths -> QueryString -> FetchCount -> GenRequest mt rw (Vector a)
+
+ -- | Command
+ Command
+ :: CommandMethod -- ^ command
+ -> Paths -- ^ path
+ -> LBS.ByteString -- ^ body
+ -> GenRequest mt 'RW a
  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)
- ]
+-- | Most requests ask for @JSON@.
+type Request = GenRequest 'MtJSON
 
 -------------------------------------------------------------------------------
 -- Smart constructors
 -------------------------------------------------------------------------------
 
-query :: FromJSON a => Paths -> QueryString -> Request k a
-query ps qs = SimpleQuery (Query ps qs)
+query :: Paths -> QueryString -> Request mt a
+query ps qs = Query ps qs
 
-pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request k (Vector a)
-pagedQuery ps qs fc = SimpleQuery (PagedQuery ps qs fc)
+pagedQuery :: FromJSON a => Paths -> QueryString -> FetchCount -> Request mt (Vector a)
+pagedQuery ps qs fc = PagedQuery ps qs fc
 
-command :: FromJSON a => CommandMethod a -> Paths -> LBS.ByteString -> Request 'RW a
-command m ps body = SimpleQuery (Command m ps body)
+command :: CommandMethod -> Paths -> LBS.ByteString -> Request 'RW a
+command m ps body = 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
+deriving instance Eq (GenRequest rw mt a)
+deriving instance Ord (GenRequest rw mt a)
+deriving instance Show (GenRequest rw mt a)
+
+instance Hashable (GenRequest rw mt a) where
  hashWithSalt salt (Query ps qs) =
  salt `hashWithSalt` (0 :: Int)
  `hashWithSalt` ps
@@ -249,18 +203,4 @@ instance Hashable (SimpleRequest k a) where
  `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
+-- TODO: Binary

src/GitHub/Endpoints/Activity/Starring.hs

@@ -71,17 +71,17 @@ myStarredAcceptStar auth =
 
 -- | All the repos starred by the authenticated user.
 -- See <https://developer.github.com/v3/activity/starring/#alternative-response-with-star-creation-timestamps-1>
-myStarredAcceptStarR :: FetchCount -> Request 'RA (Vector RepoStarred)
-myStarredAcceptStarR = HeaderQuery [("Accept", "application/vnd.github.v3.star+json")] . PagedQuery ["user", "starred"] []
+myStarredAcceptStarR :: FetchCount -> GenRequest 'MtStar 'RA (Vector RepoStarred)
+myStarredAcceptStarR = PagedQuery ["user", "starred"] []
 
 -- | Star a repo by the authenticated user.
 starRepo :: Auth -> Name Owner -> Name Repo -> IO (Either Error ())
 starRepo auth user repo = executeRequest auth $ starRepoR user repo
 
 -- | Star a repo by the authenticated user.
 -- See <https://developer.github.com/v3/activity/starring/#star-a-repository>
-starRepoR :: Name Owner -> Name Repo -> Request 'RW ()
-starRepoR user repo = command Put' paths mempty
+starRepoR :: Name Owner -> Name Repo -> GenRequest 'MtUnit 'RW ()
+starRepoR user repo = Command Put paths mempty
  where
  paths = ["user", "starred", toPathPart user, toPathPart repo]
 

src/GitHub/Endpoints/Gists.hs

@@ -70,8 +70,8 @@ starGist auth gid = executeRequest auth $ starGistR gid
 
 -- | Star a gist by the authenticated user.
 -- See <https://developer.github.com/v3/gists/#star-a-gist>
-starGistR :: Name Gist -> Request 'RW ()
-starGistR gid = command Put' ["gists", toPathPart gid, "star"] mempty
+starGistR :: Name Gist -> GenRequest 'MtUnit 'RW ()
+starGistR gid = Command Put ["gists", toPathPart gid, "star"] mempty
 
 -- | Unstar a gist by the authenticated user.
 --

src/GitHub/Endpoints/Organizations/Members.hs

@@ -77,8 +77,8 @@ isMemberOf = isMemberOf' Nothing
 -- | Check if a user is a member of an organization.
 --
 -- See <https://developer.github.com/v3/orgs/members/#check-membership>
-isMemberOfR :: Name User -> Name Organization -> Request k Bool
-isMemberOfR user org = StatusQuery statusOnlyOk $
+isMemberOfR :: Name User -> Name Organization -> GenRequest 'MtStatus rw Bool
+isMemberOfR user org =
  Query [ "orgs", toPathPart org, "members", toPathPart user ] []
 
 -- | List pending organization invitations