Localstack annd rds testing support (#14)

* New runReaderAwsEnvDiscover function

* Export runFileSystem

* Testcontainers for loccalstack support

* New logEntryToJson and logMessageToJson functions

* New putJsonStdout function

* Export hedgehog Failure type

* Modify Log effect to coonvey the severity and message together in the LogMessage

* New runReaderM function

* New Effectful.Zoo.Environment exporting lookupEnv that throws on error and lookupEnvMaybe that doesn't, both using Text as the type

* New lookupParseMaybeEnv and lookupParseEitherEnv functions

* New lookupMapEnv function

* New functions: failMessage, failWithCustom, byDurationM, and byDeadlineM

* New rds-data-test and testcontainers-localstack components

Author: newhoggy

components/amazonka/Effectful/Zoo/Amazonka/Api/Run.hs

@@ -4,14 +4,19 @@ module Effectful.Zoo.Amazonka.Api.Run
   ( runDataLogAwsLogEntryToLog,
     runDataLogAwsLogEntryToLogWith,
     runDataLogAwsLogEntryLocalToLogWith,
+    runReaderAwsEnvDiscover,
   ) where
 
+import Amazonka qualified as AWS
 import Control.Monad.IO.Class
 import Data.ByteString.Builder qualified as B
+import Data.Generics.Product.Any
 import Data.Text.Lazy qualified as LT
 import Data.Text.Lazy.Encoding qualified as LT
 import Data.Time.Clock qualified as IO
 import Effectful
+import Effectful.Environment
+import Effectful.Reader.Static
 import Effectful.Zoo.Amazonka.Api
 import Effectful.Zoo.Amazonka.Data
 import Effectful.Zoo.Core
@@ -21,6 +26,8 @@ import Effectful.Zoo.DataLog.Dynamic
 import Effectful.Zoo.Log.Data.LogMessage
 import Effectful.Zoo.Log.Data.Severity
 import HaskellWorks.Prelude
+import Lens.Micro
+import System.IO qualified as IO
 
 runDataLogAwsLogEntryToLog :: forall a r. ()
   => r <: DataLog (LogEntry (LogMessage Text))
@@ -61,3 +68,26 @@ runDataLogAwsLogEntryLocalToLogWith mapSeverity context =
         , time = now
         , source = entry.callStack
         }
+
+runReaderAwsEnvDiscover :: forall a r. ()
+  => r <: Environment
+  => r <: IOE
+  => Eff (Reader AwsEnv : r) a
+  -> Eff r a
+runReaderAwsEnvDiscover f = do
+  logger' <- liftIO $ AWS.newLogger AWS.Debug IO.stdout
+
+  mLocalStackHost <- lookupEnv "AWS_LOCALSTACK_HOST"
+  mLocalStackPort <- lookupEnv "AWS_LOCALSTACK_PORT"
+
+  mLocalStackEndpoint <- pure $ (,)
+    <$> mLocalStackHost
+    <*> mLocalStackPort
+
+  discoveredAwsEnv <- liftIO $ AWS.newEnv AWS.discover
+
+  awsEnv <- pure $ discoveredAwsEnv
+    & the @"logger" .~ logger'
+    & the @"overrides" %~ maybeSetEndpoint mLocalStackEndpoint
+
+  runReader awsEnv f

components/core/Effectful/Zoo/DataLog/Api.hs

@@ -1,12 +1,23 @@
 module Effectful.Zoo.DataLog.Api
   ( dataLog,
+    logEntryToJson,
+    logMessageToJson,
+    putJsonStdout,
   ) where
 
+import Data.Aeson (Value, object, (.=))
+import Data.Aeson qualified as J
+import Data.ByteString.Lazy qualified as LBS
 import Effectful
 import Effectful.Dispatch.Dynamic
+import Effectful.Dispatch.Static
 import Effectful.Zoo.Core
+import Effectful.Zoo.DataLog.Data.LogEntry
 import Effectful.Zoo.DataLog.Dynamic
+import Effectful.Zoo.Log.Data.LogMessage
+import GHC.Stack qualified as GHC
 import HaskellWorks.Prelude
+import System.IO qualified as IO
 
 dataLog :: ()
   => HasCallStack
@@ -16,3 +27,41 @@ dataLog :: ()
 dataLog i =
   withFrozenCallStack do
     send $ DataLog i
