module Network.AWS.Types
(
AccessKey (..)
, SecretKey (..)
, SecurityToken (..)
, AuthEnv (..)
, Auth (..)
, withAuth
, Logger (..)
, debug
, Abbrev
, AWSService (..)
, Service (..)
, Endpoint (..)
, endpoint
, 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 qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.Conduit
import Data.Default.Class
import qualified Data.HashSet as Set
import Data.Hashable
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
-> UTCTime
-> 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
data Endpoint = Endpoint
{ _endpointHost :: ByteString
, _endpointScope :: ByteString
} deriving (Eq, Show)
endpoint :: Service a -> Region -> Endpoint
endpoint Service{..} r = go (CI.mk _svcPrefix)
where
go = \case
"iam"
| china -> region "iam.cn-north-1.amazonaws.com.cn"
| govcloud -> region "iam.us-gov.amazonaws.com"
| otherwise -> global "iam.amazonaws.com"
"sdb"
| virginia -> region "sdb.amazonaws.com"
"sts"
| china -> region "sts.cn-north-1.amazonaws.com.cn"
| govcloud -> region ("sts." <> reg <> ".amazonaws.com")
| otherwise -> global "sts.amazonaws.com"
"s3"
| virginia -> global "s3.amazonaws.com"
| china -> region ("s3." <> reg <> ".amazonaws.com.cn")
| s3 -> region ("s3-" <> reg <> ".amazonaws.com")
"rds"
| virginia -> global "rds.amazonaws.com"
"route53"
| not china -> region "route53.amazonaws.com"
"emr"
| virginia -> global "elasticmapreduce.us-east-1.amazonaws.com"
| otherwise -> region (reg <> ".elasticmapreduce.amazonaws.com")
"sqs"
| virginia -> global "queue.amazonaws.com"
| china -> region (reg <> ".queue.amazonaws.com.cn")
"importexport"
| not china -> region "importexport.amazonaws.com"
"cloudfront"
| not china -> global "cloudfront.amazonaws.com"
_ | china -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com.cn")
| otherwise -> region (_svcPrefix <> "." <> reg <> ".amazonaws.com")
virginia = r == NorthVirginia
s3 = r `Set.member` except
govcloud = "us-gov" `BS.isPrefixOf` reg
china = "cn-" `BS.isPrefixOf` reg
region h = Endpoint { _endpointHost = h, _endpointScope = reg }
global h = Endpoint { _endpointHost = h, _endpointScope = "us-east-1" }
reg = toBS r
except = Set.fromList
[ GovCloud
, GovCloudFIPS
, Ireland
, NorthCalifornia
, NorthVirginia
, Oregon
, SaoPaulo
, Singapore
, Sydney
, Tokyo
]
data Service a = Service
{ _svcAbbrev :: !Text
, _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
| Frankfurt
| Tokyo
| Singapore
| Sydney
| Beijing
| NorthVirginia
| NorthCalifornia
| Oregon
| GovCloud
| GovCloudFIPS
| SaoPaulo
deriving (Eq, Ord, Read, Show, Generic)
instance Hashable Region
instance Default Region where
def = NorthVirginia
instance FromText Region where
parser = takeText >>= \case
"eu-west-1" -> pure Ireland
"eu-central-1" -> pure Frankfurt
"ap-northeast-1" -> pure Tokyo
"ap-southeast-1" -> pure Singapore
"ap-southeast-2" -> pure Sydney
"cn-north-1" -> pure Beijing
"us-east-1" -> pure NorthVirginia
"us-west-2" -> pure NorthCalifornia
"us-west-1" -> pure Oregon
"us-gov-west-1" -> pure GovCloud
"fips-us-gov-west-1" -> pure GovCloudFIPS
"sa-east-1" -> pure SaoPaulo
e -> fail $
"Failure parsing Region from " ++ show e
instance ToText Region where
toText r = case r of
Ireland -> "eu-west-1"
Frankfurt -> "eu-central-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