aws-0.19: Aws/Aws.hs

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE BangPatterns          #-}

module Aws.Aws
( -- * Logging
  LogLevel(..)
, Logger
, defaultLog
  -- * Configuration
, Configuration(..)
, baseConfiguration
, dbgConfiguration
  -- * Transaction runners
  -- ** Safe runners
, aws
, awsRef
, pureAws
, memoryAws
, simpleAws
  -- ** Unsafe runners
, unsafeAws
, unsafeAwsRef
  -- ** URI runners
, awsUri
  -- * Iterated runners
--, awsIteratedAll
, awsIteratedSource
, awsIteratedSource'
, awsIteratedList
, awsIteratedList'
)
where

import           Aws.Core
import           Control.Applicative
import qualified Control.Exception.Lifted     as E
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans
import           Control.Monad.Trans.Resource
import qualified Data.ByteString              as B
import qualified Data.ByteString.Lazy         as L
import qualified Data.CaseInsensitive         as CI
import qualified Data.Conduit                 as C
import qualified Data.Conduit.List            as CL
import           Data.IORef
import           Data.Monoid
import qualified Data.Text                    as T
import qualified Data.Text.Encoding           as T
import qualified Data.Text.IO                 as T
import qualified Network.HTTP.Conduit         as HTTP
import           System.IO                    (stderr)
import           Prelude

-- | The severity of a log message, in rising order.
data LogLevel
    = Debug
    | Info
    | Warning
    | Error
    deriving (Show, Eq, Ord)

-- | The interface for any logging function. Takes log level and a log message, and can perform an arbitrary
-- IO action.
type Logger = LogLevel -> T.Text -> IO ()

-- | The default logger @defaultLog minLevel@, which prints log messages above level @minLevel@ to @stderr@.
defaultLog :: LogLevel -> Logger
defaultLog minLevel lev t | lev >= minLevel = T.hPutStrLn stderr $ T.concat [T.pack $ show lev, ": ", t]
                          | otherwise       = return ()

-- | The configuration for an AWS request. You can use multiple configurations in parallel, even over the same HTTP
-- connection manager.
data Configuration
    = Configuration {
        -- | Whether to restrict the signature validity with a plain timestamp, or with explicit expiration
        -- (absolute or relative).
        timeInfo    :: TimeInfo
        -- | AWS access credentials.
      , credentials :: Credentials
        -- | The error / message logger.
      , logger      :: Logger
      , proxy       :: Maybe HTTP.Proxy
      }

-- | The default configuration, with credentials loaded from environment variable or configuration file
-- (see 'loadCredentialsDefault').
baseConfiguration :: MonadIO io => io Configuration
baseConfiguration = liftIO $ do
  cr <- loadCredentialsDefault
  case cr of
    Nothing -> E.throw $ NoCredentialsException "could not locate aws credentials"
    Just cr' -> return Configuration {
                      timeInfo = Timestamp
                    , credentials = cr'
                    , logger = defaultLog Warning
                    , proxy = Nothing
                    }

-- | Debug configuration, which logs much more verbosely.
dbgConfiguration :: MonadIO io => io Configuration
dbgConfiguration = do
  c <- baseConfiguration
  return c { logger = defaultLog Debug }

-- | Run an AWS transaction, with HTTP manager and metadata wrapped in a 'Response'.
--
-- All errors are caught and wrapped in the 'Response' value.
--
-- Metadata is logged at level 'Info'.
--
-- Usage (with existing 'HTTP.Manager'):
-- @
--     resp <- aws cfg serviceCfg manager request
-- @
aws :: (Transaction r a)
      => Configuration
      -> ServiceConfiguration r NormalQuery
      -> HTTP.Manager
      -> r
      -> ResourceT IO (Response (ResponseMetadata a) a)
aws = unsafeAws

-- | Run an AWS transaction, with HTTP manager and metadata returned in an 'IORef'.
--
-- Errors are not caught, and need to be handled with exception handlers.
--
-- Metadata is not logged.
--
-- Usage (with existing 'HTTP.Manager'):
-- @
--     ref <- newIORef mempty;
--     resp <- awsRef cfg serviceCfg manager request
-- @

-- Unfortunately, the ";" above seems necessary, as haddock does not want to split lines for me.
awsRef :: (Transaction r a)
      => Configuration
      -> ServiceConfiguration r NormalQuery
      -> HTTP.Manager
      -> IORef (ResponseMetadata a)
      -> r
      -> ResourceT IO a
