AWS via Haskell Part 5 (Lambda)

add_handler.py

def add_handler(event, context):
    x = int(event["x"])
    y = int(event["y"])
    return { "result" : x + y }

aws-via-haskell.cabal

executable lambda-app
  default-language:                         Haskell2010
  if os(darwin)
    cpp-options:                            -DOS_MACOS
  if os(linux)
    cpp-options:                            -DOS_LINUX
  if os(windows)
    cpp-options:                            -DOS_WINDOWS
  hs-source-dirs:                           lambda
  main-is:                                  Main.hs
  ghc-options:                              -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports
  build-depends:                            aeson
                                          , amazonka
                                          , amazonka-iam
                                          , amazonka-lambda
                                          , amazonka-sts
                                          , aws-via-haskell
                                          , base >= 4.7 && < 5
                                          , bytestring
                                          , directory
                                          , filepath
                                          , lens
                                          , text
                                          , text-format
                                          , time
                                          , unordered-containers
                                          , zip-archive

AWSService.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module AWSViaHaskell.AWSService
    ( AWSConfig
    , Endpoint(..)
    , Logging(..)
    , ServiceClass(..)
    , Session
    , SessionClass(..)
    , awscCredentials
    , awscEndpoint
    , awscLogging
    , awsConfig
    , connect
    , withAWS
    ) where

import           AWSViaHaskell.Classes
import           AWSViaHaskell.Types
import           Control.Lens ((<&>), makeLenses, set)
import           Control.Monad.Trans.AWS
                    ( AWST'
                    , reconfigure
                    , runAWST
                    , within
                    )
import           Control.Monad.Trans.Resource
                    ( MonadBaseControl
                    , ResourceT
                    )
import           Data.ByteString (ByteString)
import           Network.AWS
                    ( Credentials(..)
                    , Env
                    , LogLevel(..)
                    , Region(..)
                    , Service
                    , envLogger
                    , newEnv
                    , newLogger
                    , runResourceT
                    , setEndpoint
                    )
import           System.IO (stdout)

type HostName = ByteString

type Port = Int

data Logging = LoggingEnabled | LoggingDisabled

data Endpoint = AWSRegion Region | Local HostName Port

data AWSConfig = AWSConfig
    { _awscEndpoint :: Endpoint
    , _awscLogging :: Logging
    , _awscCredentials :: Credentials
    }
makeLenses ''AWSConfig

awsConfig :: Endpoint -> AWSConfig
awsConfig endpoint = AWSConfig endpoint LoggingDisabled Discover

connect :: forall a . ServiceClass a => AWSConfig -> a -> IO (TypedSession a)
connect (AWSConfig endpoint logging credentials) service = do
    let serviceRaw = rawService service
    e <- mkEnv logging credentials
    let (r, s) = regionService endpoint serviceRaw
    session' <- return $ Session e r s
    let session = wrappedSession @a session'
    return session

mkEnv :: Logging -> Credentials -> IO Env
-- Standard discovery mechanism for credentials, log to standard output
mkEnv LoggingEnabled c = do
    logger <- newLogger Debug stdout
    newEnv c <&> set envLogger logger
-- Standard discovery mechanism for credentials, no logging
mkEnv LoggingDisabled c = newEnv c

regionService :: Endpoint -> Service -> (Region, Service)
-- Run against a DynamoDB instance running on AWS in specified region
regionService (AWSRegion region) s = (region, s)
-- Run against a local DynamoDB instance on a given host and port
regionService (Local hostName port) s = (NorthVirginia, setEndpoint False hostName port s)

withAWS :: (MonadBaseControl IO m, SessionClass b) =>
    AWST' Env (ResourceT m) a
    -> b
    -> m a
withAWS action session =
    let Session{..} = rawSession session
    in
        runResourceT . runAWST _sEnv . within _sRegion $ do
            reconfigure _sService action

Classes.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}