+
+logEntryToJson :: forall a. ()
+  => (a -> Value)
+  -> LogEntry a
+  -> Value
+logEntryToJson aToJson (LogEntry value time callstack) =
+    object
+      [ "time" .= time
+      , "data" .= aToJson value
+      , "callstack" .= fmap callsiteToJson (GHC.getCallStack callstack)
+      ]
+    where
+      callsiteToJson :: ([Char], GHC.SrcLoc) -> Value
+      callsiteToJson (caller, srcLoc) =
+        object
+          [ "caller"    .= caller
+          , "package"   .= GHC.srcLocPackage srcLoc
+          , "module"    .= GHC.srcLocModule srcLoc
+          , "file"      .= GHC.srcLocFile srcLoc
+          , "startLine" .= GHC.srcLocStartLine srcLoc
+          , "startCol"  .= GHC.srcLocStartCol srcLoc
+          , "endLine"   .= GHC.srcLocEndLine srcLoc
+          , "endCol"    .= GHC.srcLocEndCol srcLoc
+          ]
+
+logMessageToJson :: LogMessage Text -> Value
+logMessageToJson (LogMessage severity message) =
+    object
+      [ "severity" .= show severity
+      , "message"  .= message
+      ]
+
+putJsonStdout :: ()
+  => Value
+  -> Eff r ()
+putJsonStdout value = do
+  unsafeEff_ $ LBS.putStr $ J.encode value <> "\n"
+  unsafeEff_ $ IO.hFlush IO.stdout

components/core/Effectful/Zoo/Environment.hs

@@ -0,0 +1,88 @@
+module Effectful.Zoo.Environment
+  ( -- * Effect
+    Environment,
+
+    -- ** Handlers
+    E.runEnvironment,
+
+    -- * Querying the environment
+    E.getArgs,
+    E.getProgName,
+    E.getExecutablePath,
+    E.getEnv,
+    E.getEnvironment,
+    lookupEnv,
+    lookupEnvMaybe,
+    lookupMapEnv,
+    lookupParseMaybeEnv,
+    lookupParseEitherEnv,
+
+    -- * Modifying the environment
+    E.setEnv,
+    E.unsetEnv,
+    E.withArgs,
+    E.withProgName,
+  )
+  where
+
+import Data.Text qualified as T
+import Effectful
+import Effectful.Environment (Environment)
+import Effectful.Environment qualified as E
+import Effectful.Zoo.Core
+import Effectful.Zoo.Error.Static
+import Effectful.Zoo.Errors.EnvironmentVariableInvalid
+import Effectful.Zoo.Errors.EnvironmentVariableMissing
+import HaskellWorks.Prelude
+
+lookupEnv :: ()
+  => r <: Environment
+  => r <: Error EnvironmentVariableMissing
+  => Text
+  -> Eff r Text
+lookupEnv envName =
+  lookupEnvMaybe envName
+    & onNothingM (throw $ EnvironmentVariableMissing envName)
+
+lookupMapEnv :: ()
+  => r <: Environment
+  => r <: Error EnvironmentVariableMissing
+  => Text
+  -> (Text -> a)
+  -> Eff r a
+lookupMapEnv envName f =
+  f <$> lookupEnv envName
+
+lookupParseMaybeEnv :: ()
+  => r <: Environment
+  => r <: Error EnvironmentVariableInvalid
+  => r <: Error EnvironmentVariableMissing
+  => Text
+  -> (Text -> Maybe a)
+  -> Eff r a
+lookupParseMaybeEnv envName parse = do
+  text <- lookupEnv envName
+
+  parse text
+    & onNothing (throw $ EnvironmentVariableInvalid envName text Nothing)
+
+lookupParseEitherEnv :: ()
+  => r <: Environment
+  => r <: Error EnvironmentVariableInvalid
+  => r <: Error EnvironmentVariableMissing
+  => Text
+  -> (Text -> Either Text a)
+  -> Eff r a
+lookupParseEitherEnv envName parse = do
+  text <- lookupEnv envName
+
+  parse text
+    & onLeft (throw . EnvironmentVariableInvalid envName text . Just)
+
+lookupEnvMaybe :: ()
+  => r <: Environment
+  => Text
+  -> Eff r (Maybe Text)
+lookupEnvMaybe envName = do
+  value <- E.lookupEnv $ T.unpack envName
+  pure $ T.pack <$> value

components/core/Effectful/Zoo/Errors/EnvironmentVariableInvalid.hs

@@ -0,0 +1,24 @@
+module Effectful.Zoo.Errors.EnvironmentVariableInvalid
+  ( EnvironmentVariableInvalid (..),
+  ) where
+
+import Data.Aeson (ToJSON (..), (.=))
+import Data.Aeson qualified as J
+import GHC.Generics
+import HaskellWorks.Prelude
+
+data EnvironmentVariableInvalid = EnvironmentVariableInvalid
+    { variable :: Text
+    , text :: Text
+    , reason :: Maybe Text
+    }
+    deriving stock (Eq, Show, Generic)
+
+instance ToJSON EnvironmentVariableInvalid where
+    toJSON e =
+        J.object
+            [ "error" .= id @Text "EnvironmentVariableInvalid"
+            , "variable" .= e.variable
+            , "text" .= e.text
+            , "reason" .= e.reason
+            ]

components/core/Effectful/Zoo/Errors/EnvironmentVariableMissing.hs

@@ -0,0 +1,20 @@
+module Effectful.Zoo.Errors.EnvironmentVariableMissing
+  ( EnvironmentVariableMissing (..),
+  ) where
+
+import Data.Aeson (ToJSON (..), (.=))
+import Data.Aeson qualified as J
+import GHC.Generics
+import HaskellWorks.Prelude
+
+newtype EnvironmentVariableMissing = EnvironmentVariableMissing
+    { variable :: Text
+    }
+    deriving stock (Eq, Show, Generic)
+
+instance ToJSON EnvironmentVariableMissing where
+    toJSON e =
+        J.object
+            [ "error" .= id @Text "EnvironmentVariableMissing"
+            , "variable" .= e.variable
+            ]

components/core/Effectful/Zoo/FileSystem.hs

@@ -13,6 +13,8 @@ module Effectful.Zoo.FileSystem
     removePathForcibly,
     doesFileExist,
     doesDirectoryExist,
+
+    runFileSystem,
   ) where
 
 import Data.Aeson (FromJSON)
@@ -23,7 +25,7 @@ import Data.Text qualified as T
 import Data.Yaml qualified as Y
 import Effectful
 import Effectful.Dispatch.Static
-import Effectful.FileSystem (FileSystem)
+import Effectful.FileSystem (FileSystem, runFileSystem)
 import Effectful.Zoo.Core
 import Effectful.Zoo.Error.Static
 import Effectful.Zoo.Exception

components/core/Effectful/Zoo/Log/Api/Generic.hs

@@ -11,6 +11,7 @@ module Effectful.Zoo.Log.Api.Generic
 import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Zoo.Core
+import Effectful.Zoo.Log.Data.LogMessage
 import Effectful.Zoo.Log.Data.Severity
 import Effectful.Zoo.Log.Dynamic
 import HaskellWorks.Prelude
@@ -23,7 +24,7 @@ log :: ()
   -> Eff r ()
 log severity message =
   withFrozenCallStack $
-    send (Log severity message)
+    send (Log (LogMessage severity message))
 
 trace :: ()
   => HasCallStack

components/core/Effectful/Zoo/Log/Api/LazyText.hs

@@ -11,6 +11,7 @@ module Effectful.Zoo.Log.Api.LazyText
 import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Zoo.Core
+import Effectful.Zoo.Log.Data.LogMessage
 import Effectful.Zoo.Log.Data.Severity
 import Effectful.Zoo.Log.Dynamic
 import HaskellWorks.Prelude
@@ -23,7 +24,7 @@ log :: ()
   -> Eff r ()
 log severity message =
   withFrozenCallStack $
-    send (Log severity message)
+    send (Log (LogMessage severity message))
 
 trace :: ()
   => HasCallStack

components/core/Effectful/Zoo/Log/Api/String.hs

@@ -11,6 +11,7 @@ module Effectful.Zoo.Log.Api.String
 import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Zoo.Core
+import Effectful.Zoo.Log.Data.LogMessage
 import Effectful.Zoo.Log.Data.Severity
 import Effectful.Zoo.Log.Dynamic
 import HaskellWorks.Prelude
@@ -23,7 +24,7 @@ log :: ()
   -> Eff r ()
 log severity message =
   withFrozenCallStack $
-    send (Log severity message)
+    send (Log (LogMessage severity message))
 
 trace :: ()
   => HasCallStack

components/core/Effectful/Zoo/Log/Api/Text.hs

@@ -12,6 +12,7 @@ import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Zoo.Core
 import Effectful.Zoo.Log.Data.Severity
+import Effectful.Zoo.Log.Data.LogMessage
 import Effectful.Zoo.Log.Dynamic
 import HaskellWorks.Prelude
 
@@ -23,7 +24,7 @@ log :: ()
   -> Eff r ()
 log severity message =
   withFrozenCallStack $
-    send (Log severity message)
+    send (Log (LogMessage severity message))
 
 trace :: ()
   => HasCallStack