{-# 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 where
import Control.Applicative
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.Semigroup
import Data.String
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"
newtype OAuthScope = OAuthScope Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
newtype AccessToken = AccessToken Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
newtype RefreshToken = RefreshToken Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
newtype ClientId = ClientId Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
newtype ServiceId = ServiceId Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
newtype Secret = Secret Text
deriving
( Eq
, Ord
, Read
, IsString
, Generic
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)
instance Show Secret where
show = const "*****"
newtype MediaDownload a = MediaDownload a
data MediaUpload a = MediaUpload a Body
_Coerce :: (Coercible a b, Coercible b a) => Iso' a b
_Coerce = iso coerce coerce
_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
_Error :: Prism' a Error
{-# MINIMAL _Error #-}
_TransportError :: Prism' a HttpException
_SerializeError :: Prism' a SerializeError
_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
}
serviceHost :: Lens' ServiceConfig ByteString
serviceHost = lens _svcHost (\s a -> s { _svcHost = a })
servicePort :: Lens' ServiceConfig Int
servicePort = lens _svcPort (\s a -> s { _svcPort = a })
servicePath :: Lens' ServiceConfig Builder
servicePath = lens _svcPath (\s a -> s { _svcPath = a })
serviceSecure :: Lens' ServiceConfig Bool
serviceSecure = lens _svcSecure (\s a -> s { _svcSecure = a })
serviceTimeout :: Lens' ServiceConfig (Maybe Seconds)
serviceTimeout = lens _svcTimeout (\s a -> s { _svcTimeout = a })
data Body = Body !MediaType !RequestBody
instance IsString Body where
fromString = Body ("text" // "plain") . fromString
bodyContentType :: Lens' Body MediaType
bodyContentType = lens (\(Body m _) -> m) (\(Body _ b) m -> Body m b)
data Request = Request
{ _rqPath :: !Builder
, _rqQuery :: !(DList (ByteString, Maybe ByteString))
, _rqHeaders :: !(DList (HeaderName, ByteString))
, _rqBody :: ![Body]
}
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 -> [Body] -> Request
setBody rq bs = rq { _rqBody = bs }
data Client a = Client
{ _cliAccept :: !(Maybe MediaType)
, _cliMethod :: !Method
, _cliCheck :: !(Status -> Bool)
, _cliService :: !ServiceConfig
, _cliRequest :: !Request
, _cliResponse :: !(Stream -> ResourceT IO (Either (String, LBS.ByteString) a))
}
clientService :: Lens' (Client a) ServiceConfig
clientService = lens _cliService (\s a -> s { _cliService = 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
-> ServiceConfig
-> Client ()
discard = client (\b -> runConduit (b .| Conduit.sinkNull) >> pure (Right ())) Nothing
client :: (Stream -> ResourceT IO (Either (String, LBS.ByteString) a))
-> Maybe MediaType
-> Method
-> [Int]
-> Request
-> ServiceConfig
-> Client a
client f cs m statuses rq s = Client
{ _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 -> Body
instance ToBody OctetStream ByteString where
toBody p = Body (contentType p) . RequestBodyBS
instance ToBody OctetStream LBS.ByteString where
toBody p = Body (contentType p) . RequestBodyLBS
instance ToBody PlainText ByteString where
toBody p = Body (contentType p) . RequestBodyBS
instance ToBody PlainText LBS.ByteString where
toBody p = Body (contentType p) . RequestBodyLBS
instance ToJSON a => ToBody JSON a where
toBody p = Body (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 -> Client (Rs a)
class GoogleClient fn where
type Fn fn :: *
buildClient :: Proxy fn -> Request -> Fn fn
data Captures (s :: Symbol) a
deriving (Typeable)
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 -> Body -> 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) = 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
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 -> Client a
buildClient Proxy = mime (Proxy :: Proxy c) methodGet [200, 203]
instance {-# OVERLAPPING #-}
GoogleClient (Get (c ': cs) ()) where
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) = ServiceConfig -> Client a
buildClient Proxy = mime (Proxy :: Proxy c) methodPost [200, 201]
instance {-# OVERLAPPING #-}
GoogleClient (Post cs ()) where
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) = ServiceConfig -> Client a
buildClient Proxy = mime (Proxy :: Proxy c) methodPut [200, 201]
instance {-# OVERLAPPING #-}
GoogleClient (Put (c ': cs) ()) where
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) = ServiceConfig -> Client a
buildClient Proxy = mime (Proxy :: Proxy c) methodPatch [200, 201]
instance {-# OVERLAPPING #-}
GoogleClient (Patch (c ': cs) ()) where
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) = ServiceConfig -> Client a
buildClient Proxy = mime (Proxy :: Proxy c) methodDelete [200, 202]
instance {-# OVERLAPPING #-}
GoogleClient (Delete (c ': cs) ()) where
type Fn (Delete (c ': cs) ()) = ServiceConfig -> Client ()
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
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 FieldMask = FieldMask Text
deriving
( Eq
, Ord
, Show
, Read
, IsString
, Generic
, Data
, Typeable
, FromHttpApiData
, ToHttpApiData
, FromJSON
, ToJSON
)