module Network.AWS.Types
(
AccessKey (..)
, SecretKey (..)
, SecurityToken (..)
, AuthEnv (..)
, Auth (..)
, withAuth
, Logger (..)
, debug
, Abbrev
, AWSService (..)
, Service (..)
, Endpoint (..)
, Host (..)
, endpoint
, global
, regional
, custom
, ServiceError (..)
, _HttpError
, _SerializerError
, _ServiceError
, _Errors
, AWSError
, awsError
, AWSSigner (..)
, AWSPresigner (..)
, Signed (..)
, Meta
, sgMeta
, sgRequest
, AWSRequest (..)
, AWSPager (..)
, Request (..)
, rqMethod
, rqHeaders
, rqPath
, rqQuery
, rqBody
, Response
, Empty (..)
, Region (..)
, Zone (..)
, zRegion
, zSuffix
, Action (..)
, ClientRequest
, ClientResponse
, ResponseBody
, clientRequest
) where
import Control.Applicative
import Control.Concurrent (ThreadId)
import Control.Exception (Exception)
import Control.Lens hiding (Action)
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.Aeson hiding (Error)
import qualified Data.Attoparsec.Text as AText
import Data.ByteString (ByteString)
import Data.Char
import Data.Conduit
import Data.Default.Class
import Data.IORef
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Time
import Data.Typeable
import GHC.Generics
import Network.AWS.Data hiding ((.:), (.:?))
import qualified Network.HTTP.Client as Client
import Network.HTTP.Client hiding (Request, Response)
import Network.HTTP.Types.Header
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status (Status)
import System.Locale
type Abbrev = Text
data ServiceError a
= HttpError HttpException
| SerializerError Abbrev String
| ServiceError Abbrev Status a
| Errors [ServiceError a]
deriving (Show, Typeable)
instance (Show a, Typeable a) => Exception (ServiceError a)
instance Monoid (ServiceError a) where
mempty = Errors []
mappend a b = Errors (f a <> f b)
where
f (Errors xs) = xs
f x = [x]
class AWSError a where
awsError :: a -> ServiceError String
instance Show a => AWSError (ServiceError a) where
awsError = \case
HttpError e -> HttpError e
SerializerError a e -> SerializerError a e
ServiceError a s x -> ServiceError a s (show x)
Errors xs -> Errors (map awsError xs)
class (AWSSigner (Sg a), Show (Er a)) => AWSService a where
type Sg a :: *
type Er a :: *
service :: Service a
handle :: Service a
-> Status
-> Maybe (LazyByteString -> ServiceError (Er a))
type Response a = Either (ServiceError (Er (Sv a))) (Rs a)
class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where
type Sv a :: *
type Rs a :: *
request :: a -> Request a
response :: MonadResource m
=> a
-> Either HttpException ClientResponse
-> m (Response a)
class AWSRequest a => AWSPager a where
page :: a -> Rs a -> Maybe a
data family Meta v :: *
data Signed a v where
Signed :: Show (Meta v)
=> { _sgMeta :: Meta v
, _sgRequest :: ClientRequest
}
-> Signed a v
sgMeta :: Lens' (Signed a v) (Meta v)
sgMeta f (Signed m rq) = f m <&> \y -> Signed y rq
sgRequest :: Lens' (Signed a v) ClientRequest
sgRequest f (Signed m rq) = f rq <&> \y -> Signed m y
instance ToText (Signed a v) where
toText (Signed m rq) = Text.unlines
[ Text.pack (show m)
, "HTTP Request:"
, Text.pack (show rq)
]
class AWSSigner v where
signed :: (AWSService (Sv a), v ~ Sg (Sv a))
=> AuthEnv
-> Region
-> Request a
-> TimeLocale
-> UTCTime
-> Signed a v
class AWSPresigner v where
presigned :: (AWSService (Sv a), v ~ Sg (Sv a))
=> AuthEnv
-> Region
-> Request a
-> TimeLocale
-> UTCTime
-> Int
-> Signed a v
newtype AccessKey = AccessKey ByteString
deriving (Eq, Show, IsString)
instance ToByteString AccessKey where
toBS (AccessKey k) = k
instance ToText AccessKey where
toText = Text.decodeUtf8 . toBS
newtype SecretKey = SecretKey ByteString
deriving (Eq, Show, IsString)
instance ToByteString SecretKey where
toBS (SecretKey k) = k
instance ToText SecretKey where
toText = Text.decodeUtf8 . toBS
newtype SecurityToken = SecurityToken ByteString
deriving (Eq, Show, IsString)
instance ToByteString SecurityToken where
toBS (SecurityToken t) = t
data AuthEnv = AuthEnv
{ _authAccess :: !AccessKey
, _authSecret :: !SecretKey
, _authToken :: Maybe SecurityToken
, _authExpiry :: Maybe UTCTime
}
instance FromJSON AuthEnv where
parseJSON = withObject "AuthEnv" $ \o -> AuthEnv
<$> f AccessKey (o .: "AccessKeyId")
<*> f SecretKey (o .: "SecretAccessKey")
<*> fmap (f SecurityToken) (o .:? "Token")
<*> o .:? "Expiration"
where
f g = fmap (g . Text.encodeUtf8)
data Auth
= Ref ThreadId (IORef AuthEnv)
| Auth AuthEnv
withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
withAuth (Auth e) f = f e
withAuth (Ref _ r) f = liftIO (readIORef r) >>= f
data Logger
= None
| Debug (Text -> IO ())
debug :: MonadIO m => Logger -> Text -> m ()
debug None = const (return ())
debug (Debug f) = liftIO . f
newtype Host = Host ByteString
deriving (Eq, Show)
instance ToByteString Host where
toBS (Host h) = h
data Endpoint
= Global
| Regional
| Custom ByteString
instance IsString Endpoint where
fromString = Custom . fromString
endpoint :: Service a -> Region -> Host
endpoint Service{..} reg =
let suf = ".amazonaws.com"
in Host $ case _svcEndpoint of
Global -> _svcPrefix <> suf
Regional -> _svcPrefix <> "." <> toBS reg <> suf
Custom x -> x
global, regional :: Endpoint
global = Global
regional = Regional
custom :: ByteString -> Endpoint
custom = Custom
data Service a = Service
{ _svcAbbrev :: !Text
, _svcEndpoint :: !Endpoint
, _svcPrefix :: ByteString
, _svcVersion :: ByteString
, _svcTargetPrefix :: Maybe ByteString
, _svcJSONVersion :: Maybe ByteString
}
data Request a = Request
{ _rqMethod :: !StdMethod
, _rqPath :: ByteString
, _rqQuery :: Query
, _rqHeaders :: [Header]
, _rqBody :: RqBody
}
instance Default (Request a) where
def = Request GET "/" mempty mempty ""
instance ToText (Request a) where
toText Request{..} = Text.unlines
[ "Request:"
, "_rqMethod = " <> toText _rqMethod
, "_rqPath = " <> toText _rqPath
, "_rqQuery = " <> toText _rqQuery
, "_rqHeaders = " <> toText _rqHeaders
, "_rqBody = " <> toText _rqBody
]
data Region
= Ireland
| Tokyo
| Singapore
| Sydney
| Beijing
| NorthVirginia
| NorthCalifornia
| Oregon
| GovCloud
| GovCloudFIPS
| SaoPaulo
deriving (Eq, Ord, Read, Show, Generic)
instance Default Region where
def = NorthVirginia
instance FromText Region where
parser = match "eu-west-1" Ireland
<|> match "ap-northeast-1" Tokyo
<|> match "ap-southeast-1" Singapore
<|> match "ap-southeast-2" Sydney
<|> match "cn-north-1" Beijing
<|> match "us-east-1" NorthVirginia
<|> match "us-west-2" NorthCalifornia
<|> match "us-west-1" Oregon
<|> match "us-gov-west-1" GovCloud
<|> match "fips-us-gov-west-1" GovCloudFIPS
<|> match "sa-east-1" SaoPaulo
instance ToText Region where
toText r = case r of
Ireland -> "eu-west-1"
Tokyo -> "ap-northeast-1"
Singapore -> "ap-southeast-1"
Sydney -> "ap-southeast-2"
Beijing -> "cn-north-1"
NorthVirginia -> "us-east-1"
NorthCalifornia -> "us-west-1"
Oregon -> "us-west-2"
GovCloud -> "us-gov-west-1"
GovCloudFIPS -> "fips-us-gov-west-1"
SaoPaulo -> "sa-east-1"
instance ToByteString Region
instance FromXML Region where parseXML = parseXMLText "Region"
instance ToXML Region where toXML = toXMLText
data Zone = Zone
{ _zRegion :: !Region
, _zSuffix :: !Char
} deriving (Eq, Ord, Read, Show)
instance FromText Zone where
parser = Zone <$> parser <*> AText.satisfy isAlpha <* AText.endOfInput
instance ToText Zone where
toText Zone{..} = toText _zRegion `Text.snoc` _zSuffix
newtype Action = Action Text
deriving (Eq, Ord, Show, IsString, ToText, ToByteString)
data Empty = Empty
deriving (Eq, Show)
instance ToJSON Empty where
toJSON = const Null
type ClientRequest = Client.Request
type ClientResponse = Client.Response ResponseBody
type ResponseBody = ResumableSource (ResourceT IO) ByteString
clientRequest :: ClientRequest
clientRequest = def
{ Client.secure = True
, Client.port = 443
, Client.checkStatus = \_ _ _ -> Nothing
}
makePrisms ''ServiceError
makeLenses ''Request
makeLenses ''Zone