57 lines
2.2 KiB
Haskell
57 lines
2.2 KiB
Haskell
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
module Client.ApiRequests where
|
|
|
|
import Relude
|
|
|
|
import Data.Morpheus.Client
|
|
import Yesod hiding (Header)
|
|
import Yesod.Auth
|
|
|
|
type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)
|
|
-- From Data.Morpheus.Client.Fetch.RequestType
|
|
type Header = (Text, Text)
|
|
-- From Data.Morpheus.Client.Fetch.GQLClient
|
|
-- No clue why these are not exported
|
|
|
|
type RequestConstraint a site = (ClientTypeConstraint a, ApiRequest site)
|
|
|
|
type Authorization = Text
|
|
|
|
class YesodAuth site => ApiRequest site where
|
|
getApiUrl :: HandlerFor site Text
|
|
authIdToAuthorization :: site -> AuthId site -> Authorization
|
|
|
|
apiRequest' :: RequestConstraint a site => [Header] -> Bool -> Args a -> HandlerFor site a
|
|
apiRequest' extraHeaders authRequired args = do
|
|
yesod <- liftHandler getYesod
|
|
auth <- fmap (authIdToAuthorization yesod) <$> if authRequired then Just <$> requireAuthId else maybeAuthId
|
|
apiRequestAuth extraHeaders (("Bearer " <>) <$> auth) args >>= handleErrors
|
|
|
|
apiRequestAuth :: RequestConstraint a site =>
|
|
[Header] -> Maybe Authorization -> Args a -> HandlerFor site (GQLClientResult a)
|
|
apiRequestAuth extraHeaders auth args = do
|
|
apiUrl <- getApiUrl
|
|
stream <- liftIO $ request (fromString (toString apiUrl) `withHeaders` headers) args
|
|
single stream
|
|
where headers = maybe [] (\x -> [("Authorization", x)]) auth <> extraHeaders
|
|
|
|
apiRequest :: RequestConstraint a site => Bool -> Args a -> HandlerFor site a
|
|
apiRequest authRequired = apiRequest' [] authRequired
|
|
|
|
handleErrors :: RequestConstraint a site => GQLClientResult a -> HandlerFor site a
|
|
handleErrors (Right a) = pure a
|
|
handleErrors (Left (FetchErrorParseFailure s)) = error $ "GQL parse failure: " <> toText s
|
|
handleErrors (Left (FetchErrorProducedErrors errs Nothing)) = error $ "GQL errors: " <> show errs
|
|
handleErrors (Left (FetchErrorProducedErrors _ (Just a))) = pure a -- TODO log the errors?
|
|
handleErrors (Left (FetchErrorNoResult)) = error $ "GQL no results"
|