awsRef = unsafeAwsRef

-- | Run an AWS transaction, with HTTP manager and without metadata.
--
-- Metadata is logged at level 'Info'.
--
-- Usage (with existing 'HTTP.Manager'):
-- @
--     resp <- aws cfg serviceCfg manager request
-- @
pureAws :: (Transaction r a)
      => Configuration
      -> ServiceConfiguration r NormalQuery
      -> HTTP.Manager
      -> r
      -> ResourceT IO a
pureAws cfg scfg mgr req = readResponseIO =<< aws cfg scfg mgr req

-- | Run an AWS transaction, with HTTP manager and without metadata.
--
-- Metadata is logged at level 'Info'.
--
-- Usage (with existing 'HTTP.Manager'):
-- @
--     resp <- aws cfg serviceCfg manager request
-- @
memoryAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)
      => Configuration
      -> ServiceConfiguration r NormalQuery
      -> HTTP.Manager
      -> r
      -> io (MemoryResponse a)
memoryAws cfg scfg mgr req = liftIO $ runResourceT $ loadToMemory =<< readResponseIO =<< aws cfg scfg mgr req

-- | Run an AWS transaction, /without/ HTTP manager and without metadata.
--
-- Metadata is logged at level 'Info'.
--
-- Note that this is potentially less efficient than using 'aws', because HTTP connections cannot be re-used.
--
-- Usage:
-- @
--     resp <- simpleAws cfg serviceCfg request
-- @
simpleAws :: (Transaction r a, AsMemoryResponse a, MonadIO io)
            => Configuration
            -> ServiceConfiguration r NormalQuery
            -> r
            -> io (MemoryResponse a)
simpleAws cfg scfg request = liftIO $ runResourceT $ do
    manager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings
    loadToMemory =<< readResponseIO =<< aws cfg scfg manager request

-- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.
--
-- This is especially useful for debugging and development, you should not have to use it in production.
--
-- All errors are caught and wrapped in the 'Response' value.
--
-- Metadata is wrapped in the Response, and also logged at level 'Info'.
unsafeAws
  :: (ResponseConsumer r a,
      Loggable (ResponseMetadata a),
      SignQuery r) =>
     Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> r -> ResourceT IO (Response (ResponseMetadata a) a)
unsafeAws cfg scfg manager request = do
  metadataRef <- liftIO $ newIORef mempty

  let catchAll :: ResourceT IO a -> ResourceT IO (Either E.SomeException a)
      catchAll = E.handle (return . Left) . fmap Right

  resp <- catchAll $
            unsafeAwsRef cfg scfg manager metadataRef request
  metadata <- liftIO $ readIORef metadataRef
  liftIO $ logger cfg Info $ "Response metadata: " `mappend` toLogText metadata
  return $ Response metadata resp

-- | Run an AWS transaction, without enforcing that response and request type form a valid transaction pair.
--
-- This is especially useful for debugging and development, you should not have to use it in production.
--
-- Errors are not caught, and need to be handled with exception handlers.
--
-- Metadata is put in the 'IORef', but not logged.
unsafeAwsRef
  :: (ResponseConsumer r a,
      SignQuery r) =>
     Configuration -> ServiceConfiguration r NormalQuery -> HTTP.Manager -> IORef (ResponseMetadata a) -> r -> ResourceT IO a
