diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/gogol-core.cabal b/gogol-core.cabal --- a/gogol-core.cabal +++ b/gogol-core.cabal @@ -1,93 +1,77 @@ -name: gogol-core -version: 0.5.0 -synopsis: Core data types and functionality for Gogol libraries. -homepage: https://github.com/brendanhay/gogol -bug-reports: https://github.com/brendanhay/gogol/issues -license: OtherLicense -license-file: LICENSE -author: Brendan Hay -maintainer: Brendan Hay -copyright: Copyright (c) 2015-2016 Brendan Hay -category: Network, Google, Cloud -build-type: Simple -extra-source-files: README.md -cabal-version: >= 1.10 +cabal-version: 2.2 +name: gogol-core +version: 1.0.0.0 +synopsis: Core data types and functionality for Gogol libraries. +homepage: https://github.com/brendanhay/gogol +bug-reports: https://github.com/brendanhay/gogol/issues +license: MPL-2.0 +license-file: LICENSE +author: Brendan Hay +maintainer: + Brendan Hay , Toni Cebrián +copyright: Copyright (c) 2015-2025 Brendan Hay +category: Google +build-type: Simple +extra-source-files: README.md description: - Core data types, functionality and serialisation primitives for - Gogol related Google Services SDKs. - . - The external interface of this library is stable with respect to the - downstream Gogol libraries, only, and as such is not suitable - for use in non-Gogol projects. + Core data types, functionality and serialisation primitives for + Gogol related Google Services SDKs. + . + The external interface of this library is stable with respect to the + downstream Gogol libraries, only, and as such is not suitable + for use in non-Gogol projects. source-repository head - type: git - location: git://github.com/brendanhay/gogol.git - -flag old-locale - description: Use old-locale and time < 1.5 - default: False + type: git + location: git://github.com/brendanhay/gogol.git library - default-language: Haskell2010 - hs-source-dirs: src - - ghc-options: -Wall - - exposed-modules: - Network.Google.Data.Bytes - , Network.Google.Data.JSON - , Network.Google.Data.Numeric - , Network.Google.Data.Time - , Network.Google.Prelude - , Network.Google.Types - - build-depends: - aeson >= 0.8 - , attoparsec >= 0.11.3 - , base >= 4.7 && < 5 - , bifunctors >= 0.1 - , bytestring >= 0.9 - , case-insensitive >= 1.2 - , conduit >= 1.3 - , dlist >= 0.7 - , exceptions >= 0.6 - , hashable >= 1.2 - , http-api-data >= 0.2 - , http-client >= 0.5 && < 1 - , http-media >= 0.6 - , http-types >= 0.8.6 - , lens >= 4.4 - , resourcet >= 1.1 - , scientific >= 0.3 - , servant >= 0.4.4 - , text >= 1.1 - , unordered-containers >= 0.2.5 + default-language: GHC2021 + hs-source-dirs: src + ghc-options: + -Wall -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates -funbox-strict-fields + -fwarn-unused-packages - if !impl(ghc>=7.9) - build-depends: - nats >= 0.1.3 + exposed-modules: + Gogol.Data.Base64 + Gogol.Data.JSON + Gogol.Data.Time + Gogol.Prelude + Gogol.Types - if flag(old-locale) - build-depends: - old-locale == 1.* - , time >= 1.2 && < 1.5 - else - build-depends: - time >= 1.5 + build-depends: + , aeson >=0.8 && <2.3 + , attoparsec >=0.11.3 && <0.15 + , base >=4.12 && <5 + , base64 >=1.0 && <1.1 + , bytestring >=0.9 && <0.14 + , case-insensitive >=1.2 && <1.3 + , conduit >=1.3 && <1.4 + , dlist >=0.7 && <1.1 + , exceptions >=0.6 && <0.12 + , hashable >=1.2 && <1.6 + , http-api-data >=0.2 && <0.7 + , http-client >=0.5 && <1 + , http-media >=0.6 && <0.9 + , http-types >=0.8.6 && <0.13 + , lens >=4.4 && <5.4 + , resourcet >=1.1 && <1.4 + , scientific >=0.3 && <0.4 + , servant >=0.20.1 && <0.21 + , text >=1.1 && <2.2 + , time >=1.2 && <2 + , unordered-containers >=0.2.5 && <0.3 test-suite tests - type: exitcode-stdio-1.0 - default-language: Haskell2010 - hs-source-dirs: test - main-is: Main.hs - - ghc-options: -Wall -threaded - - other-modules: - - build-depends: - gogol-core - , base - , tasty + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wall -threaded + other-modules: + build-depends: + , base + , gogol-core + , tasty diff --git a/src/Gogol/Data/Base64.hs b/src/Gogol/Data/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Data/Base64.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module : Gogol.Data.Base64 +-- Copyright : (c) 2013-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Data.Base64 + ( Base64 (..), + _Base64, + ) +where + +import Control.Lens (Iso', iso) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Base64.Types qualified as Base64 +import Data.ByteString (ByteString) +import Data.ByteString.Base64 qualified as Base64 +import Data.Hashable +import Data.Text.Encoding qualified as Text +import GHC.Generics (Generic) +import Gogol.Data.JSON (parseJSONText, toJSONText) +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + +-- | Raw bytes that will be transparently base64 encoded\/decoded +-- on tramission to\/from a remote API. +newtype Base64 = Base64 {fromBase64 :: ByteString} + deriving (Eq, Show, Read, Ord, Generic, Hashable) + +_Base64 :: Iso' Base64 ByteString +_Base64 = iso fromBase64 Base64 + +instance ToHttpApiData Base64 where + toUrlPiece = Base64.extractBase64 . Base64.encodeBase64 . fromBase64 + toQueryParam = Base64.extractBase64 . Base64.encodeBase64 . fromBase64 + toHeader = Base64.extractBase64 . Base64.encodeBase64' . fromBase64 + +instance FromHttpApiData Base64 where + parseUrlPiece = fmap Base64 . Base64.decodeBase64Untyped . Text.encodeUtf8 + parseQueryParam = fmap Base64 . Base64.decodeBase64Untyped . Text.encodeUtf8 + parseHeader = fmap Base64 . Base64.decodeBase64Untyped + +instance FromJSON Base64 where + parseJSON = parseJSONText "Base64" + +instance ToJSON Base64 where + toJSON = toJSONText diff --git a/src/Gogol/Data/JSON.hs b/src/Gogol/Data/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Data/JSON.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Gogol.Data.JSON +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Data.JSON + ( Value, + AsText (..), + parseJSONObject, + parseJSONText, + toJSONText, + + -- * Re-exports + FromJSON (..), + FromJSONKey (..), + ToJSON (..), + ToJSONKey (..), + withObject, + emptyObject, + object, + (.=), + (.:), + (.:?), + (.!=), + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Text qualified as Text +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.KeyMap (KeyMap) +#else +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +#endif + +newtype AsText a = AsText {fromAsText :: a} + deriving (Eq, Ord, Read, Show, Num, Fractional, ToHttpApiData, FromHttpApiData) + +instance (FromJSON a, FromHttpApiData a) => FromJSON (AsText a) where + parseJSON (String s) = either (fail . Text.unpack) (pure . AsText) (parseQueryParam s) + parseJSON o = AsText <$> parseJSON o + +instance (ToHttpApiData a) => ToJSON (AsText a) where + toJSON (AsText x) = String (toQueryParam x) + +#if MIN_VERSION_aeson(2,0,0) +parseJSONObject :: FromJSON a => KeyMap Value -> Parser a +#else +parseJSONObject :: FromJSON a => HashMap Text Value -> Parser a +#endif +parseJSONObject = parseJSON . toJSON + +parseJSONText :: (FromHttpApiData a) => String -> Value -> Parser a +parseJSONText n = withText n (either (fail . f) pure . parseQueryParam) + where + f x = n ++ " - " ++ Text.unpack x + +toJSONText :: (ToHttpApiData a) => a -> Value +toJSONText = String . toQueryParam diff --git a/src/Gogol/Data/Time.hs b/src/Gogol/Data/Time.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Data/Time.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Gogol.Data.Time +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Data.Time + ( Time (..), + Date (..), + DateTime (..), + Duration (..), + _Time, + _Date, + _DateTime, + _Duration, + ) +where + +import Control.Lens +import Data.Aeson +import Data.Aeson.Types qualified as Aeson +import Data.Attoparsec.Text +import Data.Bifunctor (first, second) +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Scientific (Scientific) +import Data.Scientific qualified as Sci +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Lazy qualified as LText +import Data.Text.Lazy.Builder qualified as Build +import Data.Text.Lazy.Builder.Scientific qualified as Sci +import Data.Time +import GHC.Generics +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 {fromTime :: TimeOfDay} + deriving (Eq, Ord, Show, Read, Generic) + +_Time :: Iso' Time TimeOfDay +_Time = iso fromTime Time + +instance ToHttpApiData Time where + toQueryParam = Text.pack . show . fromTime + +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 {unDate :: Day} + deriving (Eq, Ord, Show, Read, Generic, ToHttpApiData, FromHttpApiData) + +_Date :: Iso' Date Day +_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 {unDateTime :: UTCTime} + deriving (Eq, Ord, Show, Read, Generic, ToHttpApiData, FromHttpApiData) + +_DateTime :: Iso' DateTime UTCTime +_DateTime = iso unDateTime DateTime + +-- | A duration in seconds with up to nine fractional digits, terminated by 's'. +-- +-- /Example/: @"3.5s"@. +newtype Duration = Duration {unDuration :: Scientific} + deriving (Eq, Ord, Show, Read, Generic) + +_Duration :: Iso' Duration Scientific +_Duration = iso unDuration Duration + +instance ToHttpApiData Duration where + toQueryParam = + LText.toStrict + . (\seconds -> Build.toLazyText seconds <> "s") + . Sci.formatScientificBuilder Sci.Fixed (Just 9) + . unDuration + +instance FromHttpApiData Duration where + parseQueryParam = second Duration . parseText durationParser + +instance ToJSON Time where toJSON = String . toQueryParam + +instance ToJSON Date where toJSON = String . toQueryParam + +instance ToJSON DateTime where toJSON = toJSON . unDateTime + +instance ToJSON Duration where toJSON = String . toQueryParam + +instance FromJSON Time where + parseJSON = fmap Time . withText "Time" (run timeParser) + +instance FromJSON Date where + parseJSON = fmap Date . withText "Date" (run dayParser) + +instance FromJSON DateTime where + parseJSON = fmap DateTime . parseJSON + +instance FromJSON Duration where + parseJSON = fmap Duration . withText "Duration" (run durationParser) + +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 +timeParser = do + h <- twoDigits <* char ':' + m <- twoDigits <* char ':' + s <- twoDigits <&> fromIntegral + if h < 24 && m < 60 && s < 61 + then pure (TimeOfDay h m s) + else fail "invalid time" + +-- | Parse a date of the form @YYYY-MM-DD@. +dayParser :: Parser Day +dayParser = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") pure (fromGregorianValid y m d) + +durationParser :: Parser Scientific +durationParser = Sci.fromFloatDigits <$> (double <* char 's') + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + pure $! c2d a * 10 + c2d b + +-- | Run an attoparsec parser as an aeson parser. +run :: Parser a -> Text -> Aeson.Parser a +run p t = + case parseOnly (p <* endOfInput) t of + Left err -> fail $ "could not parse date: " ++ err + Right r -> pure r diff --git a/src/Gogol/Prelude.hs b/src/Gogol/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Prelude.hs @@ -0,0 +1,36 @@ +-- | +-- Module : Gogol.Prelude +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Prelude + ( module Export, + ) +where + +import Control.Lens as Export (Lens', lens, mapping, (#), (^.), _Just) +import Data.ByteString as Export (ByteString) +import Data.Data as Export (Data, Typeable) +import Data.Functor as Export ((<&>)) +import Data.HashMap.Strict as Export (HashMap) +import Data.Hashable as Export (Hashable, hashWithSalt) +import Data.Int as Export (Int32, Int64) +import Data.Maybe as Export +import Data.Proxy as Export +import Data.Scientific as Export (Scientific) +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 Gogol.Data.Base64 as Export +import Gogol.Data.JSON as Export +import Gogol.Data.Time as Export +import Gogol.Types as Export +import Network.HTTP.Client as Export (RequestBody) +import Numeric.Natural as Export (Natural) +import Servant.API as Export hiding (FromHttpApiData, Header, Headers, IsMember, Link, ResponseHeader, Stream, ToHttpApiData, Union, getResponse) +import Servant.Links as Export hiding (Link) +import Web.HttpApiData as Export (FromHttpApiData (..), ToHttpApiData (..)) +import Prelude as Export diff --git a/src/Gogol/Types.hs b/src/Gogol/Types.hs new file mode 100644 --- /dev/null +++ b/src/Gogol/Types.hs @@ -0,0 +1,680 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Gogol.Types +-- Copyright : (c) 2015-2022 Brendan Hay +-- License : Mozilla Public License, v. 2.0. +-- Maintainer : Brendan Hay +-- Stability : provisional +-- Portability : non-portable (GHC extensions) +module Gogol.Types where + +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 Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.CaseInsensitive qualified as CI +import Data.Coerce +import Data.Conduit +import Data.Conduit.Combinators qualified as Conduit +import Data.DList (DList) +import Data.DList qualified as DList +import Data.Data +import Data.Foldable qualified as Foldable +import Data.Kind (Type) +import Data.String +import Data.Text (Text) +import Data.Text.Encoding qualified as Text +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder qualified 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 Network.HTTP.Types qualified as HTTP +import Servant.API hiding (Stream) + +data AltJSON = AltJSON + deriving (Eq, Ord, Show, Read, Generic) + +instance ToHttpApiData AltJSON where + toQueryParam = const "json" + +data AltMedia = AltMedia + deriving (Eq, Ord, Show, Read, Generic) + +instance ToHttpApiData AltMedia where + toQueryParam = const "media" + +data Multipart = Multipart + deriving (Eq, Ord, Show, Read, Generic) + +instance ToHttpApiData Multipart where + toQueryParam = const "multipart" + +-- | An OAuth2 scope. +newtype OAuthScope = OAuthScope Text + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +-- | An OAuth2 access token. +newtype AccessToken = AccessToken Text + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +-- | An OAuth2 refresh token. +newtype RefreshToken = RefreshToken Text + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +-- | A client identifier. +newtype ClientId = ClientId Text + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +-- | A service identifier. +newtype ServiceId = ServiceId Text + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +-- | An opaque client secret. +newtype GSecret = GSecret Text + deriving + ( Eq, + Ord, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) + +instance Show GSecret where + show = const "*****" + +newtype MediaDownload a = MediaDownload a + +data MediaUpload a = MediaUpload a GBody + +_Coerce :: (Coercible a b, Coercible b a) => Iso' a b +_Coerce = iso coerce coerce + +-- | Invalid Iso, exists for ease of composition with the current 'Lens . Iso' +-- chaining to hide internal types from the user. +_Default :: (Monoid a) => Iso' (Maybe a) a +_Default = iso f Just + where + f (Just x) = x + f Nothing = mempty + +type Stream = ConduitM () ByteString (ResourceT IO) () + +data Error + = TransportError HttpException + | SerializeError SerializeError + | ServiceError ServiceError + deriving (Show) + +instance Exception Error + +data SerializeError = SerializeError' + { _serializeId :: !ServiceId, + _serializeHeaders :: [HTTP.Header], + _serializeStatus :: !Status, + _serializeMessage :: !String, + _serializeBody :: !(Maybe LBS.ByteString) + } + deriving (Eq, Show) + +data ServiceError = ServiceError' + { _serviceId :: !ServiceId, + _serviceStatus :: !Status, + _serviceHeaders :: ![HTTP.Header], + _serviceBody :: !(Maybe LBS.ByteString) + } + deriving (Eq, Show) + +class AsError a where + -- | A general Amazonka error. + _Error :: Prism' a Error + + {-# MINIMAL _Error #-} + + -- | An error occured while communicating over HTTP with a remote service. + _TransportError :: Prism' a HttpException + + -- | A serialisation error occured when attempting to deserialise a response. + _SerializeError :: Prism' a SerializeError + + -- | A service specific error returned by the remote service. + _ServiceError :: Prism' a ServiceError + + _TransportError = _Error . _TransportError + _SerializeError = _Error . _SerializeError + _ServiceError = _Error . _ServiceError + +instance AsError SomeException where + _Error = exception + +instance AsError Error where + _Error = id + + _TransportError = prism TransportError $ \case + TransportError e -> Right e + x -> Left x + + _SerializeError = prism SerializeError $ \case + SerializeError e -> Right e + x -> Left x + + _ServiceError = prism ServiceError $ \case + ServiceError e -> Right e + x -> Left x + +data ServiceConfig = ServiceConfig + { _svcId :: !ServiceId, + _svcHost :: !ByteString, + _svcPath :: !Builder, + _svcPort :: !Int, + _svcSecure :: !Bool, + _svcTimeout :: !(Maybe Seconds) + } + +defaultService :: ServiceId -> ByteString -> ServiceConfig +defaultService i h = + ServiceConfig + { _svcId = i, + _svcHost = h, + _svcPath = mempty, + _svcPort = 443, + _svcSecure = True, + _svcTimeout = Just 70 + } + +-- | 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}) + +-- | The remote port to connect to. +-- +-- Defaults to @443@. +servicePort :: Lens' ServiceConfig Int +servicePort = lens _svcPort (\s a -> s {_svcPort = a}) + +-- | 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}) + +-- | 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 (potentially multipart) request body. +-- +-- /Note:/ The 'IsString' instance defaults to a @text/plain@ MIME type. +data GBody = GBody !MediaType !RequestBody + +instance IsString GBody where + fromString = GBody ("text" // "plain") . fromString + +-- | A lens into the 'MediaType' of a request 'Body'. +bodyContentType :: Lens' GBody MediaType +bodyContentType = lens (\(GBody m _) -> m) (\(GBody _ b) m -> GBody m b) + +-- | An intermediary request builder. +data Request = Request + { _rqPath :: !Builder, + _rqQuery :: !(DList (ByteString, Maybe ByteString)), + _rqHeaders :: !(DList (HeaderName, ByteString)), + _rqBody :: ![GBody] + } + +instance Monoid Request where + mempty = Request mempty mempty mempty mempty + mappend = (<>) + +instance Semigroup Request where + a <> b = + Request + (_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 :: (ToHttpApiData a) => Request -> [a] -> Request +appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText) + +appendQuery :: Request -> ByteString -> Maybe Text -> Request +appendQuery rq k v = + rq + { _rqQuery = DList.snoc (_rqQuery rq) (k, Text.encodeUtf8 <$> v) + } + +appendHeader :: Request -> HeaderName -> Maybe Text -> Request +appendHeader rq _ Nothing = rq +appendHeader rq k (Just v) = + rq + { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v) + } + +setBody :: Request -> [GBody] -> Request +setBody rq bs = rq {_rqBody = bs} + +-- | A materialised 'http-client' request and associated response parser. +data GClient a = GClient + { _cliAccept :: !(Maybe MediaType), + _cliMethod :: !Method, + _cliCheck :: !(Status -> Bool), + _cliService :: !ServiceConfig, + _cliRequest :: !Request, + _cliResponse :: !(Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) + } + +clientService :: Lens' (GClient a) ServiceConfig +clientService = lens _cliService (\s a -> s {_cliService = a}) + +mime :: + (FromStream c a) => + Proxy c -> + Method -> + [Int] -> + Request -> + ServiceConfig -> + GClient a +mime p = gClient (fromStream p) (Just (contentType p)) + +discard :: + Method -> + [Int] -> + Request -> + ServiceConfig -> + GClient () +discard = gClient (\b -> runConduit (b .| Conduit.sinkNull) >> pure (Right ())) Nothing + +gClient :: + (Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) -> + Maybe MediaType -> + Method -> + [Int] -> + Request -> + ServiceConfig -> + GClient a +gClient f cs m statuses rq s = + GClient + { _cliAccept = cs, + _cliMethod = m, + _cliCheck = \status -> fromEnum status `elem` statuses, + _cliService = s, + _cliRequest = rq, + _cliResponse = f + } + +class (Accept c) => ToBody c a where + toBody :: Proxy c -> a -> GBody + +instance ToBody OctetStream ByteString where + toBody p = GBody (contentType p) . RequestBodyBS + +instance ToBody OctetStream LBS.ByteString where + toBody p = GBody (contentType p) . RequestBodyLBS + +instance ToBody PlainText ByteString where + toBody p = GBody (contentType p) . RequestBodyBS + +instance ToBody PlainText LBS.ByteString where + toBody p = GBody (contentType p) . RequestBodyLBS + +instance (ToJSON a) => ToBody JSON a where + toBody p = GBody (contentType p) . RequestBodyLBS . encode + +class (Accept c) => FromStream c a where + fromStream :: + Proxy c -> + Stream -> + ResourceT IO (Either (String, LBS.ByteString) a) + +instance FromStream OctetStream Stream where + fromStream Proxy = pure . Right + +instance (FromJSON a) => FromStream JSON a where + fromStream Proxy s = do + bs <- sinkLBS s + case eitherDecode bs of + Left e -> pure $! Left (e, bs) + Right x -> pure $! Right x + +class GoogleRequest a where + type Rs a :: Type + type Scopes a :: [Symbol] + + requestClient :: a -> GClient (Rs a) + +class GoogleClient fn where + type Fn fn :: Type + + buildClient :: Proxy fn -> Request -> Fn fn + +-- | Multiple path captures, with @[xs]@ forming @////...@. +data Captures (s :: Symbol) a + +-- | Form a Google style sub-resource, such as @/:@. +data CaptureMode (s :: Symbol) (m :: Symbol) a + +data MultipartRelated (cs :: [Type]) m + +instance + ( ToBody c m, + GoogleClient fn + ) => + GoogleClient (MultipartRelated (c ': cs) m :> fn) + where + type Fn (MultipartRelated (c ': cs) m :> fn) = m -> GBody -> Fn fn + + 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) = GBody -> 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 + + buildClient Proxy rq = + buildClient (Proxy :: Proxy fn) $ + appendPath rq (buildSymbol (Proxy :: Proxy s)) + +instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where + type Fn (a :<|> b) = Fn a :<|> Fn b + + buildClient Proxy rq = + buildClient (Proxy :: Proxy a) rq + :<|> buildClient (Proxy :: Proxy b) rq + +instance + ( KnownSymbol s, + ToHttpApiData a, + GoogleClient fn + ) => + GoogleClient (Capture s a :> fn) + where + type Fn (Capture s a :> fn) = a -> Fn fn + + buildClient Proxy rq = + buildClient (Proxy :: Proxy fn) + . appendPath rq + . buildText + +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, + ToHttpApiData a, + GoogleClient fn + ) => + GoogleClient (CaptureMode s m a :> fn) + where + type Fn (CaptureMode s m a :> fn) = a -> Fn fn + + buildClient Proxy rq x = + buildClient (Proxy :: Proxy fn) + . appendPath rq + $ buildText x <> ":" <> buildSymbol (Proxy :: Proxy m) + +instance + ( KnownSymbol s, + ToHttpApiData a, + GoogleClient fn + ) => + GoogleClient (QueryParam s a :> fn) + where + type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn + + buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $ + case mx of + Nothing -> rq + Just x -> appendQuery rq k v + where + k = byteSymbol (Proxy :: Proxy s) + v = Just (toQueryParam x) + +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) . Foldable.foldl' go rq + where + go r = appendQuery r k . Just . toQueryParam + + k = byteSymbol (Proxy :: Proxy s) + +instance + ( KnownSymbol s, + ToHttpApiData a, + GoogleClient fn + ) => + GoogleClient (Header s a :> fn) + where + type Fn (Header s a :> fn) = Maybe a -> Fn fn + + buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $ + case mx of + Nothing -> rq + Just x -> appendHeader rq (CI.mk k) v + where + k = byteSymbol (Proxy :: Proxy s) + 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 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) = ServiceConfig -> GClient a + + buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203] + +instance {-# OVERLAPPING #-} GoogleClient (Get (c ': cs) ()) where + type Fn (Get (c ': cs) ()) = ServiceConfig -> GClient () + + buildClient Proxy = discard methodGet [204] + +instance {-# OVERLAPPABLE #-} (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where + type Fn (Post cs' a) = ServiceConfig -> GClient a + + buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201] + +instance {-# OVERLAPPING #-} GoogleClient (Post cs ()) where + type Fn (Post cs ()) = ServiceConfig -> GClient () + + buildClient Proxy = discard methodPost [204] + +instance {-# OVERLAPPABLE #-} (FromStream c a) => GoogleClient (Put (c ': cs) a) where + type Fn (Put (c ': cs) a) = ServiceConfig -> GClient a + + buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201] + +instance {-# OVERLAPPING #-} GoogleClient (Put (c ': cs) ()) where + type Fn (Put (c ': cs) ()) = ServiceConfig -> GClient () + + buildClient Proxy = discard methodPut [204] + +instance {-# OVERLAPPABLE #-} (FromStream c a) => GoogleClient (Patch (c ': cs) a) where + type Fn (Patch (c ': cs) a) = ServiceConfig -> GClient a + + buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201] + +instance {-# OVERLAPPING #-} GoogleClient (Patch (c ': cs) ()) where + type Fn (Patch (c ': cs) ()) = ServiceConfig -> GClient () + + buildClient Proxy = discard methodPatch [204] + +instance {-# OVERLAPPABLE #-} (FromStream c a) => GoogleClient (Delete (c ': cs) a) where + type Fn (Delete (c ': cs) a) = ServiceConfig -> GClient a + + buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202] + +instance {-# OVERLAPPING #-} GoogleClient (Delete (c ': cs) ()) where + type Fn (Delete (c ': cs) ()) = ServiceConfig -> GClient () + + buildClient Proxy = discard methodDelete [204] + +sinkLBS :: Stream -> ResourceT IO LBS.ByteString +sinkLBS = runConduit . (.| Conduit.sinkLazy) + +buildText :: (ToHttpApiData a) => a -> Builder +buildText = Build.fromText . toQueryParam + +buildSymbol :: forall n proxy. (KnownSymbol n) => proxy n -> Builder +buildSymbol = Build.fromString . symbolVal + +byteSymbol :: forall n proxy. (KnownSymbol n) => proxy n -> ByteString +byteSymbol = BS8.pack . symbolVal + +-- | An integral value representing seconds. +newtype Seconds = Seconds Int + deriving + ( Eq, + Ord, + Read, + Show, + Enum, + Num, + Bounded, + Integral, + Real, + Generic + ) + +seconds :: Seconds -> Int +seconds (Seconds n) + | n < 0 = 0 + | otherwise = n + +microseconds :: Seconds -> Int +microseconds = (1000000 *) . seconds + +newtype FieldMask = FieldMask {fromFieldMask :: Text} + deriving + ( Eq, + Ord, + Show, + Read, + IsString, + Generic, + FromHttpApiData, + ToHttpApiData, + FromJSON, + ToJSON + ) diff --git a/src/Network/Google/Data/Bytes.hs b/src/Network/Google/Data/Bytes.hs deleted file mode 100644 --- a/src/Network/Google/Data/Bytes.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module : Network.Google.Data.Bytes --- 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.Bytes - ( Bytes (..) - , _Bytes - ) where - -import Control.Lens (Iso', iso) -import Data.Aeson (FromJSON (..), ToJSON (..)) -import Data.ByteString (ByteString) -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 (..)) --- | Binary data. --- --- This data is passed to/from the serialisation routines as-is, and any --- particular encoding or decoding (say, base64) is left up to the caller. -newtype Bytes = Bytes { unBytes :: ByteString } - deriving (Eq, Show, Read, Ord, Data, Typeable, Generic) - -instance Hashable Bytes - -_Bytes :: Iso' Bytes ByteString -_Bytes = iso unBytes Bytes - -instance ToHttpApiData Bytes where - toQueryParam = Text.decodeUtf8 . unBytes - toHeader = unBytes - -instance FromHttpApiData Bytes where - parseQueryParam = pure . Bytes . Text.encodeUtf8 - parseHeader = pure . Bytes - -instance FromJSON Bytes where parseJSON = parseJSONText "Bytes" -instance ToJSON Bytes where toJSON = toJSONText diff --git a/src/Network/Google/Data/JSON.hs b/src/Network/Google/Data/JSON.hs deleted file mode 100644 --- a/src/Network/Google/Data/JSON.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.Google.Data.JSON --- 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.JSON - ( JSONValue - , Textual (..) - , parseJSONObject - , parseJSONText - , toJSONText - - -- * Re-exports - , FromJSON (..) - , ToJSON (..) - - , withObject - , emptyObject - , object - - , (.=) - , (.:) - , (.:?) - , (.!=) - ) where - -import Data.Aeson -import Data.Aeson.Types -import Data.Data -import Data.HashMap.Strict (HashMap) -import Data.Text (Text) -import qualified Data.Text as Text -import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) - -type JSONValue = Value - -newtype Textual a = Textual a - deriving - ( Eq - , Ord - , Read - , Show - , Num - , Fractional - , Data - , Typeable - , ToHttpApiData - , FromHttpApiData - ) - -instance (FromJSON a, FromHttpApiData a) => FromJSON (Textual a) where - parseJSON (String s) = - either (fail . Text.unpack) (pure . Textual) (parseQueryParam s) - parseJSON o = Textual <$> parseJSON o - -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 :: FromHttpApiData a => String -> Value -> Parser a -parseJSONText n = withText n (either (fail . f) pure . parseQueryParam) - where - f x = n ++ " - " ++ Text.unpack x - -toJSONText :: ToHttpApiData a => a -> Value -toJSONText = String . toQueryParam diff --git a/src/Network/Google/Data/Numeric.hs b/src/Network/Google/Data/Numeric.hs deleted file mode 100644 --- a/src/Network/Google/Data/Numeric.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | --- Module : Network.Google.Data.Numeric --- 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.Numeric - ( Nat (..) - ) where - -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 -import qualified Data.Text.Lazy as LText -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as Build -import qualified Data.Text.Lazy.Builder.Int as Build -import qualified Data.Text.Read as Read -import Numeric.Natural -import Servant.API - -newtype Nat = Nat { unNat :: Natural } - deriving (Eq, Ord, Enum, Show, Read, Num, Real, Integral, Data, Typeable) - -instance FromJSON Nat where - parseJSON = parseJSON >=> go - where - go n = case floatingOrInteger n of - Left (_ :: Double) -> fail (floatErr n) - Right i - | n < 0 -> fail (negateErr n) - | otherwise -> return . Nat $ fromInteger i - - floatErr = mappend "Cannot convert float to Natural: " . show - negateErr = mappend "Cannot convert negative number to Natural: " . show - -instance ToJSON Nat where - toJSON = Number . flip scientific 0 . toInteger . unNat - -instance ToHttpApiData Nat where - toQueryParam = shortText . Build.decimal - -instance FromHttpApiData Nat where - parseQueryParam t = - case Read.decimal t of - Right (x, r) | Text.null r - -> 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 deleted file mode 100644 --- a/src/Network/Google/Data/Time.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- | --- Module : Network.Google.Data.Time --- 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' (..) - , GDuration - - , _Time - , _Date - , _DateTime - , _GDuration - ) where - -import Data.Monoid ((<>)) -import Control.Lens -import Data.Aeson -import qualified Data.Aeson.Types as Aeson -import Data.Attoparsec.Text -import Data.Bifunctor (first, second) -import Data.Bits ((.&.)) -import Data.Char (ord) -import Data.Data (Data, Typeable) -import Data.Scientific (Scientific) -import qualified Data.Scientific as Sci -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 qualified Data.Text.Lazy.Builder.Scientific as Sci -import Data.Time -import GHC.Generics -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' { unTime :: TimeOfDay } - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable) - -_Time :: Iso' Time' TimeOfDay -_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' { unDate :: Day } - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToHttpApiData, FromHttpApiData) - -_Date :: Iso' Date' Day -_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' { unDateTime :: UTCTime } - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, ToHttpApiData, FromHttpApiData) - -_DateTime :: Iso' DateTime' UTCTime -_DateTime = iso unDateTime DateTime' - --- | A duration in seconds with up to nine fractional digits, terminated by 's'. --- --- /Example/: @"3.5s"@. -newtype GDuration = GDuration { unGDuration :: Scientific } - deriving (Eq, Ord, Show, Read, Generic, Data, Typeable) - -_GDuration :: Iso' GDuration Scientific -_GDuration = iso unGDuration GDuration - -instance ToHttpApiData GDuration where - toQueryParam = - LText.toStrict - . (\seconds -> Build.toLazyText seconds <> "s") - . Sci.formatScientificBuilder Sci.Fixed (Just 9) - . unGDuration - -instance FromHttpApiData GDuration where - parseQueryParam = second GDuration . parseText durationParser - -instance ToJSON Time' where toJSON = String . toQueryParam -instance ToJSON Date' where toJSON = String . toQueryParam -instance ToJSON DateTime' where toJSON = toJSON . unDateTime -instance ToJSON GDuration where toJSON = String . toQueryParam - -instance FromJSON Time' where - parseJSON = fmap Time' . withText "time" (run timeParser) - -instance FromJSON Date' where - parseJSON = fmap Date' . withText "date" (run dayParser) - -instance FromJSON DateTime' where - parseJSON = fmap DateTime' . parseJSON - -instance FromJSON GDuration where - parseJSON = fmap GDuration . withText "duration" (run durationParser) - -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 -timeParser = do - h <- twoDigits <* char ':' - m <- twoDigits <* char ':' - s <- twoDigits <&> fromIntegral - if h < 24 && m < 60 && s < 61 - then pure (TimeOfDay h m s) - else fail "invalid time" - --- | Parse a date of the form @YYYY-MM-DD@. -dayParser :: Parser Day -dayParser = do - y <- decimal <* char '-' - m <- twoDigits <* char '-' - d <- twoDigits - maybe (fail "invalid date") pure (fromGregorianValid y m d) - -durationParser :: Parser Scientific -durationParser = Sci.fromFloatDigits <$> (double <* char 's') - --- | Parse a two-digit integer (e.g. day of month, hour). -twoDigits :: Parser Int -twoDigits = do - a <- digit - b <- digit - let c2d c = ord c .&. 15 - pure $! c2d a * 10 + c2d b - --- | Run an attoparsec parser as an aeson parser. -run :: Parser a -> Text -> Aeson.Parser a -run p t = - case parseOnly (p <* endOfInput) t of - Left err -> fail $ "could not parse date: " ++ err - Right r -> pure r diff --git a/src/Network/Google/Prelude.hs b/src/Network/Google/Prelude.hs deleted file mode 100644 --- a/src/Network/Google/Prelude.hs +++ /dev/null @@ -1,38 +0,0 @@ --- | --- Module : Network.Google.Prelude --- 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.Prelude - ( module Export - ) where - -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 (Hashable, hashWithSalt) -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.Scientific as Export (Scientific) -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, span, any, Word) -import Servant.API as Export hiding (Headers, Link, getResponse, Stream, ResponseHeader, Header, header) -import Servant.Utils.Links as Export hiding (Link) -import Web.HttpApiData as Export (FromHttpApiData (..), ToHttpApiData (..)) - -import Network.Google.Data.Bytes 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 deleted file mode 100644 --- a/src/Network/Google/Types.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Network.Google.Types --- 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.Types where - -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 Data.Coerce -import Data.Conduit -import Data.Data -import Data.DList (DList) -import Data.Foldable (foldMap, foldl') -import Data.String -import Data.Semigroup -import Data.Text (Text) -import Data.Text.Lazy.Builder (Builder) - -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 Servant.API hiding (Stream) - -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS -import qualified Data.CaseInsensitive as CI -import qualified Data.Conduit.Combinators as Conduit -import qualified Data.DList as DList -import qualified Data.Text.Encoding as Text -import qualified Data.Text.Lazy.Builder as Build -import qualified Network.HTTP.Types as HTTP - -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 ToHttpApiData AltJSON where toQueryParam = const "json" -instance ToHttpApiData AltMedia where toQueryParam = const "media" -instance ToHttpApiData Multipart where toQueryParam = const "multipart" - --- | An OAuth2 scope. -newtype OAuthScope = OAuthScope Text - deriving - ( Eq - , Ord - , Show - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - --- | An OAuth2 access token. -newtype AccessToken = AccessToken Text - deriving - ( Eq - , Ord - , Show - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - --- | An OAuth2 refresh token. -newtype RefreshToken = RefreshToken Text - deriving - ( Eq - , Ord - , Show - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - --- | A client identifier. -newtype ClientId = ClientId Text - deriving - ( Eq - , Ord - , Show - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - --- | A service identifier. -newtype ServiceId = ServiceId Text - deriving - ( Eq - , Ord - , Show - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - --- | An opaque client secret. -newtype GSecret = GSecret Text - deriving - ( Eq - , Ord - , Read - , IsString - , Generic - , Typeable - , FromHttpApiData - , ToHttpApiData - , FromJSON - , ToJSON - ) - -instance Show GSecret where - show = const "*****" - -newtype MediaDownload a = MediaDownload a - -data MediaUpload a = MediaUpload a GBody - -_Coerce :: (Coercible a b, Coercible b a) => Iso' a b -_Coerce = iso coerce coerce - --- | Invalid Iso, exists for ease of composition with the current 'Lens . Iso' --- chaining to hide internal types from the user. -_Default :: Monoid a => Iso' (Maybe a) a -_Default = iso f Just - where - f (Just x) = x - f Nothing = mempty - -type Stream = ConduitM () ByteString (ResourceT IO) () - -data Error - = TransportError HttpException - | SerializeError SerializeError - | ServiceError ServiceError - deriving (Show, Typeable) - -instance Exception Error - -data SerializeError = SerializeError' - { _serializeId :: !ServiceId - , _serializeHeaders :: [HTTP.Header] - , _serializeStatus :: !Status - , _serializeMessage :: !String - , _serializeBody :: !(Maybe LBS.ByteString) - } deriving (Eq, Show, Typeable) - -data ServiceError = ServiceError' - { _serviceId :: !ServiceId - , _serviceStatus :: !Status - , _serviceHeaders :: ![HTTP.Header] - , _serviceBody :: !(Maybe LBS.ByteString) - } deriving (Eq, Show, Typeable) - -class AsError a where - -- | A general Amazonka error. - _Error :: Prism' a Error - {-# MINIMAL _Error #-} - - -- | An error occured while communicating over HTTP with a remote service. - _TransportError :: Prism' a HttpException - - -- | A serialisation error occured when attempting to deserialise a response. - _SerializeError :: Prism' a SerializeError - - -- | A service specific error returned by the remote service. - _ServiceError :: Prism' a ServiceError - - _TransportError = _Error . _TransportError - _SerializeError = _Error . _SerializeError - _ServiceError = _Error . _ServiceError - -instance AsError SomeException where - _Error = exception - -instance AsError Error where - _Error = id - - _TransportError = prism TransportError $ \case - TransportError e -> Right e - x -> Left x - - _SerializeError = prism SerializeError $ \case - SerializeError e -> Right e - x -> Left x - - _ServiceError = prism ServiceError $ \case - ServiceError e -> Right e - x -> Left x - -data ServiceConfig = ServiceConfig - { _svcId :: !ServiceId - , _svcHost :: !ByteString - , _svcPath :: !Builder - , _svcPort :: !Int - , _svcSecure :: !Bool - , _svcTimeout :: !(Maybe Seconds) - } - -defaultService :: ServiceId -> ByteString -> ServiceConfig -defaultService i h = ServiceConfig - { _svcId = i - , _svcHost = h - , _svcPath = mempty - , _svcPort = 443 - , _svcSecure = True - , _svcTimeout = Just 70 - } - --- | 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 }) - --- | The remote port to connect to. --- --- Defaults to @443@. -servicePort :: Lens' ServiceConfig Int -servicePort = lens _svcPort (\s a -> s { _svcPort = a }) - --- | 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 }) - --- | 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 (potentially multipart) request body. --- --- /Note:/ The 'IsString' instance defaults to a @text/plain@ MIME type. -data GBody = GBody !MediaType !RequestBody - -instance IsString GBody where - fromString = GBody ("text" // "plain") . fromString - --- | A lens into the 'MediaType' of a request 'Body'. -bodyContentType :: Lens' GBody MediaType -bodyContentType = lens (\(GBody m _) -> m) (\(GBody _ b) m -> GBody m b) - --- | An intermediary request builder. -data Request = Request - { _rqPath :: !Builder - , _rqQuery :: !(DList (ByteString, Maybe ByteString)) - , _rqHeaders :: !(DList (HeaderName, ByteString)) - , _rqBody :: ![GBody] - } - -instance Monoid Request where - mempty = Request mempty mempty mempty mempty - mappend = (<>) - -instance Semigroup Request where - a <> b = Request - (_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 :: ToHttpApiData a => Request -> [a] -> Request -appendPaths rq = appendPath rq . foldMap (mappend "/" . buildText) - -appendQuery :: Request -> ByteString -> Maybe Text -> Request -appendQuery rq k v = rq - { _rqQuery = DList.snoc (_rqQuery rq) (k, Text.encodeUtf8 <$> v) - } - -appendHeader :: Request -> HeaderName -> Maybe Text -> Request -appendHeader rq _ Nothing = rq -appendHeader rq k (Just v) = rq - { _rqHeaders = DList.snoc (_rqHeaders rq) (k, Text.encodeUtf8 v) - } - -setBody :: Request -> [GBody] -> Request -setBody rq bs = rq { _rqBody = bs } - --- | A materialised 'http-client' request and associated response parser. -data GClient a = GClient - { _cliAccept :: !(Maybe MediaType) - , _cliMethod :: !Method - , _cliCheck :: !(Status -> Bool) - , _cliService :: !ServiceConfig - , _cliRequest :: !Request - , _cliResponse :: !(Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) - } - -clientService :: Lens' (GClient a) ServiceConfig -clientService = lens _cliService (\s a -> s { _cliService = a }) - -mime :: FromStream c a - => Proxy c - -> Method - -> [Int] - -> Request - -> ServiceConfig - -> GClient a -mime p = gClient (fromStream p) (Just (contentType p)) - -discard :: Method - -> [Int] - -> Request - -> ServiceConfig - -> GClient () -discard = gClient (\b -> runConduit (b .| Conduit.sinkNull) >> pure (Right ())) Nothing - -gClient :: (Stream -> ResourceT IO (Either (String, LBS.ByteString) a)) - -> Maybe MediaType - -> Method - -> [Int] - -> Request - -> ServiceConfig - -> GClient a -gClient f cs m statuses rq s = GClient - { _cliAccept = cs - , _cliMethod = m - , _cliCheck = \status -> fromEnum status `elem` statuses - , _cliService = s - , _cliRequest = rq - , _cliResponse = f - } - -class Accept c => ToBody c a where - toBody :: Proxy c -> a -> GBody - -instance ToBody OctetStream ByteString where - toBody p = GBody (contentType p) . RequestBodyBS - -instance ToBody OctetStream LBS.ByteString where - toBody p = GBody (contentType p) . RequestBodyLBS - -instance ToBody PlainText ByteString where - toBody p = GBody (contentType p) . RequestBodyBS - -instance ToBody PlainText LBS.ByteString where - toBody p = GBody (contentType p) . RequestBodyLBS - -instance ToJSON a => ToBody JSON a where - toBody p = GBody (contentType p) . RequestBodyLBS . encode - -class Accept c => FromStream c a where - fromStream :: Proxy c - -> Stream - -> ResourceT IO (Either (String, LBS.ByteString) a) - -instance FromStream OctetStream Stream where - fromStream Proxy = pure . Right - -instance FromJSON a => FromStream JSON a where - fromStream Proxy s = do - bs <- sinkLBS s - case eitherDecode bs of - Left e -> pure $! Left (e, bs) - Right x -> pure $! Right x - -class GoogleRequest a where - type Rs a :: * - type Scopes a :: [Symbol] - - requestClient :: a -> GClient (Rs a) - -class GoogleClient fn where - type Fn fn :: * - - buildClient :: Proxy fn -> Request -> Fn fn - --- | Multiple path captures, with @[xs]@ forming @////...@. -data Captures (s :: Symbol) a - deriving (Typeable) - --- | Form a Google style sub-resource, such as @/:@. -data CaptureMode (s :: Symbol) (m :: Symbol) a - deriving (Typeable) - -data MultipartRelated (cs :: [*]) m - deriving (Typeable) - -instance ( ToBody c m - , GoogleClient fn - ) => GoogleClient (MultipartRelated (c ': cs) m :> fn) where - type Fn (MultipartRelated (c ': cs) m :> fn) = m -> GBody -> Fn fn - - 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) = GBody -> 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 - - buildClient Proxy rq = buildClient (Proxy :: Proxy fn) $ - appendPath rq (buildSymbol (Proxy :: Proxy s)) - -instance (GoogleClient a, GoogleClient b) => GoogleClient (a :<|> b) where - type Fn (a :<|> b) = Fn a :<|> Fn b - - buildClient Proxy rq = - buildClient (Proxy :: Proxy a) rq - :<|> buildClient (Proxy :: Proxy b) rq - -instance ( KnownSymbol s - , ToHttpApiData a - , GoogleClient fn - ) => GoogleClient (Capture s a :> fn) where - type Fn (Capture s a :> fn) = a -> Fn fn - - buildClient Proxy rq = buildClient (Proxy :: Proxy fn) - . appendPath rq - . buildText - -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 - , ToHttpApiData a - , GoogleClient fn - ) => GoogleClient (CaptureMode s m a :> fn) where - type Fn (CaptureMode s m a :> fn) = a -> Fn fn - - buildClient Proxy rq x = buildClient (Proxy :: Proxy fn) - . appendPath rq - $ buildText x <> ":" <> buildSymbol (Proxy :: Proxy m) - -instance ( KnownSymbol s - , ToHttpApiData a - , GoogleClient fn - ) => GoogleClient (QueryParam s a :> fn) where - type Fn (QueryParam s a :> fn) = Maybe a -> Fn fn - - buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $ - case mx of - Nothing -> rq - Just x -> appendQuery rq k v - where - k = byteSymbol (Proxy :: Proxy s) - v = Just (toQueryParam x) - -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 . toQueryParam - - k = byteSymbol (Proxy :: Proxy s) - -instance ( KnownSymbol s - , ToHttpApiData a - , GoogleClient fn - ) => GoogleClient (Header s a :> fn) where - type Fn (Header s a :> fn) = Maybe a -> Fn fn - - buildClient Proxy rq mx = buildClient (Proxy :: Proxy fn) $ - case mx of - Nothing -> rq - Just x -> appendHeader rq (CI.mk k) v - where - k = byteSymbol (Proxy :: Proxy s) - 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 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) = ServiceConfig -> GClient a - - buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203] - -instance {-# OVERLAPPING #-} - GoogleClient (Get (c ': cs) ()) where - type Fn (Get (c ': cs) ()) = ServiceConfig -> GClient () - - buildClient Proxy = discard methodGet [204] - -instance {-# OVERLAPPABLE #-} - (FromStream c a, cs' ~ (c ': cs)) => GoogleClient (Post cs' a) where - type Fn (Post cs' a) = ServiceConfig -> GClient a - - buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201] - -instance {-# OVERLAPPING #-} - GoogleClient (Post cs ()) where - type Fn (Post cs ()) = ServiceConfig -> GClient () - - buildClient Proxy = discard methodPost [204] - -instance {-# OVERLAPPABLE #-} - FromStream c a => GoogleClient (Put (c ': cs) a) where - type Fn (Put (c ': cs) a) = ServiceConfig -> GClient a - - buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201] - -instance {-# OVERLAPPING #-} - GoogleClient (Put (c ': cs) ()) where - type Fn (Put (c ': cs) ()) = ServiceConfig -> GClient () - - buildClient Proxy = discard methodPut [204] - -instance {-# OVERLAPPABLE #-} - FromStream c a => GoogleClient (Patch (c ': cs) a) where - type Fn (Patch (c ': cs) a) = ServiceConfig -> GClient a - - buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201] - -instance {-# OVERLAPPING #-} - GoogleClient (Patch (c ': cs) ()) where - type Fn (Patch (c ': cs) ()) = ServiceConfig -> GClient () - - buildClient Proxy = discard methodPatch [204] - -instance {-# OVERLAPPABLE #-} - FromStream c a => GoogleClient (Delete (c ': cs) a) where - type Fn (Delete (c ': cs) a) = ServiceConfig -> GClient a - - buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202] - -instance {-# OVERLAPPING #-} - GoogleClient (Delete (c ': cs) ()) where - type Fn (Delete (c ': cs) ()) = ServiceConfig -> GClient () - - buildClient Proxy = discard methodDelete [204] - -sinkLBS :: Stream -> ResourceT IO LBS.ByteString -sinkLBS = runConduit . (.| Conduit.sinkLazy) - -buildText :: ToHttpApiData a => a -> Builder -buildText = Build.fromText . toQueryParam - -buildSymbol :: forall n proxy. KnownSymbol n => proxy n -> Builder -buildSymbol = Build.fromString . symbolVal - -byteSymbol :: forall n proxy. KnownSymbol n => proxy n -> ByteString -byteSymbol = BS8.pack . symbolVal - --- | An integral value representing seconds. -newtype Seconds = Seconds Int - deriving - ( Eq - , Ord - , Read - , Show - , Enum - , Num - , Bounded - , Integral - , Real - , Data - , Typeable - , Generic - ) - -seconds :: Seconds -> Int -seconds (Seconds n) - | n < 0 = 0 - | otherwise = n - -microseconds :: Seconds -> Int -microseconds = (1000000 *) . seconds - -newtype GFieldMask = GFieldMask 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-2016 Brendan Hay +-- Copyright : (c) 2015-2022 Brendan Hay -- License : Mozilla Public License, v. 2.0. -- Maintainer : Brendan Hay -- Stability : experimental @@ -7,10 +7,11 @@ module Main (main) where -import Test.Tasty +import Test.Tasty main :: IO () -main = defaultMain $ - testGroup "gogol" - [ - ] +main = + defaultMain $ + testGroup + "gogol" + []