module AWSViaHaskell.Classes
    ( ServiceClass(..)
    , SessionClass(..)
    ) where

import           AWSViaHaskell.Types
import           Network.AWS (Service)

class ServiceClass a where
    type TypedSession a :: *
    rawService :: a -> Service
    wrappedSession :: Session -> TypedSession a

class SessionClass a where
    rawSession :: a -> Session

Connect.hs

connect :: forall a . ServiceClass a => AWSConfig -> a -> IO (TypedSession a)

DDBService.hs

-- Our service type: simply wraps Service
data DDBService = DDBService Service

-- Our session type: simply wraps Session
data DDBSession = DDBSession Session

-- ServiceClass instance used to extract the raw Service and to wrap Session
instance ServiceClass DDBService where
    type TypedSession DDBService = DDBSession
    rawService (DDBService x) = x
    wrappedSession = DDBSession

-- SessionClass used to extract the raw Session
instance SessionClass DDBSession where
    rawSession (DDBSession x) = x

-- Type-safe wrapper around the dynamoDB Service instance
dynamoDBService :: DDBService
dynamoDBService = DDBService dynamoDB

DoGetAccountID.hs

doGetAccountID :: STSSession -> IO (Maybe AccountID)
doGetAccountID = withAWS $ do
    result <- send getCallerIdentity
    return $ AccountID <$> result ^. gcirsAccount

LICENSE

The MIT License (MIT)

Copyright (c) 2017 Richard Cook

Permission is hereby granted, free of charge, to any person obtaining a copy of
this software and associated documentation files (the "Software"), to deal in
the Software without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Software, and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Main (main) where

import           AWSViaHaskell
                    ( Endpoint(..)
                    , awscCredentials
                    , awsConfig
                    , connect
                    , withAWS
                    , wrapAWSService
                    )
import           Codec.Archive.Zip
                    ( addEntryToArchive
                    , emptyArchive
                    , fromArchive
                    , toEntry
                    )
import           Control.Concurrent (threadDelay)
import           Control.Exception.Lens (handling)
import           Control.Lens ((^.), (.~), (&))
import           Control.Monad (forM_, void)
import           Data.Aeson (Value(..))
import           Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as ByteString (toStrict)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap (fromList)
import           Data.Maybe (catMaybes)
import           Data.Monoid ((<>))
import           Data.Text (Text)
import           Data.Text.Format (format)
import qualified Data.Text.Lazy as Text (toStrict)
import qualified Data.Text.IO as Text (putStrLn)
import           Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import           Network.AWS
                    ( Credentials(..)
                    , Region(..)
                    , send
                    )
import           Network.AWS.IAM
                    ( _EntityAlreadyExistsException
                    , _NoSuchEntityException
                    , apPolicyARN
                    , attachRolePolicy
                    , createRole
                    , crrsRole
                    , deleteRole
                    , detachRolePolicy
                    , iam
                    , larprsAttachedPolicies
                    , listAttachedRolePolicies
                    , rARN
                    )
import           Network.AWS.Lambda
                    ( _ResourceConflictException
                    , _ResourceNotFoundException
                    , FunctionCode
                    , Runtime(..)
                    , createFunction
                    , deleteFunction
                    , fcFunctionName
                    , fcZipFile
                    , functionCode
                    , invoke
                    , irsPayload
                    , lambda
                    , listFunctions
                    , lfrsFunctions
                    )
import           Network.AWS.STS
                    ( gcirsAccount
                    , getCallerIdentity
                    , sts
                    )
import           System.Directory (getHomeDirectory)
import           System.FilePath ((</>))

wrapAWSService 'iam "IAMService" "IAMSession"
wrapAWSService 'lambda "LambdaService" "LambdaSession"
wrapAWSService 'sts "STSService" "STSSession"