unsafeAwsRef cfg info manager metadataRef request = do
  sd <- liftIO $ signatureData <$> timeInfo <*> credentials $ cfg
  let !q = {-# SCC "unsafeAwsRef:signQuery" #-} signQuery request info sd
  let logDebug = liftIO . logger cfg Debug . T.pack
  logDebug $ "String to sign: " ++ show (sqStringToSign q)
  !httpRequest <- {-# SCC "unsafeAwsRef:httpRequest" #-} liftIO $ do
    req <- queryToHttpRequest q
    return $ req { HTTP.proxy = proxy cfg }
  logDebug $ "Host: " ++ show (HTTP.host httpRequest)
  logDebug $ "Path: " ++ show (HTTP.path httpRequest)
  logDebug $ "Query string: " ++ show (HTTP.queryString httpRequest)
  logDebug $ "Header: " ++ show (HTTP.requestHeaders httpRequest)
  case HTTP.requestBody httpRequest of
    HTTP.RequestBodyLBS lbs -> logDebug $ "Body: " ++ show (L.take 1000 lbs)
    HTTP.RequestBodyBS bs -> logDebug $ "Body: " ++ show (B.take 1000 bs)
    _ -> return ()
  hresp <- {-# SCC "unsafeAwsRef:http" #-} HTTP.http httpRequest manager
  logDebug $ "Response status: " ++ show (HTTP.responseStatus hresp)
  forM_ (HTTP.responseHeaders hresp) $ \(hname,hvalue) -> liftIO $
    logger cfg Debug $ T.decodeUtf8 $ "Response header '" `mappend` CI.original hname `mappend` "': '" `mappend` hvalue `mappend` "'"
  {-# SCC "unsafeAwsRef:responseConsumer" #-} responseConsumer httpRequest request metadataRef hresp

-- | Run a URI-only AWS transaction. Returns a URI that can be sent anywhere. Does not work with all requests.
--
-- Usage:
-- @
--     uri <- awsUri cfg request
-- @
awsUri :: (SignQuery request, MonadIO io)
         => Configuration -> ServiceConfiguration request UriOnlyQuery -> request -> io B.ByteString
awsUri cfg info request = liftIO $ do
  let ti = timeInfo cfg
      cr = credentials cfg
  sd <- signatureData ti cr
  let q = signQuery request info sd
  logger cfg Debug $ T.pack $ "String to sign: " ++ show (sqStringToSign q)
  return $ queryToUri q

{-
-- | Run an iterated AWS transaction. May make multiple HTTP requests.
awsIteratedAll :: (IteratedTransaction r a)
                  => Configuration
                  -> ServiceConfiguration r NormalQuery
                  -> HTTP.Manager
                  -> r
                  -> ResourceT IO (Response [ResponseMetadata a] a)
awsIteratedAll cfg scfg manager req_ = go req_ Nothing
  where go request prevResp = do Response meta respAttempt <- aws cfg scfg manager request
                                 case maybeCombineIteratedResponse prevResp <$> respAttempt of
                                   f@(Failure _) -> return (Response [meta] f)
                                   s@(Success resp) ->
                                     case nextIteratedRequest request resp of
                                       Nothing ->
                                         return (Response [meta] s)
                                       Just nextRequest ->
                                         mapMetadata (meta:) `liftM` go nextRequest (Just resp)
-}

awsIteratedSource
    :: (IteratedTransaction r a)
    => Configuration
    -> ServiceConfiguration r NormalQuery
    -> HTTP.Manager
    -> r
    -> C.Producer (ResourceT IO) (Response (ResponseMetadata a) a)
awsIteratedSource cfg scfg manager req_ = awsIteratedSource' run req_
  where
    run r = do
        res <- aws cfg scfg manager r
        a <- readResponseIO res
        return (a, res)


awsIteratedList
    :: (IteratedTransaction r a, ListResponse a i)
    => Configuration
    -> ServiceConfiguration r NormalQuery
    -> HTTP.Manager
    -> r
    -> C.Producer (ResourceT IO) i
awsIteratedList cfg scfg manager req = awsIteratedList' run req
  where
    run r = readResponseIO =<< aws cfg scfg manager r


-------------------------------------------------------------------------------
-- | A more flexible version of 'awsIteratedSource' that uses a
-- user-supplied run function. Useful for embedding AWS functionality
-- within application specific monadic contexts.
awsIteratedSource'
    :: (Monad m, IteratedTransaction r a)
    => (r -> m (a, b))
    -- ^ A runner function for executing transactions.
    -> r
    -- ^ An initial request
    -> C.Producer m b
awsIteratedSource' run r0 = go r0
    where
      go q = do
          (a, b) <- lift $ run q
          C.yield b
          case nextIteratedRequest q a of
            Nothing -> return ()
            Just q' -> go q'


-------------------------------------------------------------------------------
-- | A more flexible version of 'awsIteratedList' that uses a
-- user-supplied run function. Useful for embedding AWS functionality
-- within application specific monadic contexts.
awsIteratedList'
    :: (Monad m, IteratedTransaction r b, ListResponse b c)
    => (r -> m b)
    -- ^ A runner function for executing transactions.
    -> r
    -- ^ An initial request
    -> C.Producer m c
awsIteratedList' run r0 =
    awsIteratedSource' run' r0 C.=$=
    CL.concatMap listResponse
  where
    dupl a = (a,a)
    run' r = dupl `liftM` run r