module Network.AWS.Types
(
AccessKey (..)
, SecretKey (..)
, SecurityToken (..)
, AuthEnv (..)
, Auth (..)
, withAuth
, Abbrev
, AWSService (..)
, Service (..)
, serviceOf
, 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 (..)
, 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 Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.CaseInsensitive as CI
import Data.Conduit
import Data.Default.Class
import qualified Data.HashSet as Set
import Data.Hashable
import Data.IORef
import Data.List (intersperse)
import Data.Monoid
import Data.String
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Data.Time
import Data.Typeable
import GHC.Generics
import Network.AWS.Data
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))
serviceOf :: AWSService (Sv a) => Request a -> Service (Sv a)
serviceOf = const service
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 :: ToBuilder (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
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, ToText, ToByteString, ToBuilder)
newtype SecretKey = SecretKey ByteString
deriving (Eq, IsString, ToText, ToByteString)
newtype SecurityToken = SecurityToken ByteString
deriving (Eq, IsString, ToText, ToByteString)
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)
instance ToBuilder AuthEnv where
build AuthEnv{..} = mconcat $ intersperse "\n"
[ "[Authentication] {"
, " access key = " <> build _authAccess
, " secret key = ****"
, " security token = ****"
, " expiry = " <> build _authExpiry
, "}"
]
data Auth
= Ref ThreadId (IORef AuthEnv)
| Auth AuthEnv
instance ToBuilder Auth where
build (Ref t _) = "[Authentication] { <thread:" <> build (show t) <> "> }"
build (Auth e) = build e
withAuth :: MonadIO m => Auth -> (AuthEnv -> m a) -> m a
withAuth (Auth e) f = f e
withAuth (Ref _ r) f = liftIO (readIORef r) >>= 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 ToBuilder (Request a) where
build Request{..} = mconcat $ intersperse "\n"
[ "[Raw Request] {"
, " method = " <> build _rqMethod
, " path = " <> build _rqPath
, " query = " <> build _rqQuery
, " headers = " <> build _rqHeaders
, " body = {"
, " hash = " <> build (bodyHash _rqBody)
, " payload =\n" <> build (_bdyBody _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 ToBuilder Region
instance FromXML Region where parseXML = parseXMLText "Region"
instance ToXML Region where toXML = toXMLText
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