newtype AccountID = AccountID Text deriving Show
newtype ARN = ARN Text deriving (Eq, Show)
newtype FunctionName = FunctionName Text deriving Show
newtype PolicyDocument = PolicyDocument Text deriving Show
newtype RoleName = RoleName Text deriving Show
newtype Handler = Handler Text deriving Show
type Payload = HashMap Text Value

awsLambdaBasicExecutionRolePolicy :: ARN
awsLambdaBasicExecutionRolePolicy = ARN "arn:aws:iam::aws:policy/service-role/AWSLambdaBasicExecutionRole"

doGetAccountID :: STSSession -> IO (Maybe AccountID)
doGetAccountID = withAWS $ do
    result <- send getCallerIdentity
    return $ AccountID <$> result ^. gcirsAccount

doDeleteFunctionIfExists :: FunctionName -> LambdaSession -> IO ()
doDeleteFunctionIfExists (FunctionName fn) = withAWS $ do
    handling (_ResourceNotFoundException) (const (pure ())) $ do
        void $ send $ deleteFunction fn

doDetachRolePolicyIfExists :: RoleName -> ARN -> IAMSession -> IO ()
doDetachRolePolicyIfExists (RoleName rn) (ARN arn) = withAWS $ do
    handling _NoSuchEntityException (const $ pure ()) $ do
        void $ send $ detachRolePolicy rn arn

doDeleteRoleIfExists :: RoleName -> IAMSession -> IO ()
doDeleteRoleIfExists (RoleName rn) = withAWS $ do
    handling _NoSuchEntityException (const $ pure ()) $ do
        void $ send $ deleteRole rn

doCreateRoleIfNotExists :: AccountID -> RoleName -> PolicyDocument -> IAMSession -> IO ARN
doCreateRoleIfNotExists (AccountID aid) (RoleName rn) (PolicyDocument pd) = withAWS $ do
    handling _EntityAlreadyExistsException (const $ pure (arn aid rn)) $ do
        result <- send $ createRole rn pd
        return $ ARN (result ^. crrsRole . rARN)
    where
        arn aid' rn' = ARN (Text.toStrict (format "arn:aws:iam::{}:role/{}" $ (aid', rn')))

doAttachRolePolicy :: RoleName -> ARN -> IAMSession -> IO ()
doAttachRolePolicy (RoleName rn) (ARN arn) = withAWS $ do
    void $ send $ attachRolePolicy rn arn

doListAttachedRolePolicies :: RoleName -> IAMSession -> IO [ARN]
doListAttachedRolePolicies (RoleName rn) = withAWS $ do
    result <- send $ listAttachedRolePolicies rn
    return $ catMaybes [ ARN <$> x ^. apPolicyARN | x <- result ^. larprsAttachedPolicies ]

waitForRolePolicy :: RoleName -> ARN -> IAMSession -> IO ()
waitForRolePolicy roleName policyArn iamSession = do
    arns <- doListAttachedRolePolicies roleName iamSession
    if policyArn `elem` arns then pure () else do
        threadDelay 1000000
        waitForRolePolicy roleName policyArn iamSession
        
zipFunctionCode :: FilePath -> POSIXTime -> ByteString -> FunctionCode
zipFunctionCode path timestamp sourceCode =
    let entry = toEntry path (floor timestamp) sourceCode
        archive = entry `addEntryToArchive` emptyArchive
        bytes = ByteString.toStrict $ fromArchive archive
    in functionCode & fcZipFile .~ Just bytes

doListFunctions :: LambdaSession -> IO [Maybe FunctionName]
doListFunctions = withAWS $ do
    result <- send $ listFunctions
    return [ FunctionName <$> f ^. fcFunctionName | f <- result ^. lfrsFunctions ]

doCreateFunctionIfNotExists :: FunctionName -> Runtime -> ARN -> Handler -> FunctionCode -> LambdaSession -> IO ()
doCreateFunctionIfNotExists (FunctionName fn) rt (ARN arn) (Handler h) fc = withAWS $ do
    handling _ResourceConflictException (const (pure ())) $ do
        void $ send $ createFunction fn rt arn h fc

doInvoke :: FunctionName -> Payload -> LambdaSession -> IO (Maybe Payload)
doInvoke (FunctionName fn) payload = withAWS $ do
    result <- send $ invoke fn payload
    return $ result ^. irsPayload

awsSession :: FunctionName -> IO (ARN, LambdaSession)
awsSession fn = do
    homeDir <- getHomeDirectory
    let conf = awsConfig (AWSRegion Ohio)
                & awscCredentials .~ (FromFile "aws-via-haskell" $ homeDir </> ".aws" </> "credentials")

    stsSession <- connect conf stsService
    mbAccountID <- doGetAccountID stsSession
    let accountID = case mbAccountID of
                        Nothing -> error "No AWS account ID!"
                        Just x -> x
        roleName = RoleName "lambda_basic_execution"
        policyDoc = PolicyDocument "{\n\
                        \    \"Version\": \"2012-10-17\",\n\
                        \    \"Statement\": [{\n\
                        \         \"Effect\": \"Allow\",\n\
                        \         \"Principal\": { \"Service\" : \"lambda.amazonaws.com\" },\n\
                        \         \"Action\": \"sts:AssumeRole\"\n\
                        \    }]\n\
                        \}"

    lambdaSession <- connect conf lambdaService

    putStrLn "DeleteFunctionIfExists"
    doDeleteFunctionIfExists fn lambdaSession

    iamSession <- connect conf iamService

    putStrLn "DetachRolePolicyIfExists"
    doDetachRolePolicyIfExists roleName awsLambdaBasicExecutionRolePolicy iamSession

    putStrLn "DeleteRoleIfExists"
    doDeleteRoleIfExists roleName iamSession

    putStrLn "CreateRole"
    arn <- doCreateRoleIfNotExists accountID roleName policyDoc iamSession

    putStrLn "AttachRolePolicy"
    doAttachRolePolicy roleName awsLambdaBasicExecutionRolePolicy iamSession

    putStrLn "WaitForRolePolicy"
    waitForRolePolicy roleName awsLambdaBasicExecutionRolePolicy iamSession

    return (arn, lambdaSession)

localStackSession :: IO (ARN, LambdaSession)
localStackSession = do
    s <- connect (awsConfig $ Local "localhost" 4574) lambdaService
    return (ARN "", s)

main :: IO ()
main = do
    let fn = FunctionName "Add"
    (arn, lambdaSession) <- if False then awsSession fn else localStackSession

    timestamp <- getPOSIXTime
    let fc = zipFunctionCode "add_handler.py" timestamp "def add_handler(event, context):\n\
        \    x = int(event[\"x\"])\n\
        \    y = int(event[\"y\"])\n\
        \    return { \"result\" : x + y }"

    putStrLn "CreateFunction"
    doCreateFunctionIfNotExists fn PYTHON2_7 arn (Handler "add_handler.add_handler") fc lambdaSession

    putStrLn "ListFunctions"
    names <- doListFunctions lambdaSession
    forM_ names $ \mbName ->
        case mbName of
            Just name -> putStrLn $ "  " <> show name
            Nothing -> Text.putStrLn $ "  (unnamed)"

    putStrLn "Invoke"
    result <- doInvoke fn (HashMap.fromList [ ("x", Number 10), ("y", Number 25) ]) lambdaSession
    print result

TH.hs

{-|
Module      : AWSViaHaskell.TH
Description : Template Haskell helpers for 'AWSViaHaskell'
Copyright   : (C) Richard Cook, 2017
License     : MIT
Maintainer  : rcook@rcook.org
Stability   : experimental
Portability : portable

This modules provides Template Haskell helper functions for eliminating boilerplate
-}

