Create a gist now

Instantly share code, notes, and snippets.

@rcook /AWSService.hs
Last active Dec 29, 2017

What would you like to do?
AWS via Haskell Part 5 (Lambda)
def add_handler(event, context):
x = int(event["x"])
y = int(event["y"])
return { "result" : x + y }
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
{-# 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
{-# 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 :: forall a . ServiceClass a => AWSConfig -> a -> IO (TypedSession a)
-- 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 :: STSSession -> IO (Maybe AccountID)
doGetAccountID = withAWS $ do
result <- send getCallerIdentity
return $ AccountID <$> result ^. gcirsAccount
{-# 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
{-|
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
]
{-# 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
{-# 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
wrapAWSService 'iam "IAMService" "IAMSession"
wrapAWSService 'lambda "LambdaService" "LambdaSession"
wrapAWSService 'sts "STSService" "STSSession"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment