diff --git a/Aws.hs b/Aws.hs --- a/Aws.hs +++ b/Aws.hs @@ -53,7 +53,9 @@ , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv +, loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile +, loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault ) where diff --git a/Aws/Aws.hs b/Aws/Aws.hs --- a/Aws/Aws.hs +++ b/Aws/Aws.hs @@ -79,13 +79,14 @@ -- (see 'loadCredentialsDefault'). baseConfiguration :: MonadIO io => io Configuration baseConfiguration = liftIO $ do - Just cr <- loadCredentialsDefault - return Configuration { + cr <- loadCredentialsDefault + case cr of + Nothing -> E.throw $ NoCredentialsException "could not locate aws credentials" + Just cr' -> return Configuration { timeInfo = Timestamp - , credentials = cr + , credentials = cr' , logger = defaultLog Warning } --- TODO: better error handling when credentials cannot be loaded -- | Debug configuration, which logs much more verbosely. dbgConfiguration :: MonadIO io => io Configuration diff --git a/Aws/Core.hs b/Aws/Core.hs --- a/Aws/Core.hs +++ b/Aws/Core.hs @@ -21,6 +21,7 @@ , XmlException(..) , HeaderException(..) , FormException(..) +, NoCredentialsException(..) -- ** Response deconstruction helpers , readHex2 -- *** XML @@ -73,7 +74,9 @@ , credentialsDefaultKey , loadCredentialsFromFile , loadCredentialsFromEnv +, loadCredentialsFromInstanceMetadata , loadCredentialsFromEnvOrFile +, loadCredentialsFromEnvOrFileOrInstanceMetadata , loadCredentialsDefault -- * Service configuration , DefaultServiceConfiguration(..) @@ -85,6 +88,8 @@ ) where +import Aws.Ec2.InstanceMetadata +import Aws.Network import qualified Blaze.ByteString.Builder as Blaze import Control.Applicative import Control.Arrow @@ -93,6 +98,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Resource (ResourceT, MonadThrow (throwM)) import Crypto.Hash +import qualified Data.Aeson as A import Data.Byteable import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -108,6 +114,7 @@ import Data.Default (def) import Data.IORef import Data.List +import qualified Data.Map as M import Data.Maybe import Data.Monoid import qualified Data.Text as T @@ -232,9 +239,11 @@ , secretAccessKey :: B.ByteString -- | Signing keys for signature version 4 , v4SigningKeys :: IORef [V4Key] + -- | Signed IAM token + , iamToken :: Maybe B.ByteString } instance Show Credentials where - show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ "}" + show c = "Credentials{accessKeyID=" ++ show (accessKeyID c) ++ ",secretAccessKey=" ++ show (secretAccessKey c) ++ ",iamToken=" ++ show (iamToken c) ++ "}" -- | The file where access credentials are loaded, when using 'loadCredentialsDefault'. -- @@ -262,6 +271,7 @@ return Credentials { accessKeyID = T.encodeUtf8 keyID , secretAccessKey = T.encodeUtf8 secret , v4SigningKeys = ref + , iamToken = Nothing } where hasKey _ [] = False @@ -278,8 +288,37 @@ secret = lk "AWS_ACCESS_KEY_SECRET" `mplus` lk "AWS_SECRET_ACCESS_KEY" return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) <*> (T.encodeUtf8 . T.pack <$> secret) - <*> return ref) + <*> return ref + <*> return Nothing) +loadCredentialsFromInstanceMetadata :: MonadIO io => io (Maybe Credentials) +loadCredentialsFromInstanceMetadata = liftIO $ HTTP.withManager $ \mgr -> + do + -- check if the path is routable + avail <- liftIO $ hostAvailable "169.254.169.254" + if not avail + then return Nothing + else do + info <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam" "info" >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) + let infodict = info >>= A.decode :: Maybe (M.Map String String) + info' = infodict >>= M.lookup "InstanceProfileArn" + case info' of + Just name -> + do + let name' = drop 1 $ dropWhile (/= '/') $ name + creds <- liftIO $ E.catch (getInstanceMetadata mgr "latest/meta-data/iam/security-credentials" name' >>= return . Just) (\(_ :: HTTP.HttpException) -> return Nothing) + -- this token lasts ~6 hours + let dict = creds >>= A.decode :: Maybe (M.Map String String) + keyID = dict >>= M.lookup "AccessKeyId" + secret = dict >>= M.lookup "SecretAccessKey" + token = dict >>= M.lookup "Token" + ref <- liftIO $ newIORef [] + return (Credentials <$> (T.encodeUtf8 . T.pack <$> keyID) + <*> (T.encodeUtf8 . T.pack <$> secret) + <*> return ref + <*> (Just . T.encodeUtf8 . T.pack <$> token)) + Nothing -> return Nothing + -- | Load credentials from environment variables if possible, or alternatively from a file with a given key name. -- -- See 'loadCredentialsFromEnv' and 'loadCredentialsFromFile' for details. @@ -291,6 +330,22 @@ Just cr -> return (Just cr) Nothing -> loadCredentialsFromFile file key +-- | Load credentials from environment variables if possible, or alternatively from the instance metadata store, or alternatively from a file with a given key name. +-- +-- See 'loadCredentialsFromEnv', 'loadCredentialsFromFile' and 'loadCredentialsFromInstanceMetadata' for details. +loadCredentialsFromEnvOrFileOrInstanceMetadata :: MonadIO io => FilePath -> T.Text -> io (Maybe Credentials) +loadCredentialsFromEnvOrFileOrInstanceMetadata file key = + do + envcr <- loadCredentialsFromEnv + case envcr of + Just cr -> return (Just cr) + Nothing -> + do + instcr <- loadCredentialsFromInstanceMetadata + case instcr of + Just cr -> return (Just cr) + Nothing -> loadCredentialsFromFile file key + -- | Load credentials from environment variables if possible, or alternative from the default file with the default -- key name. -- @@ -301,7 +356,7 @@ loadCredentialsDefault :: MonadIO io => io (Maybe Credentials) loadCredentialsDefault = do file <- credentialsDefaultFile - loadCredentialsFromEnvOrFile file credentialsDefaultKey + loadCredentialsFromEnvOrFileOrInstanceMetadata file credentialsDefaultKey -- | Protocols supported by AWS. Currently, all AWS services use the HTTP or HTTPS protocols. data Protocol @@ -682,10 +737,16 @@ instance E.Exception HeaderException -- | An error that occurred during form parsing / validation. -newtype FormException = FormException { formErrorMesage :: String } +newtype FormException = FormException { formErrorMesage :: String } deriving (Show, Typeable) instance E.Exception FormException + +-- | No credentials were found and an invariant was violated. +newtype NoCredentialsException = NoCredentialsException { noCredentialsErrorMesage :: String } + deriving (Show, Typeable) + +instance E.Exception NoCredentialsException -- | A specific element (case-insensitive, ignoring namespace - sadly necessary), extracting only the textual contents. diff --git a/Aws/Network.hs b/Aws/Network.hs new file mode 100644 --- /dev/null +++ b/Aws/Network.hs @@ -0,0 +1,20 @@ +module Aws.Network where + +import Data.Maybe +import Control.Exception +import Network.BSD (getProtocolNumber) +import Network.Socket +import System.Timeout + +-- Make a good guess if a host is reachable. +hostAvailable :: String -> IO Bool +hostAvailable h = do + sock <- getProtocolNumber "tcp" >>= socket AF_INET Stream + addr <- (addrAddress . head) `fmap` getAddrInfo (Just (defaultHints { addrFlags = [ AI_PASSIVE ] } )) (Just h) (Just "80") + case addr of + remote@(SockAddrInet _ _) -> do + v <- catch (timeout 100000 (connect sock remote) >>= return . isJust) + (\(_ :: SomeException) -> return False) + sClose sock + return v + _ -> return False diff --git a/Aws/S3/Core.hs b/Aws/S3/Core.hs --- a/Aws/S3/Core.hs +++ b/Aws/S3/Core.hs @@ -177,7 +177,7 @@ , sqStringToSign = stringToSign } where - amzHeaders = merge $ sortBy (compare `on` fst) s3QAmzHeaders + amzHeaders = merge $ sortBy (compare `on` fst) (s3QAmzHeaders ++ (fmap (\(k, v) -> (CI.mk k, v)) iamTok)) where merge (x1@(k1,v1):x2@(k2,v2):xs) | k1 == k2 = merge ((k1, B8.intercalate "," [v1, v2]) : xs) | otherwise = x1 : merge (x2 : xs) merge xs = xs @@ -196,6 +196,7 @@ (True, AbsoluteTimestamp time) -> AbsoluteExpires $ s3DefaultExpiry `addUTCTime` time (True, AbsoluteExpires time) -> AbsoluteExpires time sig = signature signatureCredentials HmacSHA1 stringToSign + iamTok = maybe [] (\x -> [("x-amz-security-token", x)]) (iamToken signatureCredentials) stringToSign = Blaze.toByteString . mconcat . intersperse (Blaze8.fromChar '\n') . concat $ [[Blaze.copyByteString $ httpMethod s3QMethod] , [maybe mempty (Blaze.copyByteString . Base64.encode . toBytes) s3QContentMd5] @@ -214,7 +215,7 @@ = [("Expires" :: B8.ByteString, fmtTimeEpochSeconds time) , ("AWSAccessKeyId", accessKeyID signatureCredentials) , ("SignatureMethod", "HmacSHA256") - , ("Signature", sig)] + , ("Signature", sig)] ++ iamTok s3ResponseConsumer :: HTTPResponseConsumer a -> IORef S3Metadata @@ -356,7 +357,7 @@ , objectETag :: T.Text , objectSize :: Integer , objectStorageClass :: StorageClass - , objectOwner :: UserInfo + , objectOwner :: Maybe UserInfo } deriving (Show) @@ -371,7 +372,9 @@ eTag <- force "Missing object ETag" $ el $/ elContent "ETag" size <- forceM "Missing object Size" $ el $/ elContent "Size" &| textReadInt storageClass <- forceM "Missing object StorageClass" $ el $/ elContent "StorageClass" &| parseStorageClass - owner <- forceM "Missing object Owner" $ el $/ Cu.laxElement "Owner" &| parseUserInfo + owner <- case el $/ Cu.laxElement "Owner" &| parseUserInfo of + (x:_) -> fmap' Just x + [] -> return Nothing return ObjectInfo{ objectKey = key , objectLastModified = lastModified @@ -380,6 +383,9 @@ , objectStorageClass = storageClass , objectOwner = owner } + where + fmap' :: Monad m => (a -> b) -> m a -> m b + fmap' f ma = ma >>= return . f data ObjectMetadata = ObjectMetadata { diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -90,6 +90,10 @@ ** 0.9 series +- 0.9.2 + - Support for credentials from EC2 instance metadata (only S3 for now) + - aeson 0.8 compatibility + - 0.9.1 - Support for multi-page S3 GetBucket requests - S3 GLACIER support diff --git a/aws.cabal b/aws.cabal --- a/aws.cabal +++ b/aws.cabal @@ -1,5 +1,5 @@ Name: aws -Version: 0.9.1 +Version: 0.9.2 Synopsis: Amazon Web Services (AWS) for Haskell Description: Bindings for Amazon Web Services (AWS), with the aim of supporting all AWS services. To see a high level overview of the library, see the README at . Homepage: http://github.com/aristidb/aws @@ -20,7 +20,7 @@ Source-repository this type: git location: https://github.com/aristidb/aws.git - tag: 0.9.1 + tag: 0.9.2 Source-repository head type: git @@ -95,10 +95,11 @@ Aws.Ses.Core, Aws.DynamoDb.Commands, Aws.DynamoDb.Commands.Table, - Aws.DynamoDb.Core + Aws.DynamoDb.Core, + Aws.Network Build-depends: - aeson >= 0.6 && < 0.8, + aeson >= 0.6, base == 4.*, base16-bytestring == 0.1.*, base64-bytestring == 1.0.*, @@ -119,6 +120,7 @@ lifted-base >= 0.1 && < 0.3, monad-control >= 0.3, mtl == 2.*, + network == 2.*, old-locale == 1.*, resourcet >= 1.1 && < 1.2, text >= 0.11,