Last active
May 23, 2022 09:14
-
-
Save rcook/802f0b02591d4fd46e47e8de34b8218d to your computer and use it in GitHub Desktop.
AWS via Haskell Part 5 (Lambda)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
def add_handler(event, context): | |
x = int(event["x"]) | |
y = int(event["y"]) | |
return { "result" : x + y } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
connect :: forall a . ServiceClass a => AWSConfig -> a -> IO (TypedSession a) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
doGetAccountID :: STSSession -> IO (Maybe AccountID) | |
doGetAccountID = withAWS $ do | |
result <- send getCallerIdentity | |
return $ AccountID <$> result ^. gcirsAccount |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-| | |
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 | |
] |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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