-
Hey, sorry for the newbie question here, but I've been banging my head against this for three days and some help would be appreciated. In short, I'm trying to convert a Long form:My goal is to take a log effect I've written (based on Di-Df1): data Log :: Effect where
LogWithLevel :: Level -> Message -> Log m () Full `Log.hs` filemodule Yf.Effect.Log (
Log,
-- Re-exports from other Log libs
Level(..),
Rate(..),
-- Re-exports from DF1
Path,
Segment,
ToSegment,
Key,
ToKey,
Value,
ToValue,
Message,
ToMessage,
segment,
key,
value,
message,
-- Core effects
attr_,
push_,
filter,
logWithLevel,
flush,
askLogFn,
-- Helpers
attr,
push,
traceSensitive,
debug,
info,
error,
traceSensitive_,
debug_,
info_,
error_,
-- Runners
runDiIO,
runConsole,
runConsole_,
runNoop,
) where
import Prelude hiding (runReader, Reader, filter, error)
import Yf.Effect.Log.Level (Level(..), Rate(..))
import qualified Yf.Effect.Log.Level as Level
import Effectful (Effect, Eff, IOE, (:>), UnliftStrategy(ConcUnlift), Persistence(Persistent), Limit(Unlimited))
import qualified Effectful as Effectful
import Effectful.Dispatch.Dynamic (interpret, reinterpret, localUnlift, localSeqUnlift)
import Effectful.TH (makeEffect)
-- TODO: try swapping out for static
import Effectful.Reader.Dynamic (Reader(), runReader)
import qualified Effectful.Reader.Dynamic as Reader
import Di.Core (Di, log_level)
import qualified Di.Core as Di
import qualified Di.Handle as DiHandle
import qualified Di.Df1 as DiDf1
import Df1 (Path, Segment, ToSegment, Key, ToKey, Value, ToValue, Message, ToMessage, segment, key, value, message)
import Data.Sequence (Seq)
data Log :: Effect where
Attr_ :: Key -> Value -> m a -> Log m a
Push_ :: Segment -> m a -> Log m a
Filter :: (Level -> Seq Path -> Message -> Bool) -> m a -> Log m a
AskDi :: Log m (Di Level Path Message)
LogWithLevel :: Level -> Message -> Log m ()
Flush :: Log m ()
AskLogFn :: (MonadIO w) => Log m (Level -> Message -> w ())
makeEffect ''Log
attr :: (ToValue v, Log :> es) => Key -> v -> Eff es a -> Eff es a
attr key val action = attr_ key (Df1.value val) action
push :: (ToSegment s, Log :> es) => s -> Eff es a -> Eff es a
push s action = push_ (segment s) action
traceSensitive :: (ToMessage msg, Log :> es) => msg -> Eff es ()
traceSensitive msg = logWithLevel TraceSensitive (message msg)
debug :: (ToMessage msg, Log :> es) => msg -> Eff es ()
debug msg = logWithLevel Debug (message msg)
info :: (ToMessage msg, Log :> es) => msg -> Eff es ()
info msg = logWithLevel Info (message msg)
error :: (ToMessage msg, Log :> es) => Rate -> msg -> Eff es ()
error rate msg = logWithLevel (Error rate) (message msg)
traceSensitive_ :: Log :> es => Message -> Eff es ()
traceSensitive_ msg = logWithLevel TraceSensitive (message msg)
debug_ :: Log :> es => Message -> Eff es ()
debug_ msg = logWithLevel Debug (message msg)
info_ :: Log :> es => Message -> Eff es ()
info_ msg = logWithLevel Info (message msg)
error_ :: Log :> es => Rate -> Message -> Eff es ()
error_ rate msg = logWithLevel (Error rate) (message msg)
runDiIO :: (IOE :> es) => Di Level Path Message -> Eff (Log : es) a -> Eff es a
runDiIO di =
reinterpret (runReader di) $ \env -> \case
Attr_ kk value action -> adaptDf1 (DiDf1.attr_ kk value) action env
Push_ segment action -> adaptDf1 (DiDf1.push segment) action env
Filter pred action -> adaptDf1 (Di.filter pred) action env
LogWithLevel level msg -> do
di' <- Reader.ask @(Di Level Path Message)
Di.log di' level msg
Flush -> do
di' <- Reader.ask @(Di Level Path Message)
Di.flush di'
AskLogFn -> do
di' <- Reader.ask @(Di Level Path Message)
pure (Di.log di')
where
adaptDf1 modifyDf1 action env = do
unliftStrat <- Effectful.unliftStrategy
localUnlift env unliftStrat $ \unlift ->
Reader.local @(Di Level Path Message) modifyDf1 $ unlift action
runConsole :: (IOE :> es) => Level -> Eff (Log : es) a -> Eff es a
runConsole level action = do
writeLog <- DiHandle.stderr lineRenderer
Di.new writeLog (\di -> runDiIO di $ do
val <- filteredAction
flush
pure val)
where
filteredAction = filter (\msgLevel _ _ -> msgLevel >= level) action
runConsole_ :: (IOE :> es) => Eff (Log : es) a -> Eff es a
runConsole_ = runConsole (Level.Error Level.Rate)
runNoop :: Eff (Log : es) a -> Eff es a
runNoop =
interpret $ \env -> \case
Attr_ _ _ action -> adapt action env
Push_ _ action -> adapt action env
Filter _ action -> adapt action env
LogWithLevel _ _ -> pure ()
Flush -> pure ()
AskLogFn -> pure (\_ _ -> pure ())
where
adapt action env = localSeqUnlift env (\unlift ->
unlift action)
-- TODO: systemd journal
-- https://github.com/ocharles/libsystemd-journal
lineRenderer :: DiHandle.LineRenderer Level Path Message
lineRenderer = DiHandle.LineRendererUtf8 render
where
renderDf1 = case DiDf1.df1 of
DiHandle.LineRendererUtf8 renderDf1' -> renderDf1'
render supportsColors log =
renderDf1 supportsColors log{
log_level =
log
& log_level
& Level.toDf1
} and provide the data Aws' withAuth :: Effect where
SendEither ::
(AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Aws' Identity m (Either Amazonka.Error (AWSResponse a))
AwaitEither ::
(AWSRequest a, Typeable a) =>
Amazonka.Wait a
-> a
-> Aws' Identity m (Either Amazonka.Error Amazonka.Accept)
-- TODO: paginateEither
SendUnsignedEither ::
(AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Aws' withAuth m (Either Amazonka.Error (AWSResponse a))
LocalEnv' ::
(Amazonka.Env' withAuth -> Amazonka.Env' withAuth)
-> m a
-> Aws' withAuth m a
type Aws = Aws' Identity
type AwsNoAuth = Aws' Proxy
run ::
forall withAuth a es.
(IOE :> es, Resource :> es) =>
Amazonka.Env' withAuth
-> Eff (Aws' withAuth : es) a
-> Eff es a
run awsEnv = reinterpret (runReader awsEnv) $ \env -> \case
SendEither req -> adapt @withAuth (\env -> Amazonka.sendEither env req)
AwaitEither waiter req -> adapt @withAuth (\env -> Amazonka.awaitEither env waiter req)
SendUnsignedEither req -> adapt @withAuth (\env -> Amazonka.sendUnsignedEither env req)
LocalEnv' f action -> do
unliftStrat <- Effectful.unliftStrategy
Reader.local @(Amazonka.Env' withAuth)
f
(localUnlift env unliftStrat $ \unlift -> unlift action)
where
adapt ::
forall withAuth' a' es'.
(Reader (Amazonka.Env' withAuth') :> es') =>
(Amazonka.Env' withAuth' -> Eff es' a')
-> Eff es' a'
adapt envToAction = do
env <- Reader.ask @(Amazonka.Env' withAuth')
envToAction env
I have been able to write the following function to try and inject withLogs ::
forall withAuth a es.
( IOE :> es
, HasCallStack
, Log :> es
, Aws' withAuth :> es
) =>
Eff es a
-> Eff es a
withLogs = Dynamic.interpose @(Aws' withAuth) $ \env awsOp -> do
unliftStrat <- Effectful.unliftStrategy
awsLogger <- localLend @Log env unliftStrat $ \useLog -> localUnliftIO env unliftStrat $ \intoIO -> do
pure
( ( \awsLevel binBuilder -> do
intoIO $
useLog $
Log.logWithLevel
(convertLogLevel awsLevel)
(toLogMessage binBuilder)
) :: Amazonka.Logger
)
localEnv' @withAuth (#logger .~ awsLogger) $ localUnlift env unliftStrat $ \unlift -> unlift $ Dynamic.send awsOp
where
convertLogLevel :: Amazonka.LogLevel -> Log.Level
convertLogLevel = ...
toLogMessage :: Lazy.BinaryBuilder -> Log.Message
toLogMessage = ... Full (of wip nonsense) `Effect/Amazonka.hs`:{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLabels #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Avoid lambda using `infix`" #-}
module Yf.Effect.Amazonka (
-- Effect types
Aws',
Aws,
AwsNoAuth,
-- Runners
run,
withLogs,
runDiscover,
run,
-- Effects
sendEither,
sendUnsignedEither,
awaitEither,
) where
import Prelude hiding (Reader, error, filter, runReader)
import Data.Binary.Builder qualified as BinaryBuilder
import Data.Text.Encoding.Error qualified as TextEncodeError
import Data.Text.Lazy.Encoding qualified as TLE
import Effectful (
DispatchOf,
Eff,
Effect,
IOE,
Limit (Unlimited),
Persistence (Persistent),
UnliftStrategy (ConcUnlift),
inject,
(:>),
)
import Effectful qualified as Effectful
import Effectful.Dispatch.Dynamic (
interpret,
localLend,
localLiftUnliftIO,
localSeqUnlift,
localUnlift,
localUnliftIO,
reinterpret,
)
import Effectful.Dispatch.Dynamic qualified as Dynamic
import Effectful.Reader.Dynamic (Reader (), runReader)
import Effectful.Reader.Dynamic as Reader
import Effectful.Resource (Resource)
import Effectful.Resource qualified as Resource
import Effectful.TH (makeEffect)
import Optics
import Yf.Effect.Log (Log)
import Yf.Effect.Log qualified as Log
import Amazonka (AWSRequest, AWSResponse)
import Amazonka qualified as Amazonka
import Effectful.Dispatch.Static (SideEffects (NoSideEffects))
import Type.Reflection (Typeable)
import GHC.Stack (callStack, prettyCallStack)
data Aws' withAuth :: Effect where
SendEither ::
(AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Aws' Identity m (Either Amazonka.Error (AWSResponse a))
AwaitEither ::
(AWSRequest a, Typeable a) =>
Amazonka.Wait a
-> a
-> Aws' Identity m (Either Amazonka.Error Amazonka.Accept)
-- TODO: paginateEither
SendUnsignedEither ::
(AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Aws' withAuth m (Either Amazonka.Error (AWSResponse a))
LocalEnv' ::
(Amazonka.Env' withAuth -> Amazonka.Env' withAuth)
-> m a
-> Aws' withAuth m a
type Aws = Aws' Identity
type AwsNoAuth = Aws' Proxy
type instance DispatchOf (Aws' withAuth) = Effectful.Dynamic
localEnv' ::
forall withAuth a es.
(Aws' withAuth :> es) =>
(Amazonka.Env' withAuth -> Amazonka.Env' withAuth)
-> Eff es a
-> Eff es a
localEnv' f action = Dynamic.send (LocalEnv' f action)
-- localEnv' f action = send (LocalEnv' f action)
--
-- localEnv ::
-- forall newAuth currentAuth a es.
-- (Amazonka.Env' currentAuth -> Amazonka.Env' newAuth)
-- -> Eff (Aws' newAuth : es) a
-- -> Eff (Aws' currentAuth : es) a
-- localEnv f a = localEnv' f (rewrite a)
-- where
-- rewrite :: Eff (Aws' newAuth : es) -> Eff (Aws' currentAuth : es) (Eff '[Aws' newAuth] a)
-- rewrite =
sendEither ::
(HasCallStack, Aws :> es, AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Eff es (Either Amazonka.Error (AWSResponse a))
sendEither req = Dynamic.send (SendEither req)
awaitEither ::
(HasCallStack, Aws :> es, AWSRequest a, Typeable a) =>
Amazonka.Wait a
-> a
-> Eff es (Either Amazonka.Error Amazonka.Accept)
awaitEither wait req = Dynamic.send (AwaitEither wait req)
sendUnsignedEither ::
forall withAuth a es.
(HasCallStack, Aws' withAuth :> es, AWSRequest a, Typeable a, Typeable (AWSResponse a)) =>
a
-> Eff es (Either Amazonka.Error (AWSResponse a))
sendUnsignedEither req = Dynamic.send (SendUnsignedEither @a @withAuth req)
run ::
forall withAuth a es.
(IOE :> es, Resource :> es) =>
Amazonka.Env' withAuth
-> Eff (Aws' withAuth : es) a
-> Eff es a
run awsEnv = reinterpret (runReader awsEnv) $ \env -> \case
SendEither req -> adapt @withAuth (\env -> Amazonka.sendEither env req)
AwaitEither waiter req -> adapt @withAuth (\env -> Amazonka.awaitEither env waiter req)
SendUnsignedEither req -> adapt @withAuth (\env -> Amazonka.sendUnsignedEither env req)
LocalEnv' f action -> do
unliftStrat <- Effectful.unliftStrategy
Reader.local @(Amazonka.Env' withAuth)
f
(localUnlift env unliftStrat $ \unlift -> unlift action)
where
adapt ::
forall withAuth' a' es'.
(Reader (Amazonka.Env' withAuth') :> es') =>
(Amazonka.Env' withAuth' -> Eff es' a')
-> Eff es' a'
adapt envToAction = do
env <- Reader.ask @(Amazonka.Env' withAuth')
envToAction env
withLogs ::
forall withAuth a es.
( IOE :> es
, HasCallStack
, Log :> es
, Aws' withAuth :> es
) =>
Eff es a
-> Eff es a
withLogs = Dynamic.interpose @(Aws' withAuth) $ \env awsOp -> do
-- Log.push "(amazonka)" $ do
-- logFn <- Log.askLogFn
-- putStrLn $ prettyCallStack $ callStack
unliftStrat <- Effectful.unliftStrategy
-- localLend env unliftStrat $ \lendLog -> $ \intoIO -> lendLog $ do
-- intoIO $ Log.push "(amazonka)"
awsLogger <- localLend @Log env unliftStrat $ \useLog -> localUnliftIO env unliftStrat $ \intoIO -> do
pure
( ( \awsLevel binBuilder -> do
intoIO $
useLog $
Log.logWithLevel
(convertLogLevel awsLevel)
( BinaryBuilder.toLazyByteString binBuilder
& TLE.decodeUtf8With TextEncodeError.lenientDecode
& Log.message
)
) ::
Amazonka.Logger
)
localEnv' @withAuth (#logger .~ awsLogger) $ localUnlift env unliftStrat $ \unlift -> unlift $ Dynamic.send awsOp
where
convertLogLevel :: Amazonka.LogLevel -> Log.Level
convertLogLevel = \case
Amazonka.Error -> Log.Error Log.Rate
Amazonka.Info -> Log.Info
Amazonka.Debug -> Log.Debug
Amazonka.Trace -> Log.TraceSensitive
runDiscover ::
(IOE :> es, Log :> es, Resource :> es) =>
Eff (Aws : es) a
-> Eff es a
runDiscover action = do
env <- Amazonka.newEnv Amazonka.discover
action
& withLogs @Identity
& run env My current suspicion is that the Notes:
(expand)
|
Beta Was this translation helpful? Give feedback.
Replies: 1 comment 4 replies
-
Unrelated, but using
This is correct. By sending in the local environment you're sending to the newest handler, which is most likely the one you're currently defining, so it'll just loop. The last line should be Though I don't see why you need the withLogs ::
forall withAuth a es.
( IOE :> es
, HasCallStack
, Log :> es
, Aws' withAuth :> es
) =>
Eff es a
-> Eff es a
withLogs action = do
awsLogger <- withSeqEffToIO $ \intoIO -> do
pure
( ( \awsLevel binBuilder -> do
intoIO $
useLog $
Log.logWithLevel
(convertLogLevel awsLevel)
(toLogMessage binBuilder)
) :: Amazonka.Logger
)
localEnv' @withAuth (#logger .~ awsLogger) action
where
convertLogLevel :: Amazonka.LogLevel -> Log.Level
convertLogLevel = ...
toLogMessage :: Lazy.BinaryBuilder -> Log.Message
toLogMessage = ... |
Beta Was this translation helpful? Give feedback.
Unrelated, but using
unliftStrategy
fromIOE
for local unlifts is incorrect. The type of unlift only depends locally on the functions you're unlifting. Well, ok, not quite if you use the unlifting function out of its scope like inwithLogs
because who knows where it's going to end up being called, but then ifSeqUnlift
doesn't work, you can just useConcUnlift
for it. You can definitely use localSeqUnlift for unliftinglocal
inLocalEnv'
.This is correct. By sending in the local environment you're sending to the newest handler, which is most likely the one you'…