diff --git a/gogol-core.cabal b/gogol-core.cabal --- a/gogol-core.cabal +++ b/gogol-core.cabal @@ -1,5 +1,5 @@ name: gogol-core -version: 0.0.1 +version: 0.1.0 synopsis: Core data types and functionality for Gogol libraries. homepage: https://github.com/brendanhay/gogol bug-reports: https://github.com/brendanhay/gogol/issues @@ -7,7 +7,7 @@ license-file: LICENSE author: Brendan Hay maintainer: Brendan Hay -copyright: Copyright (c) 2015 Brendan Hay +copyright: Copyright (c) 2015-2016 Brendan Hay category: Network, Google, Cloud build-type: Simple extra-source-files: README.md @@ -36,7 +36,8 @@ ghc-options: -Wall exposed-modules: - Network.Google.Data.JSON + Network.Google.Data.Base64 + , Network.Google.Data.JSON , Network.Google.Data.Numeric , Network.Google.Data.Time , Network.Google.Prelude @@ -45,17 +46,20 @@ build-depends: aeson >= 0.8 , attoparsec >= 0.11.3 - , base >= 4.7 && < 5 + , base >= 4.7 && < 5 + , bifunctors >= 0.1 , bytestring >= 0.9 , case-insensitive >= 1.2 , conduit >= 1.1 , dlist >= 0.7 , exceptions >= 0.6 , hashable >= 1.2 + , http-api-data >= 0.2 , http-client >= 0.4.4 , http-media >= 0.6 , http-types >= 0.8.6 , lens >= 4.4 + , memory >= 0.8 , resourcet >= 1.1 , scientific >= 0.3 , servant >= 0.4.4 @@ -72,7 +76,7 @@ , time >= 1.2 && < 1.5 else build-depends: - time >= 1.5 && < 1.6 + time >= 1.5 test-suite tests type: exitcode-stdio-1.0 diff --git a/src/Network/Google/Data/Base64.hs b/src/Network/Google/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Network/Google/Data/Base64.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Network.Google.Data.Base64 +-- Copyright : (c) 2013-2016 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +-- +module Network.Google.Data.Base64 + ( Base64 (..) + , _Base64 + ) where + +import Control.Lens (Iso', iso) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.ByteArray.Encoding as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Data (Data, Typeable) +import Data.Hashable +import qualified Data.Text.Encoding as Text +import GHC.Generics (Generic) +import Network.Google.Data.JSON (parseJSONText, toJSONText) +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) + +-- | Base64 encoded binary data. +-- +-- Encoding\/decoding is automatically deferred to serialisation and deserialisation +-- respectively. +newtype Base64 = Base64 { unBase64 :: ByteString } + deriving (Eq, Read, Ord, Data, Typeable, Generic) + +instance Hashable Base64 + +_Base64 :: Iso' Base64 ByteString +_Base64 = iso unBase64 Base64 + +instance ToHttpApiData Base64 where + toQueryParam = Text.decodeUtf8 . toHeader + toHeader = BA.convertToBase BA.Base64 . unBase64 + +instance FromHttpApiData Base64 where + parseQueryParam = parseHeader . Text.encodeUtf8 + parseHeader = either fail (pure . Base64) . BA.convertFromBase BA.Base64 + +instance Show Base64 where show = show . BS8.unpack . unBase64 +instance FromJSON Base64 where parseJSON = parseJSONText "Base64" +instance ToJSON Base64 where toJSON = toJSONText diff --git a/src/Network/Google/Data/JSON.hs b/src/Network/Google/Data/JSON.hs --- a/src/Network/Google/Data/JSON.hs +++ b/src/Network/Google/Data/JSON.hs @@ -4,7 +4,7 @@ -- | -- Module : Network.Google.Data.JSON --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : provisional @@ -37,28 +37,39 @@ import Data.HashMap.Strict (HashMap) import Data.Text (Text) import qualified Data.Text as Text -import Servant.API +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) type JSONValue = Value newtype Textual a = Textual a - deriving (Eq, Ord, Read, Show, Num, Fractional, Data, Typeable, FromText, ToText) + deriving + ( Eq + , Ord + , Read + , Show + , Num + , Fractional + , Data + , Typeable + , ToHttpApiData + , FromHttpApiData + ) -instance (FromJSON a, FromText a) => FromJSON (Textual a) where +instance (FromJSON a, FromHttpApiData a) => FromJSON (Textual a) where parseJSON (String s) = - case fromText s of - Just x -> pure (Textual x) - Nothing -> fail $ "Failed to parse value from " ++ Text.unpack s + either (fail . Text.unpack) (pure . Textual) (parseQueryParam s) parseJSON o = Textual <$> parseJSON o -instance ToText a => ToJSON (Textual a) where - toJSON (Textual x) = String (toText x) +instance ToHttpApiData a => ToJSON (Textual a) where + toJSON (Textual x) = String (toQueryParam x) parseJSONObject :: FromJSON a => HashMap Text Value -> Parser a parseJSONObject = parseJSON . Object -parseJSONText :: FromText a => String -> Value -> Parser a -parseJSONText n = withText n (maybe (fail n) pure . fromText) +parseJSONText :: FromHttpApiData a => String -> Value -> Parser a +parseJSONText n = withText n (either (fail . f) pure . parseQueryParam) + where + f x = n ++ " - " ++ Text.unpack x -toJSONText :: ToText a => a -> Value -toJSONText = String . toText +toJSONText :: ToHttpApiData a => a -> Value +toJSONText = String . toQueryParam diff --git a/src/Network/Google/Data/Numeric.hs b/src/Network/Google/Data/Numeric.hs --- a/src/Network/Google/Data/Numeric.hs +++ b/src/Network/Google/Data/Numeric.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Network.Google.Data.Numeric --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : provisional @@ -14,10 +15,10 @@ ( Nat (..) ) where -import Control.Lens import Control.Monad import Data.Aeson import Data.Data +import Data.Monoid ((<>)) import Data.Scientific import Data.Text (Text) import qualified Data.Text as Text @@ -47,15 +48,15 @@ instance ToJSON Nat where toJSON = Number . flip scientific 0 . toInteger . unNat -instance ToText Nat where - toText = shortText . Build.decimal +instance ToHttpApiData Nat where + toQueryParam = shortText . Build.decimal -instance FromText Nat where - fromText t = +instance FromHttpApiData Nat where + parseQueryParam t = case Read.decimal t of Right (x, r) | Text.null r - -> Just x - _ -> Nothing + -> Right x + _ -> Left ("Unable to parse natural from: " <> t) shortText :: Builder -> Text shortText = LText.toStrict . Build.toLazyTextWith 32 diff --git a/src/Network/Google/Data/Time.hs b/src/Network/Google/Data/Time.hs --- a/src/Network/Google/Data/Time.hs +++ b/src/Network/Google/Data/Time.hs @@ -4,16 +4,16 @@ -- | -- Module : Network.Google.Data.Time --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : provisional -- Portability : non-portable (GHC extensions) -- module Network.Google.Data.Time - ( Time' (..) - , Date' (..) - , DateTime' (..) + ( Time' + , Date' + , DateTime' , _Time , _Date @@ -22,49 +22,53 @@ import Control.Lens import Data.Aeson -import Data.Aeson.Encode -import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson.Types as Aeson import Data.Attoparsec.Text -import Data.Bits ((.&.)) -import Data.Char (ord) -import Data.Data (Data, Typeable) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LText -import qualified Data.Text.Lazy.Builder as Build +import Data.Bifunctor (first, second) +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Data (Data, Typeable) +import Data.Text (Text) +import qualified Data.Text as Text import Data.Time import GHC.Generics -import Servant.Common.Text +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) -- | This SHOULD be a time in the format of hh:mm:ss. It is -- recommended that you use the "date-time" format instead of "time" -- unless you need to transfer only the time part. -newtype Time' = Time' TimeOfDay +newtype Time' = Time' { unTime :: TimeOfDay } deriving (Eq, Ord, Show, Read, Generic, Data, Typeable) _Time :: Iso' Time' TimeOfDay -_Time = iso (\(Time' t) -> t) Time' +_Time = iso unTime Time' +instance ToHttpApiData Time' where + toQueryParam = Text.pack . show . unTime + +instance FromHttpApiData Time' where + parseQueryParam = second Time' . parseText timeParser + -- | This SHOULD be a date in the format of YYYY-MM-DD. It is -- recommended that you use the "date-time" format instead of "date" -- unless you need to transfer only the date part. -newtype Date' = Date' Day - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable) +newtype Date' = Date' { unDate :: Day } + deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToHttpApiData, FromHttpApiData) _Date :: Iso' Date' Day -_Date = iso (\(Date' t) -> t) Date' +_Date = iso unDate Date' -- | This SHOULD be a date in ISO 8601 format of YYYY-MM- -- DDThh:mm:ssZ in UTC time. This is the recommended form of date/timestamp. -newtype DateTime' = DateTime' UTCTime - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable) +newtype DateTime' = DateTime' { unDateTime :: UTCTime } + deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToHttpApiData, FromHttpApiData) _DateTime :: Iso' DateTime' UTCTime -_DateTime = iso (\(DateTime' t) -> t) DateTime' +_DateTime = iso unDateTime DateTime' -instance FromText Time' where fromText = fmap Time' . parseText timeParser -instance FromText Date' where fromText = fmap Date' . parseText dayParser -instance FromText DateTime' where fromText = Aeson.parseMaybe parseJSON . String +instance ToJSON Time' where toJSON = String . toQueryParam +instance ToJSON Date' where toJSON = String . toQueryParam +instance ToJSON DateTime' where toJSON = toJSON . unDateTime instance FromJSON Time' where parseJSON = fmap Time' . withText "time" (run timeParser) @@ -75,21 +79,8 @@ instance FromJSON DateTime' where parseJSON = fmap DateTime' . parseJSON --- FIXME: Revisit once aeson-0.10 is more widely available. -instance ToText Time' where toText = Text.pack . show . view _Time -instance ToText Date' where toText = Text.pack . show . view _Date -instance ToText DateTime' where toText = encodeText - --- FIXME: Revisit once aeson-0.10 is more widely available. -instance ToJSON Time' where toJSON = String . toText -instance ToJSON Date' where toJSON = String . toText -instance ToJSON DateTime' where toJSON = toJSON . view _DateTime - -parseText :: Parser a -> Text -> Maybe a -parseText p = either (const Nothing) Just . parseOnly p - -encodeText :: ToJSON a => a -> Text -encodeText = LText.toStrict . Build.toLazyText . encodeToTextBuilder . toJSON +parseText :: Parser a -> Text -> Either Text a +parseText p = first Text.pack . parseOnly p -- | Parse a time of the form @HH:MM:SS@. timeParser :: Parser TimeOfDay diff --git a/src/Network/Google/Prelude.hs b/src/Network/Google/Prelude.hs --- a/src/Network/Google/Prelude.hs +++ b/src/Network/Google/Prelude.hs @@ -1,6 +1,6 @@ -- | -- Module : Network.Google.Prelude --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : provisional @@ -10,26 +10,28 @@ ( module Export ) where -import Control.Applicative as Export (pure, (<$>), (<*>)) -import Control.Lens as Export (Lens', lens, mapping, - ( # ), (^.), _Just) -import Data.Data as Export (Data, Typeable) -import Data.Hashable as Export -import Data.HashMap.Strict as Export (HashMap) -import Data.Int as Export (Int32, Int64) -import Data.Maybe as Export -import Data.Monoid as Export (mempty, (<>)) -import Data.Proxy as Export -import Data.Text as Export (Text) -import Data.Time as Export (Day, TimeOfDay, UTCTime) -import Data.Word as Export (Word32, Word64, Word8) -import GHC.Generics as Export (Generic) -import Network.Google.Data.JSON as Export -import Network.Google.Data.Numeric as Export -import Network.Google.Data.Time as Export -import Network.Google.Types as Export -import Network.HTTP.Client as Export (RequestBody) -import Numeric.Natural as Export (Natural) -import Prelude as Export hiding (product) -import Servant.API as Export hiding (getResponse) -import Servant.Utils.Links as Export hiding (Link) +import Control.Lens as Export (Lens', lens, mapping, ( # ), (^.), _Just) +import Data.ByteString as Export (ByteString) +import Data.Data as Export (Data, Typeable) +import Data.Hashable as Export +import Data.HashMap.Strict as Export (HashMap) +import Data.Int as Export (Int32, Int64) +import Data.Maybe as Export +import Data.Monoid as Export (mempty, (<>)) +import Data.Proxy as Export +import Data.Text as Export (Text) +import Data.Time as Export (Day, TimeOfDay, UTCTime) +import Data.Word as Export (Word32, Word64, Word8) +import GHC.Generics as Export (Generic) +import Network.HTTP.Client as Export (RequestBody) +import Numeric.Natural as Export (Natural) +import Prelude as Export hiding (product) +import Servant.API as Export hiding (getResponse) +import Servant.Utils.Links as Export hiding (Link) +import Web.HttpApiData as Export (FromHttpApiData (..), ToHttpApiData (..)) + +import Network.Google.Data.Base64 as Export +import Network.Google.Data.JSON as Export +import Network.Google.Data.Numeric as Export +import Network.Google.Data.Time as Export +import Network.Google.Types as Export diff --git a/src/Network/Google/Types.hs b/src/Network/Google/Types.hs --- a/src/Network/Google/Types.hs +++ b/src/Network/Google/Types.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -15,7 +16,7 @@ -- | -- Module : Network.Google.Types --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : provisional @@ -24,66 +25,145 @@ module Network.Google.Types where import Control.Applicative -import Control.Exception.Lens (exception) -import Control.Lens hiding (coerce) +import Control.Exception.Lens (exception) +import Control.Lens import Control.Monad.Catch import Control.Monad.Trans.Resource import Data.Aeson -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.CaseInsensitive as CI +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI import Data.Coerce import Data.Conduit -import qualified Data.Conduit.List as CL +import qualified Data.Conduit.List as CL import Data.Data -import Data.DList (DList) -import qualified Data.DList as DList -import Data.Foldable (foldl') +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Foldable (foldl') import Data.Monoid import Data.String -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as Build +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as Build import GHC.Generics import GHC.TypeLits -import Network.HTTP.Client (HttpException, RequestBody (..)) -import Network.HTTP.Media hiding (Accept) -import Network.HTTP.Types hiding (Header) -import qualified Network.HTTP.Types as HTTP +import Network.HTTP.Client (HttpException, RequestBody (..)) +import Network.HTTP.Media hiding (Accept) +import Network.HTTP.Types hiding (Header) +import qualified Network.HTTP.Types as HTTP import Servant.API +import Web.HttpApiData -data AltJSON = AltJSON - deriving (Eq, Ord, Show, Read, Generic, Typeable) +data AltJSON = AltJSON deriving (Eq, Ord, Show, Read, Generic, Typeable) +data AltMedia = AltMedia deriving (Eq, Ord, Show, Read, Generic, Typeable) +data Multipart = Multipart deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance ToText AltJSON where - toText = const "json" +instance ToHttpApiData AltJSON where toQueryParam = const "json" +instance ToHttpApiData AltMedia where toQueryParam = const "media" +instance ToHttpApiData Multipart where toQueryParam = const "multipart" -data AltMedia = AltMedia - deriving (Eq, Ord, Show, Read, Generic, Typeable) +-- | An OAuth2 scope. +newtype OAuthScope = OAuthScope Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -instance ToText AltMedia where - toText = const "media" +-- | An OAuth2 access token. +newtype AccessToken = AccessToken Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -newtype AuthKey = AuthKey Text - deriving (Eq, Ord, Show, Read, Generic, Typeable, ToText, FromJSON, ToJSON) +-- | An OAuth2 refresh token. +newtype RefreshToken = RefreshToken Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -newtype OAuthScope = OAuthScope { scopeToText :: Text } - deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON) +-- | A client identifier. +newtype ClientId = ClientId Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -newtype OAuthToken = OAuthToken { tokenToBS :: ByteString } - deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable) +-- | A service identifier. +newtype ServiceId = ServiceId Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -instance FromJSON OAuthToken where - parseJSON = withText "oauth_token" (pure . OAuthToken . Text.encodeUtf8) +-- | An opaque client secret. +newtype Secret = Secret Text + deriving + ( Eq + , Ord + , Read + , IsString + , Generic + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) -instance ToJSON OAuthToken where - toJSON = toJSON . Text.decodeUtf8 . tokenToBS +instance Show Secret where + show = const "*****" newtype MediaDownload a = MediaDownload a - -data MediaUpload a = MediaUpload a RequestBody +data MediaUpload a = MediaUpload a Body _Coerce :: (Coercible a b, Coercible b a) => Iso' a b _Coerce = iso coerce coerce @@ -98,12 +178,6 @@ type Stream = ResumableSource (ResourceT IO) ByteString -newtype ClientId = ClientId { clientIdToText :: Text } - deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON) - -newtype ServiceId = ServiceId { serviceIdToText :: Text } - deriving (Eq, Ord, Show, Read, IsString, Generic, Typeable, ToText, FromJSON, ToJSON) - data Error = TransportError HttpException | SerializeError SerializeError @@ -163,7 +237,7 @@ ServiceError e -> Right e x -> Left x -data Service = Service +data ServiceConfig = ServiceConfig { _svcId :: !ServiceId , _svcHost :: !ByteString , _svcPath :: !Builder @@ -172,8 +246,8 @@ , _svcTimeout :: !(Maybe Seconds) } -defaultService :: ServiceId -> ByteString -> Service -defaultService i h = Service +defaultService :: ServiceId -> ByteString -> ServiceConfig +defaultService i h = ServiceConfig { _svcId = i , _svcHost = h , _svcPath = mempty @@ -182,48 +256,65 @@ , _svcTimeout = Just 70 } -serviceHost :: Lens' Service ByteString +-- | The remote host name, used for both the IP address to connect to and the +-- host request header. +serviceHost :: Lens' ServiceConfig ByteString serviceHost = lens _svcHost (\s a -> s { _svcHost = a }) -servicePath :: Lens' Service Builder -servicePath = lens _svcPath (\s a -> s { _svcPath = a }) - -servicePort :: Lens' Service Int +-- | The remote port to connect to. +-- +-- Defaults to @443@. +servicePort :: Lens' ServiceConfig Int servicePort = lens _svcPort (\s a -> s { _svcPort = a }) -serviceSecure :: Lens' Service Bool +-- | A path prefix that is prepended to any sent HTTP request. +-- +-- Defaults to @mempty@. +servicePath :: Lens' ServiceConfig Builder +servicePath = lens _svcPath (\s a -> s { _svcPath = a }) + +-- | Whether to use HTTPS/SSL. +-- +-- Defaults to @True@. +serviceSecure :: Lens' ServiceConfig Bool serviceSecure = lens _svcSecure (\s a -> s { _svcSecure = a }) -serviceTimeout :: Lens' Service (Maybe Seconds) +-- | Number of seconds to wait for a response. +serviceTimeout :: Lens' ServiceConfig (Maybe Seconds) serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a }) --- | A single part of a multipart message. -data Part = Part MediaType [(HeaderName, ByteString)] RequestBody +-- | A single part of a (potentially multipart) request body. +-- +-- /Note:/ The 'IsString' instance defaults to a @text/plain@ MIME type. +data Body = Body !MediaType !RequestBody -data Payload - = Body !MediaType !RequestBody - | Related ![Part] +instance IsString Body where + fromString = Body ("text" // "plain") . fromString +-- | A lens into the 'MediaType' of a request 'Body'. +bodyContentType :: Lens' Body MediaType +bodyContentType = lens (\(Body m _) -> m) (\(Body _ b) m -> Body m b) + -- | An intermediary request builder. data Request = Request { _rqPath :: !Builder , _rqQuery :: !(DList (ByteString, Maybe ByteString)) , _rqHeaders :: !(DList (HeaderName, ByteString)) - , _rqBody :: !(Maybe Payload) + , _rqBody :: ![Body] } instance Monoid Request where - mempty = Request mempty mempty mempty Nothing + mempty = Request mempty mempty mempty mempty mappend a b = Request - (_rqPath a <> "/" <> _rqPath b) - (_rqQuery a <> _rqQuery b) - (_rqHeaders a <> _rqHeaders b) - (_rqBody b <|> _rqBody a) + (_rqPath a <> "/" <> _rqPath b) + (_rqQuery a <> _rqQuery b) + (_rqHeaders a <> _rqHeaders b) + (_rqBody b <> _rqBody a) appendPath :: Request -> Builder -> Request appendPath rq x = rq { _rqPath = _rqPath rq <> "/" <> x } -appendPaths :: ToText a => Request -> [a] -> Request +appendPaths :: ToHttpApiData a => Request -> [a] -> Request appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText) appendQuery :: Request -> ByteString -> Maybe Text -> Request @@ -237,29 +328,36 @@ { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v) } -setBody :: Request -> MediaType -> RequestBody -> Request -setBody rq c x = rq { _rqBody = Just (Body c x) } - -setRelated :: Request -> [Part] -> Request -setRelated rq ps = rq { _rqBody = Just (Related ps) } +setBody :: Request -> [Body] -> Request +setBody rq bs = rq { _rqBody = bs } -- | A materialised 'http-client' request and associated response parser. data Client a = Client { _cliAccept :: !(Maybe MediaType) , _cliMethod :: !Method , _cliCheck :: !(Status -> Bool) - , _cliService :: !Service + , _cliService :: !ServiceConfig , _cliRequest :: !Request , _cliResponse :: !(Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) } -clientService :: Lens' (Client a) Service +clientService :: Lens' (Client a) ServiceConfig clientService = lens _cliService (\s a -> s { _cliService = a }) -mime :: FromStream c a => Proxy c -> Method -> [Int] -> Request -> Service -> Client a +mime :: FromStream c a + => Proxy c + -> Method + -> [Int] + -> Request + -> ServiceConfig + -> Client a mime p = client (fromStream p) (Just (contentType p)) -discard :: Method -> [Int] -> Request -> Service -> Client () +discard :: Method + -> [Int] + -> Request + -> ServiceConfig + -> Client () discard = client (\b -> closeResumableSource b >> pure (Right ())) Nothing client :: (Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) @@ -267,7 +365,7 @@ -> Method -> [Int] -> Request - -> Service + -> ServiceConfig -> Client a client f cs m ns rq s = Client { _cliAccept = cs @@ -279,25 +377,22 @@ } class Accept c => ToBody c a where - toBody :: Proxy c -> a -> RequestBody - -instance ToBody OctetStream RequestBody where - toBody Proxy = id + toBody :: Proxy c -> a -> Body instance ToBody OctetStream ByteString where - toBody Proxy = RequestBodyBS + toBody p = Body (contentType p) . RequestBodyBS instance ToBody OctetStream LBS.ByteString where - toBody Proxy = RequestBodyLBS + toBody p = Body (contentType p) . RequestBodyLBS instance ToBody PlainText ByteString where - toBody Proxy = RequestBodyBS + toBody p = Body (contentType p) . RequestBodyBS instance ToBody PlainText LBS.ByteString where - toBody Proxy = RequestBodyLBS + toBody p = Body (contentType p) . RequestBodyLBS instance ToJSON a => ToBody JSON a where - toBody Proxy = RequestBodyLBS . encode + toBody p = Body (contentType p) . RequestBodyLBS . encode class Accept c => FromStream c a where fromStream :: Proxy c @@ -315,7 +410,8 @@ Right x -> pure $! Right x class GoogleRequest a where - type Rs a :: * + type Rs a :: * + type Scopes a :: [Symbol] requestClient :: a -> Client (Rs a) @@ -332,24 +428,25 @@ data CaptureMode (s :: Symbol) (m :: Symbol) a deriving (Typeable) -data MultipartRelated (cs :: [*]) m b +data MultipartRelated (cs :: [*]) m deriving (Typeable) instance ( ToBody c m - , ToBody OctetStream b , GoogleClient fn - ) => GoogleClient (MultipartRelated (c ': cs) m b :> fn) where - type Fn (MultipartRelated (c ': cs) m b :> fn) = m -> b -> Fn fn + ) => GoogleClient (MultipartRelated (c ': cs) m :> fn) where + type Fn (MultipartRelated (c ': cs) m :> fn) = m -> Body -> Fn fn - buildClient Proxy rq m b = buildClient (Proxy :: Proxy fn) $ - setRelated rq - [ Part (contentType mc) [] (toBody mc m) - , Part (contentType mb) [] (toBody mb b) - ] - where - mc = Proxy :: Proxy c - mb = Proxy :: Proxy OctetStream + buildClient Proxy rq m b = + buildClient (Proxy :: Proxy fn) $ + setBody rq [toBody (Proxy :: Proxy c) m, b] +instance GoogleClient fn => GoogleClient (AltMedia :> fn) where + type Fn (AltMedia :> fn) = Body -> Fn fn + + buildClient Proxy rq b = + buildClient (Proxy :: Proxy fn) $ + setBody rq [b] + instance (KnownSymbol s, GoogleClient fn) => GoogleClient (s :> fn) where type Fn (s :> fn) = Fn fn @@ -363,9 +460,9 @@ buildClient (Proxy :: Proxy a) rq :<|> buildClient (Proxy :: Proxy b) rq -instance ( KnownSymbol s - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (Capture s a :> fn) where type Fn (Capture s a :> fn) = a -> Fn fn @@ -373,19 +470,19 @@ . appendPath rq . buildText -instance ( KnownSymbol s - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (Captures s a :> fn) where type Fn (Captures s a :> fn) = [a] -> Fn fn buildClient Proxy rq = buildClient (Proxy :: Proxy fn) . appendPaths rq -instance ( KnownSymbol s - , KnownSymbol m - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , KnownSymbol m + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (CaptureMode s m a :> fn) where type Fn (CaptureMode s m a :> fn) = a -> Fn fn @@ -393,9 +490,9 @@ . appendPath rq $ buildText x <> buildSymbol (Proxy :: Proxy m) -instance ( KnownSymbol s - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (QueryParam s a :> fn) where type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn @@ -405,23 +502,23 @@ Just x -> appendQuery rq k v where k = byteSymbol (Proxy :: Proxy s) - v = Just (toText x) + v = Just (toQueryParam x) -instance ( KnownSymbol s - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (QueryParams s a :> fn) where type Fn (QueryParams s a :> fn) = [a] -> Fn fn buildClient Proxy rq = buildClient (Proxy :: Proxy fn) . foldl' go rq where - go r = appendQuery r k . Just . toText + go r = appendQuery r k . Just . toQueryParam k = byteSymbol (Proxy :: Proxy s) -instance ( KnownSymbol s - , ToText a - , GoogleClient fn +instance ( KnownSymbol s + , ToHttpApiData a + , GoogleClient fn ) => GoogleClient (Header s a :> fn) where type Fn (Header s a :> fn) = Maybe a -> Fn fn @@ -431,84 +528,82 @@ Just x -> appendHeader rq (CI.mk k) v where k = byteSymbol (Proxy :: Proxy s) - v = Just (toText x) + v = Just (toQueryParam x) instance ( ToBody c a , GoogleClient fn ) => GoogleClient (ReqBody (c ': cs) a :> fn) where type Fn (ReqBody (c ': cs) a :> fn) = a -> Fn fn - buildClient Proxy rq = buildClient (Proxy :: Proxy fn) - . setBody rq (contentType p) - . toBody p - where - p = Proxy :: Proxy c + buildClient Proxy rq x = + buildClient (Proxy :: Proxy fn) $ + setBody rq [toBody (Proxy :: Proxy c) x] instance {-# OVERLAPPABLE #-} FromStream c a => GoogleClient (Get (c ': cs) a) where - type Fn (Get (c ': cs) a) = Service -> Client a + type Fn (Get (c ': cs) a) = ServiceConfig -> Client a buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203] instance {-# OVERLAPPING #-} GoogleClient (Get (c ': cs) ()) where - type Fn (Get (c ': cs) ()) = Service -> Client () + type Fn (Get (c ': cs) ()) = ServiceConfig -> Client () buildClient Proxy = discard methodGet [204] instance {-# OVERLAPPABLE #-} (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where - type Fn (Post cs' a) = Service -> Client a + type Fn (Post cs' a) = ServiceConfig -> Client a buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201] instance {-# OVERLAPPING #-} GoogleClient (Post cs ()) where - type Fn (Post cs ()) = Service -> Client () + type Fn (Post cs ()) = ServiceConfig -> Client () buildClient Proxy = discard methodPost [204] instance {-# OVERLAPPABLE #-} FromStream c a => GoogleClient (Put (c ': cs) a) where - type Fn (Put (c ': cs) a) = Service -> Client a + type Fn (Put (c ': cs) a) = ServiceConfig -> Client a buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201] instance {-# OVERLAPPING #-} GoogleClient (Put (c ': cs) ()) where - type Fn (Put (c ': cs) ()) = Service -> Client () + type Fn (Put (c ': cs) ()) = ServiceConfig -> Client () buildClient Proxy = discard methodPut [204] instance {-# OVERLAPPABLE #-} FromStream c a => GoogleClient (Patch (c ': cs) a) where - type Fn (Patch (c ': cs) a) = Service -> Client a + type Fn (Patch (c ': cs) a) = ServiceConfig -> Client a buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201] instance {-# OVERLAPPING #-} GoogleClient (Patch (c ': cs) ()) where - type Fn (Patch (c ': cs) ()) = Service -> Client () + type Fn (Patch (c ': cs) ()) = ServiceConfig -> Client () buildClient Proxy = discard methodPatch [204] instance {-# OVERLAPPABLE #-} FromStream c a => GoogleClient (Delete (c ': cs) a) where - type Fn (Delete (c ': cs) a) = Service -> Client a + type Fn (Delete (c ': cs) a) = ServiceConfig -> Client a buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202] instance {-# OVERLAPPING #-} - GoogleClient (Delete (c ': cs) ()) where - type Fn (Delete (c ': cs) ()) = Service -> Client () + GoogleClient (Delete (c ': cs) ()) where + type Fn (Delete (c ': cs) ()) = ServiceConfig -> Client () buildClient Proxy = discard methodDelete [204] sinkLBS :: Stream -> ResourceT IO LBS.ByteString sinkLBS = fmap LBS.fromChunks . ($$+- CL.consume) -buildText :: ToText a => a -> Builder -buildText = Build.fromText . toText +buildText :: ToHttpApiData a => a -> Builder +buildText = Build.fromText . toQueryParam buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder buildSymbol = Build.fromString . symbolVal @@ -540,3 +635,19 @@ microseconds :: Seconds -> Int microseconds = (1000000 *) . seconds + +newtype FieldMask = FieldMask Text + deriving + ( Eq + , Ord + , Show + , Read + , IsString + , Generic + , Data + , Typeable + , FromHttpApiData + , ToHttpApiData + , FromJSON + , ToJSON + ) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,5 @@ -- Module : Main --- Copyright : (c) 2015 Brendan Hay +-- Copyright : (c) 2015-2016 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental