diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# Amazonka Core + +* [Description](#description) +* [Contribute](#contribute) +* [Licence](#licence) + +## Description + +Core data types, signing, (de)serialisation routines, and HTTP plumbing for all +`amazonka-*` libraries. + + +## Contribute + +For any problems, comments, or feedback please create an issue [here on GitHub](https://github.com/brendanhay/amazonka/issues). + + +## Licence + +`amazonka-core` is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/amazonka-core.cabal b/amazonka-core.cabal new file mode 100644 --- /dev/null +++ b/amazonka-core.cabal @@ -0,0 +1,98 @@ +name: amazonka-core +version: 0.0.0 +synopsis: Core functionality, serialisation primitives, and data types for the amazonka Amazon Web Services SDKs. +homepage: https://github.com/brendanhay/amazonka +license: OtherLicense +license-file: LICENSE +author: Brendan Hay +maintainer: Brendan Hay +copyright: Copyright (c) 2013-2014 Brendan Hay +category: Network, AWS, Cloud +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +description: + Core functionality, serialisation primitives, and data types for + amazonka related Amazon Web Services SDKs. + . + /Warning:/ This is an experimental preview release which is still under + heavy development and not intended for public consumption, caveat emptor! + +source-repository head + type: git + location: git://github.com/brendanhay/amazonka.git + +library + default-language: Haskell2010 + hs-source-dirs: src + + ghc-options: -Wall + + exposed-modules: + Network.AWS.Auth + , Network.AWS.Data + , Network.AWS.EC2.Metadata + , Network.AWS.Error + , Network.AWS.Pagination + , Network.AWS.Prelude + , Network.AWS.Request.JSON + , Network.AWS.Request.Query + , Network.AWS.Request.RestJSON + , Network.AWS.Request.RestXML + , Network.AWS.Response + , Network.AWS.Signing.Internal + , Network.AWS.Signing.V2 + , Network.AWS.Signing.V3 + , Network.AWS.Signing.V4 + , Network.AWS.Types + + other-modules: + Network.AWS.Data.Internal.Base64 + , Network.AWS.Data.Internal.Body + , Network.AWS.Data.Internal.ByteString + , Network.AWS.Data.Internal.Header + , Network.AWS.Data.Internal.JSON + , Network.AWS.Data.Internal.List + , Network.AWS.Data.Internal.Map + , Network.AWS.Data.Internal.Numeric + , Network.AWS.Data.Internal.Path + , Network.AWS.Data.Internal.Query + , Network.AWS.Data.Internal.Sensitive + , Network.AWS.Data.Internal.Text + , Network.AWS.Data.Internal.Time + , Network.AWS.Data.Internal.URI + , Network.AWS.Data.Internal.XML + , Network.AWS.Request.Internal + + build-depends: + aeson >= 0.8 && < 0.9 + , attoparsec >= 0.12 && < 0.15 + , base >= 4.7 && < 5 + , base16-bytestring >= 0.1 && < 1 + , base64-bytestring >= 1 && < 2 + , bifunctors >= 0.3 + , bytestring >= 0.9 + , case-insensitive >= 1.1 + , conduit >= 1.1 && < 1.3 + , conduit-extra == 1.1.* + , cryptohash == 0.11.* + , cryptohash-conduit >= 0.1.1 + , data-default-class >= 0.0.1 + , hashable >= 1.2 + , http-client >= 0.3.6 && < 0.4 + , http-types >= 0.8 + , lens >= 4.4 && < 5 + , mmorph >= 1 && < 2 + , mtl >= 2.2.1 && < 2.3 + , nats >= 0.1.3 + , old-locale >= 1 + , resourcet == 1.1.* + , semigroups >= 0.12 + , tagged >= 0.7 + , text >= 1.1 + , time >= 1.4 + , transformers == 0.4.* + , unordered-containers >= 0.2.3 + , vector >= 0.10.9 + , xml-conduit == 1.2.* diff --git a/src/Network/AWS/Auth.hs b/src/Network/AWS/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Auth.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.AWS.Auth +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Explicitly specify, or automatically retrieve your Amazon AWS security +-- credentials from the underlying host. +module Network.AWS.Auth + ( + -- * Defaults + accessKey + , secretKey + + -- * Specifying credentials + , fromKeys + , fromSession + + -- * Retrieving credentials + , Credentials (..) + , getAuth + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Monad.Except +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.IORef +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time +import Network.AWS.Data +import Network.AWS.EC2.Metadata +import Network.AWS.Types +import Network.HTTP.Client +import System.Environment +import System.Mem.Weak + +-- | Default access key environment variable. +accessKey :: Text -- ^ 'AWS_ACCESS_KEY' +accessKey = "AWS_ACCESS_KEY" + +-- | Default secret key environment variable. +secretKey :: Text -- ^ 'AWS_SECRET_KEY' +secretKey = "AWS_SECRET_KEY" + +-- | Explicit access and secret keys. +fromKeys :: AccessKey -> SecretKey -> Auth +fromKeys a s = Auth (AuthEnv a s Nothing Nothing) + +-- | A session containing the access key, secret key, and a security token. +fromSession :: AccessKey -> SecretKey -> SecurityToken -> Auth +fromSession a s t = Auth (AuthEnv a s (Just t) Nothing) + +-- | Determines how authentication information is retrieved. +data Credentials + = FromKeys AccessKey SecretKey + -- ^ Explicit access and secret keys. + -- Note: you can achieve the same result purely by using 'fromKeys'. + | FromSession AccessKey SecretKey SecurityToken + -- ^ A session containing the access key, secret key, and a security token. + -- Note: you can achieve the same result purely by using 'fromSession'. + | FromProfile Text + -- ^ An IAM Profile name to lookup from the local EC2 instance-data. + | FromEnv Text Text + -- ^ Environment variables to lookup for the access and secret keys. + | Discover + -- ^ Attempt to read the default access and secret keys from the environment, + -- falling back to the first available IAM profile if they are not set. + -- + -- Note: This attempts to resolve rather than directly + -- retrieving for IAM profile information to ensure + -- the dns lookup terminates promptly if not running on EC2. + deriving (Eq) + +instance ToText Credentials where + toText = \case + FromKeys a _ -> "FromKeys " <> toText a <> " ****" + FromSession a _ _ -> "FromSession " <> toText a <> " **** ****" + FromProfile n -> "FromProfile " <> n + FromEnv a s -> "FromEnv " <> a <> " " <> s + Discover -> "Discover" + +instance Show Credentials where + show = showText + +-- | Retrieve authentication information from the environment or instance-data. +getAuth :: (Functor m, MonadIO m) + => Manager + -> Credentials + -> ExceptT String m Auth +getAuth m = \case + FromKeys a s -> return (fromKeys a s) + FromSession a s t -> return (fromSession a s t) + FromProfile n -> show `withExceptT` fromProfileName m n + FromEnv a s -> fromEnvVars a s + Discover -> + fromEnv `catchError` const (show `withExceptT` fromProfile m) + +-- | Retrieve access and secret keys from the default environment variables. +-- +-- /See:/ 'accessKey' and 'secretKey' +fromEnv :: (Functor m, MonadIO m) => ExceptT String m Auth +fromEnv = fromEnvVars accessKey secretKey + +-- | Retrieve access and secret keys from specific environment variables. +fromEnvVars :: (Functor m, MonadIO m) => Text -> Text -> ExceptT String m Auth +fromEnvVars a s = fmap Auth $ AuthEnv + <$> (AccessKey <$> key a) + <*> (SecretKey <$> key s) + <*> pure Nothing + <*> pure Nothing + where + key (Text.unpack -> k) = ExceptT $ do + m <- liftIO (lookupEnv k) + return $ + maybe (Left $ "Unable to read ENV variable: " ++ k) + (Right . BS.pack) + m + +-- | Retrieve the default IAM Profile from the local EC2 instance-data. +-- +-- This determined by Amazon as the first IAM profile found in the response from: +-- @http://169.254.169.254/latest/meta-data/iam/security-credentials/@ +fromProfile :: MonadIO m => Manager -> ExceptT HttpException m Auth +fromProfile m = do + !ls <- BS.lines `liftM` metadata m (IAM $ SecurityCredentials Nothing) + case ls of + (x:_) -> fromProfileName m (Text.decodeUtf8 x) + _ -> throwError $ + HttpParserException "Unable to get default IAM Profile from EC2 metadata" + +-- | Lookup a specific IAM Profile by name from the local EC2 instance-data. +-- +-- The resulting IONewRef wrapper + timer is designed so that multiple concurrent +-- accesses of 'AuthEnv' from the 'AWS' environment are not required to calculate +-- expiry and sequentially queue to update it. +-- +-- The forked timer ensures a singular owner and pre-emptive refresh of the +-- temporary session credentials. +-- +-- A weak reference is used to ensure that the forked thread will eventually +-- terminate when 'Auth' is no longer referenced. +fromProfileName :: MonadIO m + => Manager + -> Text + -> ExceptT HttpException m Auth +fromProfileName m name = auth >>= start + where + auth :: MonadIO m => ExceptT HttpException m AuthEnv + auth = do + !lbs <- LBS.fromStrict `liftM` metadata m + (IAM . SecurityCredentials $ Just name) + either (throwError . HttpParserException) + return + (Aeson.eitherDecode lbs) + + start !a = ExceptT . liftM Right . liftIO $ + case _authExpiry a of + Nothing -> return (Auth a) + Just x -> do + r <- newIORef a + p <- myThreadId + s <- timer r p x + return (Ref s r) + + timer r p x = forkIO $ do + s <- myThreadId + w <- mkWeakIORef r (killThread s) + loop w p x + + loop w p x = do + diff x <$> getCurrentTime >>= threadDelay + ea <- runExceptT auth + case ea of + Left e -> throwTo p e + Right !a -> do + mr <- deRefWeak w + case mr of + Nothing -> return () + Just r -> do + atomicWriteIORef r a + maybe (return ()) (loop w p) (_authExpiry a) + + diff x y = (* 1000000) $ + let n = truncate (diffUTCTime x y) - 60 + in if n > 0 then n else 1 diff --git a/src/Network/AWS/Data.hs b/src/Network/AWS/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data.hs @@ -0,0 +1,72 @@ +-- Module : Network.AWS.Data +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Serialisation classes and primitives for the various +-- formats used to communicate with AWS. +module Network.AWS.Data + ( + -- * ByteString + module Network.AWS.Data.Internal.ByteString + , module Network.AWS.Data.Internal.Base64 + + -- * Text + , module Network.AWS.Data.Internal.Text + + -- * Numeric + , module Network.AWS.Data.Internal.Numeric + + -- * Time + , module Network.AWS.Data.Internal.Time + + -- * Sensitive + , module Network.AWS.Data.Internal.Sensitive + + -- * HTTP + -- ** Body + , module Network.AWS.Data.Internal.Body + + -- ** Headers + , module Network.AWS.Data.Internal.Header + + -- ** Path + , module Network.AWS.Data.Internal.Path + + -- ** Query + , module Network.AWS.Data.Internal.Query + + -- ** URI + , module Network.AWS.Data.Internal.URI + + -- * XML + , module Network.AWS.Data.Internal.XML + + -- * JSON + , module Network.AWS.Data.Internal.JSON + + -- * Collections + , module Network.AWS.Data.Internal.List + , module Network.AWS.Data.Internal.Map + ) where + +import Network.AWS.Data.Internal.Base64 +import Network.AWS.Data.Internal.Body +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Header +import Network.AWS.Data.Internal.JSON +import Network.AWS.Data.Internal.List +import Network.AWS.Data.Internal.Map +import Network.AWS.Data.Internal.Numeric +import Network.AWS.Data.Internal.Path +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Sensitive +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.Time +import Network.AWS.Data.Internal.URI +import Network.AWS.Data.Internal.XML diff --git a/src/Network/AWS/Data/Internal/Base64.hs b/src/Network/AWS/Data/Internal/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Base64.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.AWS.Data.Internal.Base64 +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Base64 + ( Base64 + ) where + +import Data.Aeson.Types +import qualified Data.Attoparsec.Text as AText +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.Text.Encoding as Text +import GHC.Generics +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.JSON +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.XML + +-- | Base64 encoded binary data. +newtype Base64 = Base64 { unBase64 :: ByteString } + deriving (Eq, Ord, Generic) + +instance FromText Base64 where + parser = AText.takeText >>= + either fail (return . Base64) . Base64.decode . Text.encodeUtf8 + +instance Show Base64 where show = show . toBS +instance ToText Base64 where toText = Text.decodeUtf8 . toBS +instance ToByteString Base64 where toBS = Base64.encode . unBase64 +instance ToQuery Base64 where toQuery = toQuery . toText +instance FromXML Base64 where parseXML = parseXMLText "Base64" +instance ToXML Base64 where toXML = toXMLText +instance FromJSON Base64 where parseJSON = parseJSONText "Base64" +instance ToJSON Base64 where toJSON = toJSONText diff --git a/src/Network/AWS/Data/Internal/Body.hs b/src/Network/AWS/Data/Internal/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Body.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.AWS.Data.Internal.Body +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Body where + +import Control.Lens +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Morph +import Control.Monad.Trans.Resource +import Crypto.Hash +import qualified Crypto.Hash.Conduit as Conduit +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS8 +import Data.Conduit +import qualified Data.Conduit.Binary as Conduit +import Data.IORef +import Data.Int +import Data.Monoid +import Data.String +import qualified Data.Text as Text +import Network.AWS.Data.Internal.Text +import Network.HTTP.Client +import System.IO + +data RsBody = RsBody (ResumableSource (ResourceT IO) ByteString) + +makePrisms ''RsBody + +connectBody :: MonadResource m => RsBody -> Sink ByteString m a -> m a +connectBody (RsBody src) sink = hoist liftResourceT src $$+- sink + +instance ToText RsBody where + toText = const "RsBody " + +instance Show RsBody where + show = Text.unpack . toText + +data RqBody = RqBody + { _bdyHash :: Digest SHA256 + , _bdyBody :: RequestBody + } + +makeLenses ''RqBody + +instance ToText RqBody where + toText (RqBody h _) = "RqBody " <> toText h <> " " + +instance Show RqBody where + show = Text.unpack . toText + +instance IsString RqBody where + fromString = toBody . LBS8.pack + +class ToBody a where + toBody :: a -> RqBody + toBody = const (RqBody (hash "") (RequestBodyLBS mempty)) + +instance ToBody RqBody where + toBody = id + +instance ToBody LBS.ByteString where + toBody lbs = RqBody (hashlazy lbs) (RequestBodyLBS lbs) + +instance ToBody ByteString where + toBody = toBody . LBS.fromStrict + +instance ToBody Value where + toBody = toBody . encode + +sourceBody :: Digest SHA256 -> Int64 -> Source IO ByteString -> RqBody +sourceBody h n = RqBody h . RequestBodyStream n . sourcePopper + +sourceHandle :: Digest SHA256 -> Int64 -> Handle -> RqBody +sourceHandle h n = sourceBody h n . Conduit.sourceHandle + +sourceFile :: Digest SHA256 -> Int64 -> FilePath -> RqBody +sourceFile h n = sourceBody h n . hoist runResourceT . Conduit.sourceFile + +sourceFileIO :: MonadIO m => FilePath -> m RqBody +sourceFileIO f = liftIO $ sourceFile + <$> runResourceT (Conduit.sourceFile f $$ Conduit.sinkHash) + <*> (fromIntegral <$> withBinaryFile f ReadMode hFileSize) + <*> pure f + +sourcePopper :: Source IO ByteString -> GivesPopper () +sourcePopper src f = do + (rsrc0, ()) <- src $$+ return () + irsrc <- newIORef rsrc0 + let popper :: IO ByteString + popper = do + rsrc <- readIORef irsrc + (rsrc', mres) <- rsrc $$++ await + writeIORef irsrc rsrc' + case mres of + Nothing -> return mempty + Just bs + | BS.null bs -> popper + | otherwise -> return bs + f popper diff --git a/src/Network/AWS/Data/Internal/ByteString.hs b/src/Network/AWS/Data/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/ByteString.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.ByteString + ( LazyByteString + + , ToByteString (..) + , showBS + + , ToBuilder (..) + , buildBS + + , stripBS + ) where + +import Crypto.Hash +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as Build +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Char +import Data.Int +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Time (UTCTime) +import GHC.Generics +import Network.AWS.Data.Internal.Text +import Network.HTTP.Types.Method +import Numeric.Natural + +type LazyByteString = LBS.ByteString + +showBS :: ToByteString a => a -> String +showBS = BS.unpack . toBS + +class ToByteString a where + toBS :: a -> ByteString + + default toBS :: ToText a => a -> ByteString + toBS = Text.encodeUtf8 . toText + +instance ToByteString Builder where toBS = buildBS +instance ToByteString ByteString where toBS = id +instance ToByteString Text where toBS = Text.encodeUtf8 +instance ToByteString Int where toBS = buildBS +instance ToByteString Integer where toBS = buildBS +instance ToByteString Natural where toBS = buildBS +instance ToByteString Double where toBS = buildBS +instance ToByteString StdMethod where toBS = renderStdMethod +instance ToByteString (Digest a) where toBS = digestToHexByteString +instance ToByteString UTCTime where toBS = BS.pack . show + +instance ToByteString a => ToByteString (CI a) where + toBS = toBS . CI.original + +buildBS :: ToBuilder a => a -> ByteString +buildBS = LBS.toStrict . Build.toLazyByteString . build + +class ToBuilder a where + build :: a -> Builder + + default build :: ToByteString a => a -> Builder + build = build . toBS + +instance ToBuilder Builder where build = id +instance ToBuilder ByteString where build = Build.byteString +instance ToBuilder Char where build = Build.charUtf8 +instance ToBuilder [Char] where build = Build.stringUtf8 +instance ToBuilder Int where build = Build.intDec +instance ToBuilder Int64 where build = Build.int64Dec +instance ToBuilder Integer where build = Build.integerDec +instance ToBuilder Natural where build = Build.integerDec . toInteger +instance ToBuilder Double where build = Build.doubleDec +instance ToBuilder StdMethod +instance ToBuilder (Digest a) + +stripBS :: ByteString -> ByteString +stripBS = BS.dropWhile isSpace . fst . BS.spanEnd isSpace diff --git a/src/Network/AWS/Data/Internal/Header.hs b/src/Network/AWS/Data/Internal/Header.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Header.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.Data.Internal.Header +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Header where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import Data.Foldable as Fold +import Data.Function (on) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.List (deleteBy) +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Text +import Network.HTTP.Types + +hHost :: HeaderName +hHost = "Host" + +hAMZToken :: HeaderName +hAMZToken = "X-Amz-Security-Token" + +hAMZTarget :: HeaderName +hAMZTarget = "X-Amz-Target" + +hAMZAuth :: HeaderName +hAMZAuth = "X-Amzn-Authorization" + +hAMZDate :: HeaderName +hAMZDate = "X-Amz-Date" + +hMetaPrefix :: HeaderName +hMetaPrefix = "X-Amz-" + +(~:) :: FromText a => ResponseHeaders -> HeaderName -> Either String a +hs ~: k = hs ~:? k >>= note + where + note Nothing = Left (BS.unpack $ "Unable to find header: " <> CI.original k) + note (Just x) = Right x + +(~:?) :: FromText a => ResponseHeaders -> HeaderName -> Either String (Maybe a) +hs ~:? k = + maybe (Right Nothing) + (fmap Just . fromText . Text.decodeUtf8) + (k `lookup` hs) + +class ToHeaders a where + toHeaders :: a -> [Header] + toHeaders = const mempty + +(=:) :: ToHeader a => HeaderName -> a -> [Header] +(=:) = toHeader + +hdr :: HeaderName -> ByteString -> [Header] -> [Header] +hdr k v hs = let h = (k, v) in deleteBy ((==) `on` fst) h hs ++ [h] + +hdrs :: [Header] -> [Header] -> [Header] +hdrs xs ys = Fold.foldr' (uncurry hdr) ys xs + +class ToHeader a where + toHeader :: HeaderName -> a -> [Header] + +instance ToHeader Text where + toHeader k = toHeader k . Text.encodeUtf8 + +instance ToHeader ByteString where + toHeader k = toHeader k . Just + +instance ToByteString a => ToHeader (Maybe a) where + toHeader k = maybe [] (\v -> [(k, toBS v)]) + +instance (ToByteString k, ToByteString v) => ToHeader (HashMap k v) where + toHeader p = map (\(k, v) -> (p <> CI.mk (toBS k), toBS v)) . Map.toList diff --git a/src/Network/AWS/Data/Internal/JSON.hs b/src/Network/AWS/Data/Internal/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/JSON.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.Data.Internal.JSON +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.JSON + ( + -- * FromJSON + FromJSON (..) + , parseJSONText + -- ** Parser a + , withObject + , (.:) + , (.:?) + -- ** Either String a + , (.:>) + , (.:?>) + + -- * ToJSON + , ToJSON (..) + , toJSONText + , object + , (.=) + ) where + +import Data.Aeson.Types +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import Network.AWS.Data.Internal.Text + +parseJSONText :: FromText a => String -> Value -> Parser a +parseJSONText n = withText n (either fail return . fromText) +{-# INLINE parseJSONText #-} + +toJSONText :: ToText a => a -> Value +toJSONText = String . toText +{-# INLINE toJSONText #-} + +(.:>) :: FromJSON a => Object -> Text -> Either String a +(.:>) o k = + case Map.lookup k o of + Nothing -> Left $ "key " ++ show k ++ " not present" + Just v -> parseEither parseJSON v +{-# INLINE (.:>) #-} + +(.:?>) :: FromJSON a => Object -> Text -> Either String (Maybe a) +(.:?>) o k = + case Map.lookup k o of + Nothing -> Right Nothing + Just v -> parseEither parseJSON v +{-# INLINE (.:?>) #-} diff --git a/src/Network/AWS/Data/Internal/List.hs b/src/Network/AWS/Data/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/List.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Data.Internal.List +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.List where + +import Control.Lens hiding (coerce, element) +import Control.Monad +import Data.Aeson +import Data.Coerce +import Data.Foldable (Foldable) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe +import Data.Monoid +import Data.Proxy +import Data.Semigroup (Semigroup) +import Data.String +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import GHC.Exts +import GHC.TypeLits +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.XML +import Text.XML + +newtype List (e :: Symbol) a = List { list :: [a] } + deriving (Eq, Ord, Show, Semigroup, Monoid) + +newtype List1 (e :: Symbol) a = List1 { list1 :: NonEmpty a } + deriving (Eq, Ord, Show, Semigroup) + +deriving instance Functor (List1 e) +deriving instance Foldable (List1 e) +deriving instance Traversable (List1 e) + +type role List phantom representational +type role List1 phantom representational + +_List :: (Coercible a b, Coercible b a) => Iso' (List e a) [b] +_List = iso (coerce . list) (List . coerce) + +_List1 :: (Coercible a b, Coercible b a) => Iso' (List1 e a) (NonEmpty b) +_List1 = iso (coerce . list1) (List1 . coerce) + +instance IsList (List e a) where + type Item (List e a) = a + + fromList = List + toList = list + +fromList1 :: List1 e a -> List e a +fromList1 = List . toList . list1 + +toList1 :: List e a -> Either String (List1 e a) +toList1 (List (x:xs)) + = Right $ List1 (x :| xs) +toList1 _ = Left $ "Unexpected empty list, expected at least 1 element." + +instance ToQuery a => ToQuery (List e a) where + toQuery = toQuery . list + +instance ToQuery a => ToQuery (List1 e a) where + toQuery = toQuery . toList . list1 + +instance FromJSON a => FromJSON (List e a) where + parseJSON = fmap List . parseJSON + +instance FromJSON a => FromJSON (List1 e a) where + parseJSON = withArray "List1" $ \case + v | Vector.null v -> fail "Empty array, expected at least 1 element." + v -> traverse parseJSON + . List1 $ Vector.unsafeHead v :| Vector.toList (Vector.unsafeTail v) + +instance ToJSON a => ToJSON (List e a) where + toJSON = toJSON . list + +instance ToJSON a => ToJSON (List1 e a) where + toJSON = toJSON . toList . list1 + +instance (KnownSymbol e, FromXML a) => FromXML (List e a) where + parseXML = fmap List . traverse parseXML . mapMaybe (childNodes n) + where + n = Text.pack $ symbolVal (Proxy :: Proxy e) + +instance (KnownSymbol e, FromXML a) => FromXML (List1 e a) where + parseXML = parseXML >=> toList1 + +instance (KnownSymbol e, ToXML a) => ToXML (List e a) where + toXML = map (NodeElement . element n . toXML) . list + where + n = fromString $ symbolVal (Proxy :: Proxy e) + +instance (KnownSymbol e, ToXML a) => ToXML (List1 e a) where + toXML = toXML . fromList1 diff --git a/src/Network/AWS/Data/Internal/Map.hs b/src/Network/AWS/Data/Internal/Map.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Map.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.AWS.Data.Internal.Map +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Map + ( Map (..) + , _Map + , (~::) + + , EMap (..) + , _EMap + ) where + +import Control.Applicative +import Control.Lens hiding (coerce, element) +import Data.Aeson +import Data.Bifunctor +import qualified Data.ByteString.Char8 as BS +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Coerce +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Hashable (Hashable) +import Data.Maybe +import Data.Monoid +import Data.Proxy +import Data.Semigroup (Semigroup) +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import GHC.Exts +import GHC.TypeLits +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Header +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.XML +import Network.HTTP.Types.Header +import Text.XML + +newtype Map k v = Map + { fromMap :: HashMap k v + } deriving (Eq, Show, Monoid, Semigroup) + +type role Map nominal representational + +_Map :: (Coercible a b, Coercible b a) => Iso' (Map k a) (HashMap k b) +_Map = iso (coerce . fromMap) (Map . coerce) + +instance (Eq k, Hashable k) => IsList (Map k v) where + type Item (Map k v) = (k, v) + + fromList = Map . Map.fromList + toList = Map.toList . fromMap + +instance (Eq k, Hashable k, FromText k, FromJSON v) => FromJSON (Map k v) where + parseJSON = withObject "HashMap" $ + fmap (Map . Map.fromList) + . traverse g + . Map.toList + where + g (k, v) = (,) + <$> either fail return (fromText k) + <*> parseJSON v + +instance (Eq k, Hashable k, ToText k, ToJSON v) => ToJSON (Map k v) where + toJSON = Object . Map.fromList . map (bimap toText toJSON) . toList + +(~::) :: ResponseHeaders + -> CI Text + -> Either String (Map (CI Text) Text) +hs ~:: (CI.foldedCase -> p) = Right . fromList $ mapMaybe f hs + where + f (CI.map Text.decodeUtf8 -> k, Text.decodeUtf8 -> v) = + (,v) . CI.mk <$> Text.stripPrefix p (CI.foldedCase k) + +instance ToHeader (Map (CI Text) Text) where + toHeader (CI.foldedCase -> p) = map (first CI.mk . f) . toList + where + f (CI.foldedCase -> toBS -> k, toBS -> v) + | BS.isPrefixOf p k = (k, v) + | otherwise = (p <> k, v) + +newtype EMap (e :: Symbol) (i :: Symbol) (j :: Symbol) k v = EMap + { fromEMap :: HashMap k v + } deriving (Eq, Show, Monoid, Semigroup) + +type role EMap phantom phantom phantom nominal representational + +_EMap :: (Coercible a b, Coercible b a) => Iso' (EMap e i j k a) (HashMap k b) +_EMap = iso (coerce . fromEMap) (EMap . coerce) + +instance (Eq k, Hashable k) => IsList (EMap e i j k v) where + type Item (EMap e i j k v) = (k, v) + + fromList = EMap . Map.fromList + toList = Map.toList . fromEMap + +instance ( KnownSymbol e + , KnownSymbol i + , KnownSymbol j + , Eq k + , Hashable k + , ToQuery k + , ToQuery v + ) => ToQuery (EMap e i j k v) where + toQuery m = toBS e =? (mconcat . zipWith go idx $ toList m) + where + go n (k, v) = toBS n =? toQuery (i, k) <> toQuery (j, v) + + idx = [1..] :: [Integer] + + i = BS.pack $ symbolVal (Proxy :: Proxy i) + j = BS.pack $ symbolVal (Proxy :: Proxy j) + e = BS.pack $ symbolVal (Proxy :: Proxy e) + +instance ( KnownSymbol e + , KnownSymbol i + , KnownSymbol j + , Eq k + , Hashable k + , FromXML k + , FromXML v + ) => FromXML (EMap e i j k v) where + parseXML = fmap fromList . traverse (withElement e go . (:[])) + where + go ns + | length ns == 2 = + (,) <$> withElement i parseXML ns + <*> withElement j parseXML ns + | otherwise = + Left $ "Expected two elements named " + ++ show i ++ " and " + ++ show j ++ " within " + ++ show e + + i = fromString $ symbolVal (Proxy :: Proxy i) + j = fromString $ symbolVal (Proxy :: Proxy j) + e = fromString $ symbolVal (Proxy :: Proxy e) + +instance ( KnownSymbol e + , KnownSymbol i + , KnownSymbol j + , Eq k + , Hashable k + , ToXML k + , ToXML v + ) => ToXML (EMap e i j k v) where + toXML = map (uncurry go) . toList + where + go k v = + NodeElement $ element e + [ NodeElement (element i (toXML k)) + , NodeElement (element j (toXML v)) + ] + + i = fromString $ symbolVal (Proxy :: Proxy i) + j = fromString $ symbolVal (Proxy :: Proxy j) + e = fromString $ symbolVal (Proxy :: Proxy e) diff --git a/src/Network/AWS/Data/Internal/Numeric.hs b/src/Network/AWS/Data/Internal/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Numeric.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.AWS.Data.Internal.Numeric +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Numeric where + +import Control.Applicative +import Control.Lens.TH +import Control.Monad +import Data.Aeson.Types +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.XML +import Numeric.Natural + +newtype Nat = Nat { unNat :: Natural } + deriving + ( Eq + , Ord + , Show + , Enum + , Num + , Real + , Integral + , Whole + , ToByteString + , FromText + , ToText + , FromXML + , ToXML + , ToQuery + ) + +instance FromJSON Nat where + parseJSON = parseJSON >=> \n -> + if n < 0 + then fail $ "Cannot convert negative number to Natural: " ++ show n + else pure $ Nat (fromInteger n) + +instance ToJSON Nat where + toJSON = String . toText . unNat + +makePrisms ''Nat diff --git a/src/Network/AWS/Data/Internal/Path.hs b/src/Network/AWS/Data/Internal/Path.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Path.hs @@ -0,0 +1,23 @@ +-- Module : Network.AWS.Data.Internal.Path +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Path + ( ToPath (..) + ) where + +import Data.Monoid +import Data.Text (Text) + +class ToPath a where + toPath :: a -> Text + toPath = const mempty + +instance ToPath Text where + toPath = id diff --git a/src/Network/AWS/Data/Internal/Query.hs b/src/Network/AWS/Data/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Query.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- Module : Network.AWS.Data.Internal.Query +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Query + ( ToQuery (..) + , renderQuery + + , Query + , keysOf + , valuesOf + + , pair + , (=?) + ) where + +import Control.Applicative +import Control.Lens hiding (to, from) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Data +import Data.Data.Lens +import Data.List (sort) +import Data.Monoid +import Data.String +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Text +import Numeric.Natural + +data Query + = List [Query] + | Pair ByteString Query + | Value (Maybe ByteString) + deriving (Eq, Show, Data, Typeable) + +makePrisms ''Query + +instance Monoid Query where + mempty = List [] + + mappend a b = case (a, b) of + (List l, List r) -> List (l ++ r) + (List l, r) -> List (r : l) + (l, List r) -> List (l : r) + (l, r) -> List [l, r] + +instance Plated Query where + plate = uniplate + +instance ToByteString Query where + toBS = renderQuery + +instance ToText Query where + toText = Text.decodeUtf8 . renderQuery + +instance IsString Query where + fromString = toQuery . BS.pack + +keysOf :: Traversal' Query ByteString +keysOf = deep (_Pair . _1) + +valuesOf :: Traversal' Query (Maybe ByteString) +valuesOf = deep _Value + +pair :: ToQuery a => ByteString -> a -> Query -> Query +pair k v = mappend (Pair k (toQuery v)) + +(=?) :: ToQuery a => ByteString -> a -> Query +(=?) k v = Pair k (toQuery v) + +renderQuery :: Query -> ByteString +renderQuery = intercalate . sort . enc Nothing + where + enc k (List xs) = concatMap (enc k) xs + enc k (Pair k' x) + | Just n <- k = enc (Just $ n <> "." <> k') x + | otherwise = enc (Just k') x + enc k (Value (Just v)) + | Just n <- k = [n <> vsep <> v] + | otherwise = [v] + enc k _ + | Just n <- k = [n] + | otherwise = [] + + intercalate [] = mempty + intercalate [x] = x + intercalate (x:xs) = x <> ksep <> intercalate xs + + ksep = "&" + vsep = "=" + +class ToQuery a where + toQuery :: a -> Query + toQuery = const mempty + +instance ToQuery Query where + toQuery = id + +instance (ToByteString k, ToQuery v) => ToQuery (k, v) where + toQuery (k, v) = Pair (toBS k) (toQuery v) + +instance (ToByteString k, ToByteString v) => ToQuery (k, Maybe v) where + toQuery (k, v) = Pair (toBS k) . Value $ toBS <$> v + +instance ToQuery Char where + toQuery = toQuery . BS.singleton + +instance ToQuery ByteString where + toQuery "" = Value Nothing + toQuery bs = Value (Just bs) + +instance ToQuery Text where toQuery = toQuery . toBS +instance ToQuery Int where toQuery = toQuery . toBS +instance ToQuery Integer where toQuery = toQuery . toBS +instance ToQuery Double where toQuery = toQuery . toBS +instance ToQuery Natural where toQuery = toQuery . toBS + +instance ToQuery a => ToQuery [a] where + toQuery = List . zipWith (\n v -> Pair (toBS n) (toQuery v)) idx + where + idx = [1..] :: [Integer] + +instance ToQuery a => ToQuery (Maybe a) where + toQuery (Just x) = toQuery x + toQuery Nothing = mempty + +instance ToQuery Bool where + toQuery True = toQuery ("true" :: ByteString) + toQuery False = toQuery ("false" :: ByteString) diff --git a/src/Network/AWS/Data/Internal/Sensitive.hs b/src/Network/AWS/Data/Internal/Sensitive.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Sensitive.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- Module : Network.AWS.Data.Internal.Sensitive +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Sensitive where + +import Control.Lens +import Data.Monoid +import Data.String +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.JSON +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.XML + +newtype Sensitive a = Sensitive { desensitise :: a } + deriving + ( Eq + , Ord + , IsString + , Monoid + , ToByteString + , FromText + , ToText + , FromXML + , ToXML + , ToQuery + , ToJSON + , FromJSON + ) + +instance Show (Sensitive a) where + show = const "******" + +_Sensitive :: Iso' (Sensitive a) a +_Sensitive = iso desensitise Sensitive diff --git a/src/Network/AWS/Data/Internal/Text.hs b/src/Network/AWS/Data/Internal/Text.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Text.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.Data.Internal.Text +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Text + ( FromText (..) + , fromText + , match + , matchCI + , AText.takeText + + , ToText (..) + , showText + ) where + +import Control.Applicative +import Crypto.Hash +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as AText +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.Int +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding 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.Lazy.Builder.RealFloat as Build +import Network.HTTP.Client +import Network.HTTP.Types +import Numeric.Natural + +fromText :: FromText a => Text -> Either String a +fromText = AText.parseOnly parser + +-- FIXME: improve the error messages for partial match, or extra input etc. +match :: Text -> a -> Parser a +match x y = AText.string x <* AText.endOfInput >> return y + +matchCI :: Text -> a -> Parser a +matchCI x y = AText.asciiCI x <* AText.endOfInput >> return y + +class FromText a where + parser :: Parser a + +instance FromText Text where parser = AText.takeText +instance FromText ByteString where parser = Text.encodeUtf8 <$> AText.takeText +instance FromText Int where parser = AText.decimal +instance FromText Integer where parser = AText.decimal +instance FromText Natural where parser = AText.decimal +instance FromText Double where parser = AText.rational + +instance FromText Bool where + parser = matchCI "false" False <|> matchCI "true" True + +showText :: ToText a => a -> String +showText = Text.unpack . toText + +class ToText a where + toText :: a -> Text + +instance (ToText a, ToText b) => ToText (a, b) where + toText (a, b) = "(" <> toText a <> ", " <> toText b <> ")" + +instance ToText a => ToText [a] where + toText xs = "[" <> Text.intercalate ", " (map toText xs) <> "]" + +instance ToText a => ToText (CI a) where + toText = toText . CI.original + +instance ToText (Response a) where + toText rs = Text.pack . show $ rs { responseBody = () } + +instance ToText Text where toText = id +instance ToText ByteString where toText = Text.decodeUtf8 +instance ToText Int where toText = shortText . Build.decimal +instance ToText Int64 where toText = shortText . Build.decimal +instance ToText Integer where toText = shortText . Build.decimal +instance ToText Natural where toText = shortText . Build.decimal +instance ToText Double where toText = shortText . Build.realFloat +instance ToText StdMethod where toText = toText . renderStdMethod +instance ToText (Digest a) where toText = toText . digestToHexByteString + +instance ToText Bool where + toText True = "true" + toText False = "false" + +shortText :: Builder -> Text +shortText = LText.toStrict . Build.toLazyTextWith 32 diff --git a/src/Network/AWS/Data/Internal/Time.hs b/src/Network/AWS/Data/Internal/Time.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/Time.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- Module : Network.AWS.Data.Internal.Time +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.Time + ( Format (..) + , Time (..) + , _Time + + , UTCTime + , RFC822 + , ISO8601 + , BasicTime + , AWSTime + , POSIX + ) where + +import Control.Applicative +import Control.Lens +import Data.Aeson +import Data.Attoparsec.Text (Parser) +import qualified Data.Attoparsec.Text as AText +import qualified Data.ByteString.Char8 as BS +import Data.Function (on) +import Data.Tagged +import qualified Data.Text as Text +import Data.Time +import Data.Time.Clock.POSIX +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.JSON +import Network.AWS.Data.Internal.Query +import Network.AWS.Data.Internal.Text +import Network.AWS.Data.Internal.XML +import System.Locale + +data Format + = RFC822Format + | ISO8601Format + | BasicFormat + | AWSFormat + | POSIXFormat + deriving (Eq, Show) + +data Time :: Format -> * where + Time :: UTCTime -> Time a + LocaleTime :: TimeLocale -> UTCTime -> Time a + +deriving instance Show (Time a) +deriving instance Eq (Time a) + +instance Ord (Time (a :: Format)) where + compare = compare `on` ts + where + ts (Time t) = (t, defaultTimeLocale) + ts (LocaleTime l t) = (t, l) + + +-- | This is a poorly behaved isomorphism, due to the fact 'LocaleTime' only +-- exists for testing purposes, and we wish to compose using 'mapping' +-- in actual usage. +_Time :: Iso' (Time a) UTCTime +_Time = iso (\case; Time a -> a; LocaleTime _ a -> a) Time + +type RFC822 = Time RFC822Format +type ISO8601 = Time ISO8601Format +type BasicTime = Time BasicFormat +type AWSTime = Time AWSFormat +type POSIX = Time POSIXFormat + +class TimeFormat a where + format :: Tagged a String + +instance TimeFormat RFC822 where format = Tagged "%a, %d %b %Y %H:%M:%S GMT" +instance TimeFormat ISO8601 where format = Tagged (iso8601DateFormat (Just "%XZ")) +instance TimeFormat BasicTime where format = Tagged "%Y%m%d" +instance TimeFormat AWSTime where format = Tagged "%Y%m%dT%H%M%SZ" + +instance FromText RFC822 where parser = parseFormattedTime +instance FromText ISO8601 where parser = parseFormattedTime +instance FromText BasicTime where parser = parseFormattedTime +instance FromText AWSTime where parser = parseFormattedTime + +instance FromText POSIX where + parser = Time . posixSecondsToUTCTime . realToFrac + <$> (parser :: Parser Integer) + +parseFormattedTime :: forall a. TimeFormat (Time a) => Parser (Time a) +parseFormattedTime = do + x <- Text.unpack <$> AText.takeText + p (parseTime defaultTimeLocale (untag f) x) x + where + p :: Maybe UTCTime -> String -> Parser (Time a) + p Nothing s = fail ("Unable to parse " ++ untag f ++ " from " ++ s) + p (Just x) _ = return (Time x) + + f :: Tagged (Time a) String + f = format + +instance ToText RFC822 where toText = Text.pack . renderFormattedTime +instance ToText ISO8601 where toText = Text.pack . renderFormattedTime +instance ToText BasicTime where toText = Text.pack . renderFormattedTime +instance ToText AWSTime where toText = Text.pack . renderFormattedTime + +instance ToText POSIX where + toText t = toText time + where + time :: Integer + time = truncate . utcTimeToPOSIXSeconds $ + case t of + Time x -> x + LocaleTime _ x -> x + +renderFormattedTime :: forall a. TimeFormat (Time a) => Time a -> String +renderFormattedTime x = formatTime l (untag f) t + where + (l, t) = case x of + Time t' -> (defaultTimeLocale, t') + LocaleTime l' t' -> (l', t') + + f :: Tagged (Time a) String + f = format + +instance FromXML RFC822 where parseXML = parseXMLText "RFC822" +instance FromXML ISO8601 where parseXML = parseXMLText "ISO8601" +instance FromXML AWSTime where parseXML = parseXMLText "AWSTime" +instance FromXML BasicTime where parseXML = parseXMLText "BasicTime" +instance FromXML POSIX where parseXML = parseXMLText "POSIX" + +instance FromJSON RFC822 where parseJSON = parseJSONText "RFC822" +instance FromJSON ISO8601 where parseJSON = parseJSONText "ISO8601" +instance FromJSON AWSTime where parseJSON = parseJSONText "AWSTime" +instance FromJSON BasicTime where parseJSON = parseJSONText "BasicTime" +instance FromJSON POSIX where parseJSON = parseJSONText "POSIX" + +instance ToByteString RFC822 where toBS = BS.pack . renderFormattedTime +instance ToByteString ISO8601 where toBS = BS.pack . renderFormattedTime +instance ToByteString BasicTime where toBS = BS.pack . renderFormattedTime +instance ToByteString AWSTime where toBS = BS.pack . renderFormattedTime + +instance ToQuery RFC822 where toQuery = toQuery . toBS +instance ToQuery ISO8601 where toQuery = toQuery . toBS +instance ToQuery BasicTime where toQuery = toQuery . toBS +instance ToQuery AWSTime where toQuery = toQuery . toBS + +instance ToXML RFC822 where toXML = toXMLText +instance ToXML ISO8601 where toXML = toXMLText +instance ToXML AWSTime where toXML = toXMLText +instance ToXML BasicTime where toXML = toXMLText +instance ToXML POSIX where toXML = toXMLText + +instance ToJSON RFC822 where toJSON = toJSONText +instance ToJSON ISO8601 where toJSON = toJSONText +instance ToJSON AWSTime where toJSON = toJSONText +instance ToJSON BasicTime where toJSON = toJSONText +instance ToJSON POSIX where toJSON = toJSONText diff --git a/src/Network/AWS/Data/Internal/URI.hs b/src/Network/AWS/Data/Internal/URI.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/URI.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.Data.Internal.URI +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.URI + ( collapseURI + , encodeURI + ) where + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Char +import qualified Data.Foldable as Fold +import Data.Monoid +import Network.AWS.Data.Internal.ByteString + +collapseURI :: ByteString -> ByteString +collapseURI bs + | BS.null bs = slash + | BS.null path = slash + | otherwise = tl (hd path) + where + path = BS.intercalate slash + . reverse + . Fold.foldl' go [] + . filter (/= mempty) + $ BS.split sep bs + + hd x | BS.head x == sep = x + | otherwise = sep `BS.cons` x + + tl x | BS.last x == sep = x + | BS.last bs == sep = x `BS.snoc` sep + | otherwise = x + + go acc c | c == dot = acc + go acc c | c == dots = remv acc c + go acc c = c : acc + + remv [] _ = [] + remv (x : xs) c + | x == dot = c : xs + | x == dots = c : x : xs + | otherwise = xs + + dot = "." + dots = ".." + + slash = BS.singleton sep + + sep = '/' + +encodeURI :: Bool -> ByteString -> ByteString +encodeURI p = toBS . BS.foldr (mappend . enc) mempty + where + enc ' ' = "%20" + enc c@'/' + | p = "%2F" + | otherwise = build c + enc c + | reserved c = build c + enc c = char2hex c + + reserved c = + isAsciiUpper c + || isAsciiLower c + || isDigit c + || c `elem` "-_.~" + + char2hex c = + let (a, b) = fromEnum c `divMod` 16 + in build ['%', hex a, hex b] + + hex i | i < 10 = toEnum (48 + i) + | otherwise = toEnum (65 + i - 10) diff --git a/src/Network/AWS/Data/Internal/XML.hs b/src/Network/AWS/Data/Internal/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Data/Internal/XML.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Module : Network.AWS.Data.Internal.XML +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Data.Internal.XML + ( + -- * FromXML + FromXML (..) + , decodeXML + , parseXMLText + , childNodes + , findElement + , withContent + , withElement + , withNode + , (.@) + , (.@?) + + -- * ToXML + , ToXML (..) + , ToXMLRoot (..) + , encodeXML + , toXMLText + , namespaced + , element + , nodes + , (=@) + , unsafeToXML + ) where + +import Control.Applicative +import Control.Monad +import Data.Default.Class +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import Network.AWS.Data.Internal.ByteString +import Network.AWS.Data.Internal.Text +import Numeric.Natural +import Text.XML + +decodeXML :: LazyByteString -> Either String [Node] +decodeXML = either failure success . parseLBS def + where + failure = Left . show + success = Right . elementNodes . documentRoot + +encodeXML :: ToXMLRoot a => a -> LazyByteString +encodeXML x = renderLBS def d + where + d = Document + { documentPrologue = p + , documentRoot = toXMLRoot x + , documentEpilogue = [] + } + + p = Prologue + { prologueBefore = [] + , prologueDoctype = Nothing + , prologueAfter = [] + } + +parseXMLText :: FromText a => String -> [Node] -> Either String a +parseXMLText n = withContent n fromText +{-# INLINE parseXMLText #-} + +toXMLText :: ToText a => a -> [Node] +toXMLText x = [NodeContent (toText x)] +{-# INLINE toXMLText #-} + +(.@) :: FromXML a => [Node] -> Text -> Either String a +ns .@ n = findElement n ns >>= parseXML +{-# INLINE (.@) #-} + +(.@?) :: FromXML a => [Node] -> Text -> Either String (Maybe a) +ns .@? n = + case findElement n ns of + Left _ -> Right Nothing + Right xs -> parseXML xs +{-# INLINE (.@?) #-} + +namespaced :: Text -> Text -> [Node] -> Element +namespaced g l = element (Name l (Just g) Nothing) +{-# INLINE namespaced #-} + +element :: Name -> [Node] -> Element +element n = Element n mempty +{-# INLINE element #-} + +nodes :: Name -> [Node] -> [Node] +nodes n ns = [NodeElement (element n ns)] +{-# INLINE nodes #-} + +(=@) :: ToXML a => Name -> a -> Node +n =@ x = NodeElement (element n (toXML x)) +{-# INLINE (=@) #-} + +-- | /Caution:/ This is for use with types which are 'flattened' in +-- AWS service model terminology. It is applied by the generator/templating +-- in safe contexts only. +unsafeToXML :: (Show a, ToXML a) => a -> Node +unsafeToXML x = + fromMaybe (error $ "Failed to unflatten node-list for: " ++ show x) + (listToMaybe (toXML x)) +{-# INLINE unsafeToXML #-} + +withContent :: String -> (Text -> Either String a) -> [Node] -> Either String a +withContent n f = withNode n (join . fmap f . g) + where + g (NodeContent x) + = Right x + g (NodeElement e) + = Left $ "unexpected element " ++ show (elementName e) ++ " when expecting node content: " ++ n + g _ = Left $ "unexpected element, when expecting node content: " ++ n +{-# INLINE withContent #-} + +withNode :: String -> (Node -> Either String a) -> [Node] -> Either String a +withNode n f = \case + [x] -> f x + [] -> Left $ "empty node list, when expecting a single node: " ++ n + _ -> Left $ "encountered node list, when expecting a single node: " ++ n +{-# INLINE withNode #-} + +withElement :: Text -> ([Node] -> Either String a) -> [Node] -> Either String a +withElement n f = join . fmap f . findElement n +{-# INLINE withElement #-} + +findElement :: Text -> [Node] -> Either String [Node] +findElement n = maybe err Right . listToMaybe . mapMaybe (childNodes n) + where + err = Left $ "unable to find element " ++ show n +{-# INLINE findElement #-} + +childNodes :: Text -> Node -> Maybe [Node] +childNodes n (NodeElement e) + | nameLocalName (elementName e) == n = Just (elementNodes e) +childNodes _ _ = Nothing +{-# INLINE childNodes #-} + +class FromXML a where + parseXML :: [Node] -> Either String a + +instance FromXML a => FromXML (Maybe a) where + parseXML [] = pure Nothing + parseXML ns = Just <$> parseXML ns + {-# INLINE parseXML #-} + +instance FromXML Text where parseXML = parseXMLText "Text" +instance FromXML Int where parseXML = parseXMLText "Int" +instance FromXML Integer where parseXML = parseXMLText "Integer" +instance FromXML Natural where parseXML = parseXMLText "Natural" +instance FromXML Double where parseXML = parseXMLText "Double" +instance FromXML Bool where parseXML = parseXMLText "Bool" + +class ToXMLRoot a where + toXMLRoot :: a -> Element + +class ToXML a where + toXML :: a -> [Node] + + default toXML :: ToXMLRoot a => a -> [Node] + toXML = (:[]) . NodeElement . toXMLRoot + {-# INLINE toXML #-} + +instance ToXML a => ToXML (Maybe a) where + toXML (Just x) = toXML x + toXML Nothing = [] + {-# INLINE toXML #-} + +instance ToXML Text where toXML = toXMLText +instance ToXML Int where toXML = toXMLText +instance ToXML Integer where toXML = toXMLText +instance ToXML Natural where toXML = toXMLText +instance ToXML Double where toXML = toXMLText +instance ToXML Bool where toXML = toXMLText diff --git a/src/Network/AWS/EC2/Metadata.hs b/src/Network/AWS/EC2/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/EC2/Metadata.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.EC2.Metadata +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Retrieve an EC2 instance's local metadata. +module Network.AWS.EC2.Metadata + ( + -- * Requests + -- ** Running on EC2 + isEC2 + + -- ** Dynamic + , Dynamic (..) + , dynamic + + -- ** Metadata + , Metadata (..) + , Mapping (..) + , Info (..) + , Interface (..) + , metadata + + -- ** User data + , userdata + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import Control.Monad.Except +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as Text +import Network.AWS.Data +import Network.HTTP.Client +import Network.HTTP.Types (status404) + +data Dynamic + = FWS + -- ^ Value showing whether the customer has enabled detailed one-minute + -- monitoring in CloudWatch. + -- + -- Valid values: enabled | disabled. + | Document + -- ^ JSON containing instance attributes, such as instance-id, + -- private IP address, etc. + | PKCS7 + -- ^ Used to verify the document's authenticity and content against the + -- signature. + | Signature + +instance ToPath Dynamic where + toPath x = case x of + FWS -> "fws/instance-monitoring" + Document -> "instance-identity/document" + PKCS7 -> "instance-identity/pkcs7" + Signature -> "instance-identity/signature" + +data Metadata + = AMIId + -- ^ The AMI ID used to launch the instance. + | AMILaunchIndex + -- ^ If you started more than one instance at the same time, this value + -- indicates the order in which the instance was launched. + -- The value of the first instance launched is 0. + | AMIManifestPath + -- ^ The path to the AMI's manifest file in Amazon S3. + -- If you used an Amazon EBS-backed AMI to launch the instance, + -- the returned result is unknown. + | AncestorAMIIds + -- ^ The AMI IDs of any instances that were rebundled to create this AMI. + -- This value will only exist if the AMI manifest file contained an + -- ancestor-amis key. + | BlockDevice !Mapping + -- ^ See: 'Mapping' + | Hostname + -- ^ The private hostname of the instance. In cases where multiple network + -- interfaces are present, this refers to the eth0 device + -- (the device for which the device number is 0). + | IAM !Info + -- ^ See: 'Info' + | InstanceAction + -- ^ Notifies the instance that it should reboot in preparation for bundling. + -- Valid values: none | shutdown | bundle-pending. + | InstanceId + -- ^ The ID of this instance. + | InstanceType + -- ^ The type of instance. + -- + -- See: @InstanceType@ + | KernelId + -- ^ The ID of the kernel launched with this instance, if applicable. + | LocalHostname + -- ^ The private DNS hostname of the instance. In cases where multiple + -- network interfaces are present, this refers to the eth0 device + -- (the device for which the device number is 0). + | LocalIPV4 + -- ^ The private IP address of the instance. In cases where multiple network + -- interfaces are present, this refers to the eth0 device + -- (the device for which the device number is 0). + | MAC + -- ^ The instance's media access control (MAC) address. In cases where + -- multiple network interfaces are present, this refers to the eth0 device + -- (the device for which the device number is 0). + | Network !Text !Interface + -- ^ See: 'Interface' + | AvailabilityZone + -- ^ The Availability Zone in which the instance launched. + | ProductCodes + -- ^ Product codes associated with the instance, if any. + | PublicHostname + -- ^ The instance's public DNS. If the instance is in a VPC, this category + -- is only returned if the enableDnsHostnames attribute is set to true. + -- For more information, see Using DNS with Your VPC. + | PublicIPV4 + -- ^ The public IP address. If an Elastic IP address is associated with the + -- instance, the value returned is the Elastic IP address. + | OpenSSHKey + -- ^ Public key. Only available if supplied at instance launch time. + | RAMDiskId + -- ^ The ID of the RAM disk specified at launch time, if applicable. + | ReservationId + -- ^ ID of the reservation. + | SecurityGroups + -- ^ The names of the security groups applied to the instance. + deriving (Eq, Ord, Show) + +instance ToPath Metadata where + toPath x = case x of + AMIId -> "ami-id" + AMILaunchIndex -> "ami-launch-index" + AMIManifestPath -> "ami-manifest-path" + AncestorAMIIds -> "ancestor-ami-ids" + BlockDevice m -> "block-device-mapping/" <> toPath m + Hostname -> "hostname" + IAM m -> "iam/" <> toPath m + InstanceAction -> "instance-action" + InstanceId -> "instance-id" + InstanceType -> "instance-type" + KernelId -> "kernel-id" + LocalHostname -> "local-hostname" + LocalIPV4 -> "local-ipv4" + MAC -> "mac" + Network n m -> "network/interfaces/macs/" <> n <> "/" <> toPath m + AvailabilityZone -> "placement/availability-zone" + ProductCodes -> "product-codes" + PublicHostname -> "public-hostname" + PublicIPV4 -> "public-ipv4" + OpenSSHKey -> "public-keys/0/openssh-key" + RAMDiskId -> "ramdisk-id" + ReservationId -> "reservation-id" + SecurityGroups -> "security-groups" + +data Mapping + = AMI + -- ^ The virtual device that contains the root/boot file system. + | EBS !Int + -- ^ The virtual devices associated with Amazon EBS volumes, if present. + -- This value is only available in metadata if it is present at launch time. + -- The N indicates the index of the Amazon EBS volume (such as ebs1 or ebs2). + | Ephemeral !Int + -- ^ The virtual devices associated with ephemeral devices, if present. + -- The N indicates the index of the ephemeral volume. + | Root + -- ^ The virtual devices or partitions associated with the root devices, + -- or partitions on the virtual device, where the root (/ or C:) file system + -- is associated with the given instance. + | Swap + -- ^ The virtual devices associated with swap. Not always present. + deriving (Eq, Ord, Show) + +instance ToPath Mapping where + toPath x = case x of + AMI -> "ami" + EBS n -> "ebs" <> toText n + Ephemeral n -> "ephemeral" <> toText n + Root -> "root" + Swap -> "root" + +data Interface + = IDeviceNumber + -- ^ The device number associated with that interface. Each interface must + -- have a unique device number. The device number serves as a hint to device + -- naming in the instance; for example, device-number is 2 for the eth2 device. + | IIPV4Associations !Text + -- ^ The private IPv4 addresses that are associated with each public-ip + -- address and assigned to that interface. + | ILocalHostname + -- ^ The interface's local hostname. + | ILocalIPV4s + -- ^ The private IP addresses associated with the interface. + | IMAC + -- ^ The instance's MAC address. + | IOwnerId + -- ^ The ID of the owner of the network interface. In multiple-interface + -- environments, an interface can be attached by a third party, such as + -- Elastic Load Balancing. Traffic on an interface is always billed to + -- the interface owner. + | IPublicHostname + -- ^ The interface's public DNS. If the instance is in a VPC, this category + -- is only returned if the enableDnsHostnames attribute is set to true. + -- For more information, see Using DNS with Your VPC. + | IPublicIPV4s + -- ^ The Elastic IP addresses associated with the interface. There may be + -- multiple IP addresses on an instance. + | ISecurityGroups + -- ^ Security groups to which the network interface belongs. Returned only + -- for instances launched into a VPC. + | ISecurityGroupIds + -- ^ IDs of the security groups to which the network interface belongs. + -- Returned only for instances launched into a VPC. For more information on + -- security groups in the EC2-VPC platform, see Security Groups for Your VPC. + | ISubnetId + -- ^ The ID of the subnet in which the interface resides. Returned only for + -- instances launched into a VPC. + | ISubnetIPV4_CIDRBlock + -- ^ The CIDR block of the subnet in which the interface resides. Returned + -- only for instances launched into a VPC. + | IVPCId + -- ^ The ID of the VPC in which the interface resides. Returned only for + -- instances launched into a VPC. + | IVPCIPV4_CIDRBlock + -- ^ The CIDR block of the VPC in which the interface resides. Returned only + -- for instances launched into a VPC. + deriving (Eq, Ord, Show) + +instance ToPath Interface where + toPath x = case x of + IDeviceNumber -> "device-number" + IIPV4Associations ip -> "ipv4-associations/" <> ip + ILocalHostname -> "local-hostname" + ILocalIPV4s -> "local-ipv4s" + IMAC -> "mac" + IOwnerId -> "owner-id" + IPublicHostname -> "public-hostname" + IPublicIPV4s -> "public-ipv4s" + ISecurityGroups -> "security-groups" + ISecurityGroupIds -> "security-group-ids" + ISubnetId -> "subnet-id" + ISubnetIPV4_CIDRBlock -> "subnet-ipv4-cidr-block" + IVPCId -> "vpc-id" + IVPCIPV4_CIDRBlock -> "vpc-ipv4-cidr-block" + +data Info + = Info + -- ^ Returns information about the last time the instance profile was updated, + -- including the instance's LastUpdated date, InstanceProfileArn, + -- and InstanceProfileId. + | SecurityCredentials (Maybe Text) + -- ^ Where role-name is the name of the IAM role associated with the instance. + -- Returns the temporary security credentials. + -- + -- See: 'Auth' for JSON deserialisation. + deriving (Eq, Ord, Show) + +instance ToPath Info where + toPath x = case x of + Info -> "info" + SecurityCredentials r -> "security-credentials/" <> fromMaybe "" r + +-- | Test whether the host is running on EC2 by requesting the instance-data. +isEC2 :: Manager -> IO Bool +isEC2 m = liftIO (req `catch` err) + where + req = do + !_ <- request m "http://instance-data/latest" + return True + + err :: IOException -> IO Bool + err = const (return False) + +dynamic :: MonadIO m + => Manager + -> Dynamic + -> ExceptT HttpException m ByteString +dynamic m = get m . mappend "http://169.254.169.254/latest/dynamic/" . toPath + +metadata :: MonadIO m + => Manager + -> Metadata + -> ExceptT HttpException m ByteString +metadata m = get m . mappend "http://169.254.169.254/latest/meta-data/" . toPath + +userdata :: MonadIO m + => Manager + -> ExceptT HttpException m (Maybe ByteString) +userdata m = Just + `liftM` get m "http://169.254.169.254/latest/user-data" + `catchError` err + where + err (StatusCodeException s _ _) + | status404 == s = return Nothing + err e = throwError e + +get :: MonadIO m + => Manager + -> Text + -> ExceptT HttpException m ByteString +get m url = ExceptT . liftIO $ req `catch` err + where + req = Right . strip <$> request m url + + strip bs + | BS.isSuffixOf "\n" bs = BS.init bs + | otherwise = bs + + err :: HttpException -> IO (Either HttpException a) + err = return . Left + +request :: Manager -> Text -> IO ByteString +request m url = do + rq <- parseUrl (Text.unpack url) + rs <- httpLbs (rq { responseTimeout = Just 2 }) m + return . LBS.toStrict $ responseBody rs diff --git a/src/Network/AWS/Error.hs b/src/Network/AWS/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Error.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.AWS.Error +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Error where + +import Control.Applicative +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import GHC.Generics +import Network.AWS.Data +import Network.AWS.Types +import Network.HTTP.Types + +statusSuccess :: Status -> Bool +statusSuccess (statusCode -> n) = n >= 200 && n < 400 + +data ErrorType + = Receiver + | Sender + deriving (Eq, Ord, Enum, Show, Generic) + +instance FromText ErrorType where + parser = match "Receiver" Receiver + <|> match "Sender" Sender + +instance FromXML ErrorType where + parseXML = parseXMLText "Type" + +data RESTMessage = RESTMessage + { _msgType :: !ErrorType + , _msgCode :: Text + , _msgRESTMessage :: Text + } deriving (Eq, Ord, Show, Generic) + +instance FromXML RESTMessage where + parseXML x = RESTMessage + <$> x .@ "Type" + <*> x .@ "Code" + <*> x .@ "Message" + +data RESTError = RESTError + { _errError :: RESTMessage + , _errRequestId :: Text + } deriving (Eq, Show, Generic) + +instance FromXML RESTError where + parseXML x = RESTError + <$> x .@ "Error" + <*> x .@ "RequestId" + +restError :: FromXML (Er a) + => (Status -> Bool) + -> Service a + -> Status + -> Maybe (LBS.ByteString -> ServiceError (Er a)) +restError f Service{..} s + | f s = Nothing + | otherwise = Just (either failure success . (decodeXML >=> parseXML)) + where + success = ServiceError _svcAbbrev s + failure = SerializerError _svcAbbrev + +-- cloudfront +-- autoscaling + +-- +-- +-- Sender +-- InvalidURI +-- Could not parse the specified URI. +-- +-- 410c2a4b-e435-49c9-8382-3770d80d7d4c +-- + +data JSONError = JSONError + { _errType :: Text + , _errMessage :: Text + } deriving (Eq, Show, Generic) + +instance FromJSON JSONError where + parseJSON = withObject "JSONError" $ \o -> + JSONError + <$> o .: "__type" + <*> o .: "message" + +jsonError :: FromJSON (Er a) + => (Status -> Bool) + -> Service a + -> Status + -> Maybe (LBS.ByteString -> ServiceError (Er a)) +jsonError f Service{..} s + | f s = Nothing + | otherwise = Just (either failure success . eitherDecode') + where + success = ServiceError _svcAbbrev s + failure = SerializerError _svcAbbrev + +-- {"__type":"ResourceNotFoundException","message":"Unable to find instance with ID 1"} diff --git a/src/Network/AWS/Pagination.hs b/src/Network/AWS/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Pagination.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} + +-- Module : Network.AWS.Pagination +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Pagination + ( more + , stop + , index + , choice + ) where + +import Control.Applicative +import Control.Lens hiding (index) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import Network.AWS.Data (ToText(..)) + +-- | Generalise IsTruncated and other optional/required +-- response pagination fields. +class AWSMore a where + more :: a -> Bool + +instance AWSMore Bool where + more = id + +instance AWSMore (Maybe Bool) where + more (Just x) = x + more Nothing = False + +instance AWSMore (Maybe Text) where + more (Just _) = True + more Nothing = False + +instance AWSMore [a] where + more = not . null + +instance AWSMore (HashMap k v) where + more = not . Map.null + +stop :: AWSMore a => a -> Bool +stop = not . more + +index :: ToText c => Getter a [b] -> Getter b c -> Getter a (Maybe Text) +index f g = f . to lastMay . to (fmap (toText . view g)) + +choice :: Alternative f => (a -> f b) -> (a -> f b) -> a -> f b +choice f g x = f x <|> g x + +lastMay :: [a] -> Maybe a +lastMay [] = Nothing +lastMay (x:xs) = Just (go x xs) + where + go y [] = y + go _ (y:ys) = go y ys diff --git a/src/Network/AWS/Prelude.hs b/src/Network/AWS/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Prelude.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- Module : Network.AWS.Prelude.Types +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Prelude + ( + -- * Re-exported + module Export + + -- * Primitives + , ByteString + , CI + , ClientRequest + , ClientResponse + , Exception + , HashMap + , HttpException + , Natural + , NonEmpty + , RequestBody + , Response + , Text + + -- * Classes + , AWSError (..) + , AWSPager (..) + , AWSRequest (..) + , AWSService (..) + , Generic + , IsString (..) + , Semigroup + , Whole + + -- * Endpoints + , global + , regional + , custom + + -- * Shared + , Empty (..) + , Service (..) + + -- * Errors + , ServiceError (..) + + -- * HTTP + , StdMethod (..) + , Status + ) where + +import Network.AWS.Types + +import Control.Exception (Exception) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.HashMap.Strict (HashMap) +import Data.List.NonEmpty (NonEmpty) +import Data.Semigroup (Semigroup) +import Data.String (IsString(..)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Client (HttpException, RequestBody) +import Network.HTTP.Types.Method (StdMethod(..)) +import Network.HTTP.Types.Status (Status) +import Numeric.Natural (Natural, Whole) + +import Control.Applicative as Export +import Data.Bifunctor as Export +import Data.Coerce as Export +import Data.Default.Class as Export +import Data.Hashable as Export +import Data.Maybe as Export +import Data.Monoid as Export hiding (All, Any, Sum) +import Data.Tagged as Export +import Network.AWS.Data as Export hiding (Query) +import Network.AWS.Pagination as Export +import Network.AWS.Response as Export +import Prelude as Export hiding (head, error) + +import Control.Lens as Export + ( Lens' + , Prism' + , Iso' + , (&) + , (^.) + , (.~) + , (?~) + , (%~) + , (<>~) + , lens + , prism + , iso + , withIso + , to + , mapping + ) diff --git a/src/Network/AWS/Request/Internal.hs b/src/Network/AWS/Request/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/Internal.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.AWS.Request.Internal +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Request.Internal + ( + -- * Requests + defaultRequest + + -- * Lenses + , method + , host + , path + , queryString + , requestBody + , requestHeaders + ) where + +import Control.Lens +import Data.ByteString (ByteString) +import Data.Default.Class +import qualified Data.Text.Encoding as Text +import Network.AWS.Data +import Network.AWS.Types +import qualified Network.HTTP.Client.Internal as HTTP +import qualified Network.HTTP.Types as HTTP + +defaultRequest :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +defaultRequest x = def + & rqPath .~ Text.encodeUtf8 (toPath x) + & rqQuery .~ toQuery x + & rqHeaders .~ toHeaders x +{-# INLINE defaultRequest #-} + +method :: Lens' HTTP.Request HTTP.Method +method f x = f (HTTP.method x) <&> \y -> x { HTTP.method = y } +{-# INLINE method #-} + +host :: Lens' HTTP.Request ByteString +host f x = f (HTTP.host x) <&> \y -> x { HTTP.host = y } +{-# INLINE host #-} + +path :: Lens' HTTP.Request ByteString +path f x = f (HTTP.path x) <&> \y -> x { HTTP.path = y } +{-# INLINE path #-} + +queryString :: Lens' HTTP.Request ByteString +queryString f x = f (HTTP.queryString x) <&> \y -> x { HTTP.queryString = y } +{-# INLINE queryString #-} + +requestBody :: Lens' HTTP.Request HTTP.RequestBody +requestBody f x = f (HTTP.requestBody x) <&> \y -> x { HTTP.requestBody = y } +{-# INLINE requestBody #-} + +requestHeaders :: Lens' HTTP.Request HTTP.RequestHeaders +requestHeaders f x = + f (HTTP.requestHeaders x) <&> \y -> x { HTTP.requestHeaders = y } +{-# INLINE requestHeaders #-} diff --git a/src/Network/AWS/Request/JSON.hs b/src/Network/AWS/Request/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/JSON.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Module : Network.AWS.Request.JSON +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Request.JSON + ( post + ) where + +import Control.Applicative +import Control.Lens hiding (Action) +import Data.Aeson +import Data.Monoid +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Types +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method + +post :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) + => Action + -> a + -> Request a +post a x = defaultRequest x + & rqMethod .~ POST + & rqHeaders <>~ hs + & rqBody .~ toBody (toJSON x) + where + hs = toHeader hAMZTarget target + ++ toHeader hContentType content + + target = (\p -> p <> "." <> toBS a) <$> _svcTargetPrefix svc + content = ("application/x-amz-json-" <>) <$> _svcJSONVersion svc + + svc :: Service (Sv a) + svc = service +{-# INLINE post #-} diff --git a/src/Network/AWS/Request/Query.hs b/src/Network/AWS/Request/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/Query.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Module : Network.AWS.Request.Query +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Request.Query + ( post + ) where + +import Control.Lens hiding (Action) +import Data.Monoid +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Types +import Network.HTTP.Types.Method + +post :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a) + => Action + -> a + -> Request a +post a x = defaultRequest x & rqMethod .~ POST & rqQuery <>~ qry + where + qry = pair "Version" (_svcVersion svc) + . pair "Action" (toBS a) + $ mempty + + svc :: Service (Sv a) + svc = service +{-# INLINE post #-} diff --git a/src/Network/AWS/Request/RestJSON.hs b/src/Network/AWS/Request/RestJSON.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/RestJSON.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Module : Network.AWS.Request.RestJSON +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Request.RestJSON + ( get + , delete + , post + , put + ) where + +import Control.Applicative +import Control.Lens hiding (Action) +import Data.Aeson +import Data.Monoid +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Types +import Network.HTTP.Types.Header +import Network.HTTP.Types.Method + +get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +get = defaultRequest +{-# INLINE get #-} + +delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +delete x = get x & rqMethod .~ DELETE +{-# INLINE delete #-} + +post :: (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) + => a + -> Request a +post x = put x & rqMethod .~ POST +{-# INLINE post #-} + +put :: forall a. (AWSService (Sv a), ToQuery a, ToPath a, ToHeaders a, ToJSON a) + => a + -> Request a +put x = get x + & rqMethod .~ PUT + & rqHeaders <>~ toHeader hContentType content + & rqBody .~ toBody (toJSON x) + where + content = ("application/x-amz-json-" <>) <$> _svcJSONVersion svc + + svc :: Service (Sv a) + svc = service +{-# INLINE put #-} diff --git a/src/Network/AWS/Request/RestXML.hs b/src/Network/AWS/Request/RestXML.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Request/RestXML.hs @@ -0,0 +1,52 @@ +-- Module : Network.AWS.Request.RestXML +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Request.RestXML + ( get + , head + , delete + , post + , put + , stream + ) where + +import Control.Lens +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Types +import Network.HTTP.Types.Method +import Prelude hiding (head) + +get :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +get = defaultRequest +{-# INLINE get #-} + +delete :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +delete x = get x & rqMethod .~ DELETE +{-# INLINE delete #-} + +head :: (ToPath a, ToQuery a, ToHeaders a) => a -> Request a +head x = get x & rqMethod .~ HEAD +{-# INLINE head #-} + +post :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a +post x = put x & rqMethod .~ POST +{-# INLINE post #-} + +put :: (ToPath a, ToQuery a, ToHeaders a, ToXMLRoot a) => a -> Request a +put x = get x & rqMethod .~ PUT & rqBody .~ toBody (encodeXML x) +{-# INLINE put #-} + +stream :: (ToPath a, ToQuery a, ToHeaders a, ToBody a) + => StdMethod + -> a + -> Request a +stream m x = get x & rqMethod .~ m & rqBody .~ toBody x +{-# INLINE stream #-} diff --git a/src/Network/AWS/Response.hs b/src/Network/AWS/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Response.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Response +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Response + ( + -- * Responses + nullResponse + , headerResponse + , xmlResponse + , xmlHeaderResponse + , jsonResponse + , jsonHeaderResponse + , bodyResponse + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Resource +import Data.Aeson +import Data.Bifunctor +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit +import qualified Data.Conduit.Binary as Conduit +import Network.AWS.Data (LazyByteString, FromXML(..), decodeXML) +import Network.AWS.Types +import Network.HTTP.Client hiding (Response) +import Network.HTTP.Types +import Text.XML (Node) + +nullResponse :: (MonadResource m, AWSService (Sv a)) + => Rs a + -> a + -> Either HttpException ClientResponse + -> m (Response a) +nullResponse rs = receive $ \_ _ bdy -> + liftResourceT (bdy $$+- return (Right rs)) +{-# INLINE nullResponse #-} + +headerResponse :: (MonadResource m, AWSService (Sv a)) + => (ResponseHeaders -> Either String (Rs a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +headerResponse f = deserialise (const (Right ())) (const . f) +{-# INLINE headerResponse #-} + +xmlResponse :: (MonadResource m, AWSService (Sv a), FromXML (Rs a)) + => a + -> Either HttpException ClientResponse + -> m (Response a) +xmlResponse = deserialise (decodeXML >=> parseXML) (const Right) +{-# INLINE xmlResponse #-} + +xmlHeaderResponse :: (MonadResource m, AWSService (Sv a)) + => (ResponseHeaders -> [Node] -> Either String (Rs a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +xmlHeaderResponse = deserialise decodeXML +{-# INLINE xmlHeaderResponse #-} + +jsonResponse :: (MonadResource m, AWSService (Sv a), FromJSON (Rs a)) + => a + -> Either HttpException ClientResponse + -> m (Response a) +jsonResponse = deserialise eitherDecode' (const Right) +{-# INLINE jsonResponse #-} + +jsonHeaderResponse :: (MonadResource m, AWSService (Sv a)) + => (ResponseHeaders -> Object -> Either String (Rs a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +jsonHeaderResponse = deserialise eitherDecode' +{-# INLINE jsonHeaderResponse #-} + +bodyResponse :: (MonadResource m, AWSService (Sv a)) + => (ResponseHeaders -> ResponseBody -> Either String (Rs a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +bodyResponse f = receive $ \a hs bdy -> + return (SerializerError a `first` f hs bdy) +{-# INLINE bodyResponse #-} + +deserialise :: (AWSService (Sv a), MonadResource m) + => (LazyByteString -> Either String b) + -> (ResponseHeaders -> b -> Either String (Rs a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +deserialise g f = receive $ \a hs bdy -> do + lbs <- sinkLbs bdy + return $! case g lbs of + Left e -> Left (SerializerError a e) + Right o -> + case f hs o of + Left e -> Left (SerializerError a e) + Right x -> Right x + +receive :: forall m a. (MonadResource m, AWSService (Sv a)) + => (Abbrev -> ResponseHeaders -> ResponseBody -> m (Response a)) + -> a + -> Either HttpException ClientResponse + -> m (Response a) +receive f = const (either (return . Left . HttpError) success) + where + success rs = + maybe (f (_svcAbbrev svc) hs bdy) + (\g -> Left . g <$> sinkLbs bdy) + (handle svc s) + where + svc = service :: Service (Sv a) + + s = responseStatus rs + bdy = responseBody rs + hs = responseHeaders rs + +sinkLbs :: MonadResource m => ResponseBody -> m LBS.ByteString +sinkLbs bdy = liftResourceT (bdy $$+- Conduit.sinkLbs) +{-# INLINE sinkLbs #-} diff --git a/src/Network/AWS/Signing/Internal.hs b/src/Network/AWS/Signing/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Signing/Internal.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Signing.Internal +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Signing.Internal where + +import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Crypto.MAC.HMAC as HMAC +import Data.ByteString (ByteString) +import Data.Time +import Network.AWS.Types +import System.Locale + +sign :: (MonadIO m, AWSRequest a, AWSSigner (Sg (Sv a))) + => Auth -- ^ AWS authentication credentials. + -> Region -- ^ AWS Region. + -> Request a -- ^ Request to sign. + -> UTCTime -- ^ Signing time. + -> m (Signed a (Sg (Sv a))) +sign a r rq t = withAuth a $ \e -> return $ + signed e r rq defaultTimeLocale t + +presign :: (MonadIO m, AWSRequest a, AWSPresigner (Sg (Sv a))) + => Auth -- ^ AWS authentication credentials. + -> Region -- ^ AWS Region. + -> Request a -- ^ Request to presign. + -> UTCTime -- ^ Signing time. + -> Int -- ^ Expiry time in seconds. + -> m (Signed a (Sg (Sv a))) +presign a r rq t x = withAuth a $ \e -> return $ + presigned e r rq defaultTimeLocale t x + +hmacSHA256 :: ByteString -> ByteString -> ByteString +hmacSHA256 = HMAC.hmac SHA256.hash 64 + +serviceOf :: AWSService (Sv a) => Request a -> Service (Sv a) +serviceOf = const service diff --git a/src/Network/AWS/Signing/V2.hs b/src/Network/AWS/Signing/V2.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Signing/V2.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Signing.V2 +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Signing.V2 + ( + -- * Types + V2 + , Meta (..) + + -- * Re-exports + , module Network.AWS.Signing.Internal + ) where + +import Control.Applicative +import Control.Lens +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as BS +import Data.Monoid +import Data.Time +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Signing.Internal +import Network.AWS.Types +import Network.HTTP.Types hiding (toQuery) + +data V2 + +data instance Meta V2 = Meta + { _mSignature :: ByteString + , _mTime :: UTCTime + } + +instance Show (Meta V2) where + show Meta{..} = BS.unpack $ BS.unlines + [ "Version 2 Metadata:" + , "_mSignature " <> _mSignature + , "_mTime " <> toBS _mTime + ] + +instance AWSSigner V2 where + signed AuthEnv{..} r x@Request{..} l t = Signed meta rq + where + meta = Meta + { _mSignature = signature + , _mTime = t + } + + rq = clientRequest + & method .~ meth + & host .~ host' + & path .~ _rqPath + & queryString .~ toBS authorised + & requestHeaders .~ headers + & requestBody .~ _bdyBody _rqBody + + meth = toBS _rqMethod + host' = toBS (endpoint svc r) + + authorised = pair "Signature" (urlEncode True signature) query + + signature = Base64.encode + . hmacSHA256 (toBS _authSecret) + $ BS.intercalate "\n" + [ meth + , host' + , _rqPath + , toBS query + ] + + query = + pair "Version" (_svcVersion svc) + . pair "SignatureVersion" ("2" :: ByteString) + . pair "SignatureMethod" ("HmacSHA256" :: ByteString) + . pair "Timestamp" time + . pair "AWSAccessKeyId" (toBS _authAccess) + $ _rqQuery <> maybe mempty toQuery token + + token = ("SecurityToken" :: ByteString,) . toBS <$> _authToken + + headers = hdr hDate time _rqHeaders + + time = toBS (LocaleTime l t :: ISO8601) + + svc = serviceOf x diff --git a/src/Network/AWS/Signing/V3.hs b/src/Network/AWS/Signing/V3.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Signing/V3.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Signing.V3 +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Signing.V3 + ( + -- * Types + V3 + , Meta (..) + + -- * Re-exports + , module Network.AWS.Signing.Internal + ) where + +import Control.Applicative +import Control.Lens +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as BS +import Data.List (sortBy) +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Time +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Signing.Internal +import Network.AWS.Types +import Network.HTTP.Types.Header + +data V3 + +data instance Meta V3 = Meta + { _mSignature :: ByteString + , _mTime :: UTCTime + } + +instance Show (Meta V3) where + show Meta{..} = BS.unpack $ BS.unlines + [ "Version 3 Metadata:" + , "_mSignature " <> _mSignature + , "_mTime " <> toBS _mTime + ] + +instance AWSSigner V3 where + signed AuthEnv{..} r x@Request{..} l t = Signed meta rq + where + meta = Meta + { _mSignature = signature + , _mTime = t + } + + rq = clientRequest + & method .~ toBS _rqMethod + & host .~ host' + & path .~ _rqPath + & queryString .~ toBS _rqQuery + & requestHeaders .~ headers + & requestBody .~ _bdyBody _rqBody + + host' = toBS (endpoint (serviceOf x) r) + + headers = sortBy (comparing fst) + . hdr hAMZAuth authorisation + . hdr hHost host' + . hdr hDate (toBS (LocaleTime l t :: RFC822)) + $ _rqHeaders + ++ maybeToList ((hAMZToken,) . toBS <$> _authToken) + + authorisation = "AWS3-HTTPS AWSAccessKeyId=" + <> toBS _authAccess + <> ", Algorithm=HmacSHA256, Signature=" + <> signature + + signature = Base64.encode + $ hmacSHA256 (toBS _authSecret) (toBS (LocaleTime l t :: AWSTime)) diff --git a/src/Network/AWS/Signing/V4.hs b/src/Network/AWS/Signing/V4.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Signing/V4.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Signing.V4 +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Signing.V4 + ( + -- * Types + V4 + , Meta (..) + , authorisation + + -- * Re-exports + , module Network.AWS.Signing.Internal + ) where + +import Control.Applicative +import Control.Lens +import Crypto.Hash (digestToHexByteString) +import qualified Crypto.Hash.SHA256 as SHA256 +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import qualified Data.Foldable as Fold +import Data.Function +import Data.List (groupBy, intersperse, sortBy, sort) +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Time +import Network.AWS.Data +import Network.AWS.Request.Internal +import Network.AWS.Signing.Internal +import Network.AWS.Types +import Network.HTTP.Types.Header +import System.Locale + +data V4 + +data instance Meta V4 = Meta + { _mAlgorithm :: ByteString + , _mScope :: ByteString + , _mSigned :: ByteString + , _mCReq :: ByteString + , _mSTS :: ByteString + , _mSignature :: ByteString + , _mTime :: UTCTime + } + +instance Show (Meta V4) where + show Meta{..} = BS.unpack $ BS.unlines + [ "Version 4 Metadata:" + , "_mAlgorithm " <> _mAlgorithm + , "_mScope " <> _mScope + , "_mSigned " <> _mSigned + , "_mCReq " <> _mCReq + , "_mSTS " <> _mSTS + , "_mSignature " <> _mSignature + , "_mTime " <> toBS _mTime + ] + +instance AWSPresigner V4 where + presigned a r rq l t x = out + & sgRequest . queryString <>~ auth (out ^. sgMeta) + where + out = finalise Nothing qry service a r rq l t + + qry cs sh = + pair "X-AMZ-Algorithm" algorithm + . pair "X-AMZ-Credential" cs + . pair "X-AMZ-Date" (LocaleTime l t :: ISO8601) + . pair "X-AMZ-Expires" x + . pair "X-AMZ-SignedHeaders" sh + . pair "X-AMZ-SignedHeaders" sh + . pair "X-AMZ-Security-Token" (toBS <$> _authToken a) + + auth = mappend "&X-AMZ-Signature=" . _mSignature + +instance AWSSigner V4 where + signed a r rq l t = out + & sgRequest + %~ requestHeaders + %~ hdr hAuthorization (authorisation $ out ^. sgMeta) + where + out = finalise (Just "AWS4") (\_ _ -> id) service a r inp l t + + inp = rq & rqHeaders %~ hdrs (maybeToList tok) + + tok = (hAMZToken,) . toBS <$> _authToken a + +authorisation :: Meta V4 -> ByteString +authorisation Meta{..} = BS.concat + [ _mAlgorithm + , " Credential=" + , _mScope + , ", SignedHeaders=" + , _mSigned + , ", Signature=" + , _mSignature + ] + +algorithm :: ByteString +algorithm = "AWS4-HMAC-SHA256" + +finalise :: Maybe ByteString + -> (ByteString -> ByteString -> Query -> Query) + -> Service (Sv a) + -> AuthEnv + -> Region + -> Request a + -> TimeLocale + -> UTCTime + -> Signed a V4 +finalise p qry s@Service{..} AuthEnv{..} r Request{..} l t = Signed meta rq + where + meta = Meta + { _mAlgorithm = algorithm + , _mCReq = canonicalRequest + , _mScope = toBS _authAccess <> "/" <> credentialScope + , _mSigned = signedHeaders + , _mSTS = stringToSign + , _mSignature = signature + , _mTime = t + } + + rq = clientRequest + & method .~ meth + & host .~ host' + & path .~ _rqPath + & queryString .~ toBS query + & requestHeaders .~ headers + & requestBody .~ _bdyBody _rqBody + + meth = toBS _rqMethod + host' = toBS (endpoint s r) + query = qry credentialScope signedHeaders _rqQuery + + canonicalQuery = toBS $ query + & valuesOf %~ Just . maybe "" (encodeURI True) + & keysOf %~ encodeURI False + + headers = sortBy (comparing fst) + . hdr hHost host' + . hdr hDate (toBS (LocaleTime l t :: RFC822)) + $ _rqHeaders + + joinedHeaders = map f $ groupBy ((==) `on` fst) headers + where + f [] = ("", "") + f (h:hs) = (fst h, g $ h : hs) + + g = BS.intercalate "," . sort . map snd + + signedHeaders = mconcat + . intersperse ";" + $ map (CI.foldedCase . fst) joinedHeaders + + canonicalHeaders = Fold.foldMap f joinedHeaders + where + f (k, v) = CI.foldedCase k + <> ":" + <> stripBS v + <> "\n" + + canonicalRequest = mconcat $ intersperse "\n" + [ meth + , collapseURI (encodeURI False _rqPath) + , canonicalQuery + , canonicalHeaders + , signedHeaders + , digestToHexByteString (_bdyHash _rqBody) + ] + + scope = + [ toBS (LocaleTime l t :: BasicTime) + , toBS r + , toBS _svcPrefix + , "aws4_request" + ] + + credentialScope = BS.intercalate "/" scope + + signingKey = Fold.foldl1 hmacSHA256 $ + maybe (toBS _authSecret) (<> toBS _authSecret) p : scope + + stringToSign = BS.intercalate "\n" + [ algorithm + , toBS (LocaleTime l t :: AWSTime) + , credentialScope + , Base16.encode (SHA256.hash canonicalRequest) + ] + + signature = Base16.encode (hmacSHA256 signingKey stringToSign) diff --git a/src/Network/AWS/Types.hs b/src/Network/AWS/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/AWS/Types.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.AWS.Types +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.AWS.Types + ( + -- * Authentication + -- ** Credentials + AccessKey (..) + , SecretKey (..) + , SecurityToken (..) + -- ** Environment + , AuthEnv (..) + , Auth (..) + , withAuth + + -- * Logger + , Logger (..) + , debug + + -- * Services + , Abbrev + , AWSService (..) + , Service (..) + + -- * Endpoints + , Endpoint (..) + , Host (..) + , endpoint + , global + , regional + , custom + + -- * Errors + , ServiceError (..) + , _HttpError + , _SerializerError + , _ServiceError + , _Errors + + , AWSError + , awsError + + -- * Signing + , AWSSigner (..) + , AWSPresigner (..) + , Signed (..) + , Meta + , sgMeta + , sgRequest + + -- * Requests + , AWSRequest (..) + , AWSPager (..) + , Request (..) + , rqMethod + , rqHeaders + , rqPath + , rqQuery + , rqBody + + -- * Responses + , Response + , Empty (..) + + -- * Regions + , Region (..) + , Zone (..) + , zRegion + , zSuffix + + -- * Shared + , Action (..) + + -- * Convenience + , 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 + +-- | Abbreviated service name. +type Abbrev = Text + +-- | An error type representing the subset of errors that can be directly +-- attributed to this library. +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) + +-- | The properties (such as endpoint) for a service, as well as it's +-- associated signing algorithm and error types. +class (AWSSigner (Sg a), Show (Er a)) => AWSService a where + -- | Signing algorithm supported by the service. + type Sg a :: * + + -- | The general service error. + type Er a :: * + + service :: Service a + handle :: Service a + -> Status + -> Maybe (LazyByteString -> ServiceError (Er a)) + +-- | An alias for the common response 'Either' containing a service error in the +-- 'Left' case, or the expected response in the 'Right'. +type Response a = Either (ServiceError (Er (Sv a))) (Rs a) + +-- | Specify how a request can be de/serialised. +class (AWSService (Sv a), AWSSigner (Sg (Sv a))) => AWSRequest a where + -- | The service definition for a request. + type Sv a :: * + + -- | The successful, expected response associated with a request. + type Rs a :: * + + request :: a -> Request a + response :: MonadResource m + => a + -> Either HttpException ClientResponse + -> m (Response a) + +-- | Specify how an 'AWSRequest' and it's associated 'Rs' response can generate +-- a subsequent request, if available. +class AWSRequest a => AWSPager a where + page :: a -> Rs a -> Maybe a + +-- | Signing metadata data specific to a signing algorithm. +-- +-- /Note:/ this is used for test and debug purposes, or is otherwise ignored. +data family Meta v :: * + +-- | A signed 'ClientRequest' and associated metadata specific to the signing +-- algorithm that was used. +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 + +-- | Access key credential. +newtype AccessKey = AccessKey ByteString + deriving (Eq, Show, IsString) + +instance ToByteString AccessKey where + toBS (AccessKey k) = k + +instance ToText AccessKey where + toText = Text.decodeUtf8 . toBS + +-- | Secret key credential. +newtype SecretKey = SecretKey ByteString + deriving (Eq, Show, IsString) + +instance ToByteString SecretKey where + toBS (SecretKey k) = k + +instance ToText SecretKey where + toText = Text.decodeUtf8 . toBS + +-- | A security token used by STS to temporarily authorise access to an AWS resource. +newtype SecurityToken = SecurityToken ByteString + deriving (Eq, Show, IsString) + +instance ToByteString SecurityToken where + toBS (SecurityToken t) = t + +-- | The authorisation environment. +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) + +-- | An authorisation environment containing AWS credentials and potentially +-- a reference which can be refreshed out-of-band as they expire. +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 + +-- | The log level and associated logger function. +data Logger + = None + | Debug (Text -> IO ()) + +-- | Log a message using the debug logger, or if none is specified noop. +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 + +-- | The scope for a service's endpoint. +data Endpoint + = Global + | Regional + | Custom ByteString + +instance IsString Endpoint where + fromString = Custom . fromString + +-- | Determine the full host address for a 'Service within the given 'Region'. +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 + +-- | Attributes specific to an AWS service. +data Service a = Service + { _svcAbbrev :: !Text + , _svcEndpoint :: !Endpoint + , _svcPrefix :: ByteString + , _svcVersion :: ByteString + , _svcTargetPrefix :: Maybe ByteString + , _svcJSONVersion :: Maybe ByteString + } + +-- | An unsigned request. +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 + ] + +-- | The sum of available AWS regions. +data Region + = Ireland -- ^ Europe / eu-west-1 + | Tokyo -- ^ Asia Pacific / ap-northeast-1 + | Singapore -- ^ Asia Pacific / ap-southeast-1 + | Sydney -- ^ Asia Pacific / ap-southeast-2 + | Beijing -- ^ China / cn-north-1 + | NorthVirginia -- ^ US / us-east-1 + | NorthCalifornia -- ^ US / us-west-1 + | Oregon -- ^ US / us-west-2 + | GovCloud -- ^ AWS GovCloud / us-gov-west-1 + | GovCloudFIPS -- ^ AWS GovCloud (FIPS 140-2) S3 Only / fips-us-gov-west-1 + | SaoPaulo -- ^ South America / sa-east-1 + 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 + +-- | An availability zone. +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 + +-- | A service's query action. +newtype Action = Action Text + deriving (Eq, Ord, Show, IsString, ToText, ToByteString) + +data Empty = Empty + deriving (Eq, Show) + +instance ToJSON Empty where + toJSON = const Null + +-- | A convenience alias to avoid type ambiguity. +type ClientRequest = Client.Request + +-- | A convenience alias encapsulating the common 'Response'. +type ClientResponse = Client.Response ResponseBody + +-- | A convenience alias encapsulating the common 'Response' body. +type ResponseBody = ResumableSource (ResourceT IO) ByteString + +-- | Construct a 'ClientRequest' using common parameters such as TLS and prevent +-- throwing errors when receiving erroneous status codes in respones. +clientRequest :: ClientRequest +clientRequest = def + { Client.secure = True + , Client.port = 443 + , Client.checkStatus = \_ _ _ -> Nothing + } + +makePrisms ''ServiceError +makeLenses ''Request +makeLenses ''Zone