wip: Refactor Configuration

Author: NickSeagull

.hlint.yaml

@@ -8,22 +8,31 @@
 
 # Specify additional command line arguments
 #
-# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
+- arguments:
+  - TemplateHaskell
+  - OverloadedStrings
+  - RecordWildCards
+  - ScopedTypeVariables
+  - DeriveGeneric
+  - TypeApplications
+  - FlexibleContexts
+  - DeriveAnyClass
+  - QuasiQuotes
 
 
 # Control which extensions/flags/modules/functions can be used
 #
-- extensions:
-  - name:
-    - TemplateHaskell
-    - OverloadedStrings
-    - RecordWildCards
-    - ScopedTypeVariables
-    - DeriveGeneric
-    - TypeApplications
-    - FlexibleContexts
-    - DeriveAnyClass
-    - QuasiQuotes
+# - extensions:
+#   - name:
+#     - TemplateHaskell
+#     - OverloadedStrings
+#     - RecordWildCards
+#     - ScopedTypeVariables
+#     - DeriveGeneric
+#     - TypeApplications
+#     - FlexibleContexts
+#     - DeriveAnyClass
+#     - QuasiQuotes
 #
 # - flags:
 #   - {name: -w, within: []} # -w is allowed nowhere

src/Aws/Lambda/Configuration.hs

@@ -1,97 +1,37 @@
 {-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}
 module Aws.Lambda.Configuration
-  ( LambdaOptions (..)
+  ( Main.LambdaOptions(..)
+  , Main.generate
+  , Main.getRecord
   , configureLambda
   , returnAndFail
   , returnAndSucceed
   , decodeObj
-  , Options.getRecord
   )
 where
 
 import Data.Aeson
 
-import Control.Monad
 import qualified Data.ByteString.Lazy as LazyByteString
-import Data.Function ((&))
 import Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Encoding
-import GHC.Generics
 import Language.Haskell.TH
-import qualified Options.Generic as Options
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (hFlush, stderr, stdout)
 
-import Path
-import qualified Path.IO as PathIO
-
-import Aws.Lambda.ThHelpers
+import qualified Aws.Lambda.Meta.Main as Main
+import qualified Aws.Lambda.Meta.Run as Run
 
 putTextLn :: Text -> IO ()
 putTextLn = putStrLn . Text.unpack
 
-data LambdaOptions = LambdaOptions
-  { eventObject     :: Text
-  , contextObject   :: Text
-  , functionHandler :: Text
-  , executionUuid   :: Text
-  } deriving (Generic)
-instance Options.ParseRecord LambdaOptions
-
-
--- This function is the reason why we disable the warning on top of the module
-mkMain :: Q [Dec]
-mkMain = [d|
-  $(pName "main") = getRecord "" >>= run
-  |]
-
-mkRun :: Q Dec
-mkRun = do
-  handlers <- runIO getHandlers
-  clause' <- recordQ "LambdaOptions" ["functionHandler", "contextObject", "eventObject", "executionUuid"]
-  body <- dispatcherCaseQ handlers
-  pure $ FunD (mkName "run") [Clause [clause'] (NormalB body) []]
-
-
-dispatcherCaseQ :: [Text] -> Q Exp
-dispatcherCaseQ fileNames = do
-  caseExp <- eName "functionHandler"
-  matches <- traverse handlerCaseQ fileNames
-  unmatched <- unmatchedCaseQ
-  pure $ CaseE caseExp (matches <> [unmatched])
-
-
-handlerCaseQ :: Text -> Q Match
-handlerCaseQ lambdaHandler = do
-  let pat = LitP (StringL $ Text.unpack lambdaHandler)
-  body <- [e|do
-    result <- $(eName qualifiedName) (decodeObj $(eName "eventObject")) (decodeObj $(eName "contextObject"))
-    either (returnAndFail $(eName "executionUuid")) (returnAndSucceed $(eName "executionUuid")) result |]
-  pure $ Match pat (NormalB body) []
- where
-  qualifiedName =
-    lambdaHandler
-    & Text.dropWhile (/= '/')
-    & Text.drop 1
-    & Text.replace "/" "."
-
-
-unmatchedCaseQ :: Q Match
-unmatchedCaseQ = do
-  let pattern = WildP
-  body <- [e|
-    returnAndFail $(eName "executionUuid") ("Handler " <> $(eName "functionHandler") <> " does not exist on project")
-    |]
-  pure $ Match pattern (NormalB body) []
-
 configureLambda :: Q [Dec]
 configureLambda = do
-  main <- mkMain
-  run <- mkRun
+  main <- Main.generate
+  run <- Run.generate
   return $ main <> [run]
 
-
 returnAndFail :: ToJSON a => Text -> a -> IO ()
 returnAndFail uuid v = do
   hFlush stdout
@@ -115,23 +55,4 @@ decodeObj :: FromJSON a => Text -> a
 decodeObj x =
   case (eitherDecode $ LazyByteString.fromStrict $ Encoding.encodeUtf8 x) of
     Left e  -> error e
-    Right v -> v
-
-getHandlers :: IO [Text]
-getHandlers = do
-  (_, files) <- PathIO.listDirRecurRel [reldir|.|]
-  handlerFiles <- files
-                   & fmap toFilePath
-                   & fmap Text.pack
-                   & filter (Text.isSuffixOf ".hs")
-                   & filterM containsHandler
-                   & fmap (fmap $ Text.dropEnd 3)
-                   & fmap (fmap $ Text.drop 2)
-                   & fmap (fmap (<> ".handler"))
-  return handlerFiles
-
-
-containsHandler :: Text -> IO Bool
-containsHandler file = do
-  fileContents <- readFile $ Text.unpack file
-  return $ "handler :: " `Text.isInfixOf` Text.pack fileContents
+    Right v -> v

src/Aws/Lambda/ThHelpers.hs renamed to src/Aws/Lambda/Meta/Common.hs

@@ -1,7 +1,7 @@
-module Aws.Lambda.ThHelpers
-  ( pName
-  , eName
-  , recordQ
+module Aws.Lambda.Meta.Common
+  ( declarationName
+  , expressionName
+  , getFieldsFrom
   ) where
 
 import Data.Text (Text)
@@ -10,26 +10,26 @@ import Language.Haskell.TH
 
 -- | Helper for defining names in declarations
 -- think of @myValue@ in @myValue = 2@
-pName :: Text -> Q Pat
-pName = pure . VarP . mkName . Text.unpack
+declarationName :: Text -> Q Pat
+declarationName = pure . VarP . mkName . Text.unpack
 
 -- | Helper for defining names in expressions
 -- think of @myFunction@ in @quux = myFunction 3@
-eName :: Text -> Q Exp
-eName = pure . VarE . mkName . Text.unpack
+expressionName :: Text -> Q Exp
+expressionName = pure . VarE . mkName . Text.unpack
 
 
 -- | Helper for extracting fields of a specified record
 -- it expects the constructor name as the first parameter,
 -- and the list of fields to bring into scope as second
 -- think of @Person@, and @personAge@, @personName@ in
 -- @myFunction Person { personAge, personName } = ...@
-recordQ :: Text -> [Text] -> Q Pat
-recordQ name fields = do
-  extractedFields <- traverse fName fields
+getFieldsFrom :: Text -> [Text] -> Q Pat
+getFieldsFrom name fields = do
+  extractedFields <- traverse extractField fields
   pure $ RecP (mkName $ Text.unpack name) extractedFields
  where
   -- | Helper for extracting fields of records
   -- think of @personAge@ in @myFunction Person { personAge = personAge } = ...@
-  fName :: Text -> Q FieldPat
-  fName n = pure (mkName $ Text.unpack n, VarP $ mkName $ Text.unpack n)
+  extractField :: Text -> Q FieldPat
+  extractField n = pure (mkName $ Text.unpack n, VarP $ mkName $ Text.unpack n)

src/Aws/Lambda/Meta/Discover.hs

@@ -0,0 +1,39 @@
+module Aws.Lambda.Meta.Discover
+  (handlers) where
+
+import Data.Text (Text)
+import Data.Function ((&))
+import qualified Data.Text as Text
+import qualified Control.Monad as Monad
+import qualified Data.Maybe as Maybe
+
+import Path
+import qualified Path.IO as PathIO
+
+handlers :: IO [Text]
+handlers = do
+  (_, files) <- PathIO.listDirRecurRel [reldir|.|]
+  handlerFiles <- modulesWithHandler files
+  pure (handlerNames handlerFiles)
+
+modulesWithHandler :: [Path Rel File] -> IO [Path Rel File]
+modulesWithHandler files =
+  filter isHaskellModule files
+  & Monad.filterM containsHandler
+ where
+  isHaskellModule file =
+    fileExtension file == ".hs"
+
+handlerNames :: [Path Rel File] -> [Text]
+handlerNames modules =
+  fmap changeExtensionToHandler modules
+  & fmap (Text.pack . toFilePath)
+ where
+  changeExtensionToHandler file =
+    setFileExtension ".handler" file
+    & Maybe.fromJust
+
+containsHandler :: Path Rel File -> IO Bool
+containsHandler file = do
+  fileContents <- readFile $ toFilePath file
+  pure $ "handler :: " `Text.isInfixOf` Text.pack fileContents

src/Aws/Lambda/Meta/Dispatch.hs

@@ -0,0 +1,41 @@
+module Aws.Lambda.Meta.Dispatch
+  (generate) where
+
+import Data.Function ((&))
+import Data.Text (Text)
+import qualified Data.Text as Text
+
+import qualified Language.Haskell.TH as Meta
+
+import Aws.Lambda.Meta.Common
+
+generate :: [Text] -> Meta.ExpQ
+generate fileNames = do
+  caseExp <- expressionName "functionHandler"
+  matches <- traverse handlerCase fileNames
+  unmatched <- unmatchedCase
+  pure $ Meta.CaseE caseExp (matches <> [unmatched])
+
+
+handlerCase :: Text -> Meta.MatchQ
+handlerCase lambdaHandler = do
+  let pat = Meta.LitP (Meta.StringL $ Text.unpack lambdaHandler)
+  body <- [e|do
+    result <- $(expressionName qualifiedName) (decodeObj $(expressionName "eventObject")) (decodeObj $(expressionName "contextObject"))
+    either (returnAndFail $(expressionName "executionUuid")) (returnAndSucceed $(expressionName "executionUuid")) result |]
+  pure $ Meta.Match pat (Meta.NormalB body) []
+ where
+  qualifiedName =
+    lambdaHandler
+    & Text.dropWhile (/= '/')
+    & Text.drop 1
+    & Text.replace "/" "."
+
+
+unmatchedCase :: Meta.MatchQ
+unmatchedCase = do
+  let pattern = Meta.WildP
+  body <- [e|
+    returnAndFail $(expressionName "executionUuid") ("Handler " <> $(expressionName "functionHandler") <> " does not exist on project")
+    |]
+  pure $ Meta.Match pattern (Meta.NormalB body) []

src/Aws/Lambda/Meta/Main.hs

@@ -0,0 +1,25 @@
+module Aws.Lambda.Meta.Main
+  ( LambdaOptions(..)
+  , generate
+  , Options.getRecord
+  ) where
+
+import Data.Text (Text)
+import GHC.Generics (Generic)
+
+import qualified Options.Generic as Options
+import qualified Language.Haskell.TH as Meta
+
+import Aws.Lambda.Meta.Common
+
+data LambdaOptions = LambdaOptions
+  { eventObject     :: !Text
+  , contextObject   :: !Text
+  , functionHandler :: !Text
+  , executionUuid   :: !Text
+  } deriving (Generic, Options.ParseRecord)
+
+generate :: Meta.DecsQ
+generate = [d|
+  $(declarationName "main") = getRecord "" >>= run
+  |]

src/Aws/Lambda/Meta/Run.hs

@@ -0,0 +1,16 @@
+module Aws.Lambda.Meta.Run
+  ( generate
+  ) where
+
+import qualified Language.Haskell.TH as Meta
+
+import Aws.Lambda.Meta.Common
+import qualified Aws.Lambda.Meta.Dispatch as Dispatch
+import qualified Aws.Lambda.Meta.Discover as Discover
+
+generate :: Meta.DecQ
+generate = do
+  handlers <- Meta.runIO Discover.handlers
+  clause' <- getFieldsFrom "LambdaOptions" ["functionHandler", "contextObject", "eventObject", "executionUuid"]
+  body <- Dispatch.generate handlers
+  pure $ Meta.FunD (Meta.mkName "run") [Meta.Clause [clause'] (Meta.NormalB body) []]