{-# LANGUAGE TemplateHaskell #-}

module AWSViaHaskell.TH
    ( wrapAWSService
    ) where

import           AWSViaHaskell.Classes
import           AWSViaHaskell.Types
import           Language.Haskell.TH
import           Network.AWS (Service)

-- |Generates type-safe AWS service and session wrappers types for use with
-- 'AWSViaHaskell.AWSService.connect' and 'AWSViaHaskell.AWSService.withAWS' functions
--
-- Example top-level invocation:
--
-- @
-- wrapAWSService \'dynamoDB \"DDBService\" \"DDBSession\"
-- @
--
-- This will generate boilerplate like the following:
--
-- @
-- data DDBService = DDBService Service
--
-- data DDBSession = DDBSession Session
--
-- instance ServiceClass DDBService where
--     type TypedSession DDBService = DDBSession
--     rawService (DDBService x) = x
--     wrappedSession = DDBSession
--
-- instance SessionClass DDBSession where
--     rawSession (DDBSession x) = x
--
-- dynamoDBService :: DDBService
-- dynamoDBService = DDBService dynamoDB
-- @
wrapAWSService ::
    Name        -- ^ Name of the amazonka 'Network.AWS.Types.Service' value to wrap
    -> String   -- ^ Name of the service type to generate
    -> String   -- ^ Name of the session type to generate
    -> Q [Dec]  -- ^ Declarations for splicing into source file
wrapAWSService varN serviceTypeName sessionTypeName = do
    serviceVarN <- newName "x"
    sessionVarN <- newName "x"
    let serviceN = mkName serviceTypeName
        sessionN = mkName sessionTypeName
        wrappedVarN = mkName $ nameBase varN ++ "Service"
        serviceD = DataD [] serviceN [] Nothing [NormalC serviceN [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Service)]] []
        sessionD = DataD [] sessionN [] Nothing [NormalC sessionN [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Session)]] []
        serviceInst = InstanceD
                        Nothing
                        []
                        (AppT (ConT ''ServiceClass) (ConT serviceN))
                        [ TySynInstD ''TypedSession (TySynEqn [ConT serviceN] (ConT sessionN))
                        , FunD 'rawService [Clause [ConP serviceN [VarP serviceVarN]] (NormalB (VarE serviceVarN)) []]
                        , ValD (VarP 'wrappedSession) (NormalB (ConE $ mkName sessionTypeName)) []
                        ]
        sessionInst = InstanceD
                        Nothing
                        []
                        (AppT (ConT ''SessionClass) (ConT sessionN))
                        [ FunD 'rawSession [Clause [ConP sessionN [VarP sessionVarN]] (NormalB (VarE sessionVarN)) []]
                        ]
        sig = SigD wrappedVarN (ConT serviceN)
        var = ValD (VarP wrappedVarN) (NormalB (AppE (ConE serviceN) (VarE $ varN))) []
    pure
        [ serviceD
        , sessionD
        , serviceInst
        , sessionInst
        , sig
        , var
        ]

Types.hs

{-# LANGUAGE TemplateHaskell #-}

module AWSViaHaskell.Types
    ( Session(..)
    , sEnv
    , sRegion
    , sService
    ) where

import           Control.Lens (makeLenses)
import           Network.AWS (Env, Region, Service)

data Session = Session
    { _sEnv :: Env
    , _sRegion :: Region
    , _sService :: Service
    }
makeLenses ''Session

Util.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module AWSViaHaskell.Util
    ( intToText
    , parseInt
    ) where

import           Data.Text (Text)
import qualified Data.Text as Text (null, pack)
import qualified Data.Text.Read as Text (decimal)

intToText :: Int -> Text
intToText = Text.pack . show

parseInt :: Text -> Maybe Int
parseInt s = case Text.decimal s of
    Left _ -> Nothing
    Right (result, s') -> if Text.null s' then Just result else Nothing

WrapAWSServiceSample.hs

wrapAWSService 'iam "IAMService" "IAMSession"
wrapAWSService 'lambda "LambdaService" "LambdaSession"
wrapAWSService 'sts "STSService" "STSSession"