diff --git a/spago.yaml b/spago.yaml index a8c16f6..9f7ff9e 100644 --- a/spago.yaml +++ b/spago.yaml @@ -1,21 +1,36 @@ package: dependencies: - - prelude - aff + - console - effect - either - - maybe - foldable-traversable - - console + - fork + - maybe + - mmorph - newtype + - node-buffer + - node-fs + - node-process + - prelude + - simple-json - strings - stringutils + - sync - transformers - tuples - typelevel-prelude + - unlift name: project workspace: - extra_packages: {} + extra_packages: + sync: + dependencies: + - aff + - arrays + - avar + git: https://git.orionkindel.com/orion/purescript-sync.git + ref: 'fe21a2e' package_set: url: https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.10-20230930/packages.json hash: sha256-nTsd44o7/hrTdk0c6dh0wyBqhFFDJJIeKdQU6L1zv/A= diff --git a/src/Control.Monad.Log.purs b/src/Control.Monad.Log.purs new file mode 100644 index 0000000..6a51727 --- /dev/null +++ b/src/Control.Monad.Log.purs @@ -0,0 +1,199 @@ +module Control.Monad.Log where + +import Prelude + +import Control.Alt ((<|>)) +import Control.Alternative (class Alt, class Alternative, class Plus) +import Control.Monad.Cont (class MonadCont) +import Control.Monad.Error.Class (class MonadError, class MonadThrow, catchError, throwError) +import Control.Monad.Except (runExcept) +import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible) +import Control.Monad.Morph (class MFunctor, class MMonad, embed, hoist) +import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask, asks, local) +import Control.Monad.Rec.Class (class MonadRec) +import Control.Monad.State.Async (asyncGet, runWith) +import Control.Monad.Trans.Class (class MonadTrans, lift) +import Control.Monad.Writer (class MonadTell, class MonadWriter) +import Control.MonadPlus (class MonadPlus) +import Control.Parallel (class Parallel, parallel, sequential) +import Data.Array.NonEmpty as Array.NonEmpty +import Data.Array.NonEmpty.Internal (NonEmptyArray) +import Data.Async.RwLock (RwLock) +import Data.Either (either) +import Data.List (List) +import Data.Log (Log) +import Data.Log as Log +import Data.Maybe (Maybe(..), fromMaybe, maybe) +import Data.Newtype (class Newtype, unwrap, wrap) +import Data.Traversable (sequence_) +import Effect.Aff (Aff, launchAff_) +import Effect.Aff.Class (class MonadAff, liftAff) +import Effect.Aff.Unlift (class MonadUnliftAff, UnliftAff(..), withUnliftAff) +import Effect.Class (class MonadEffect, liftEffect) +import Effect.Exception (Error, error) +import Effect.Exception as Error +import Effect.Unlift (class MonadUnliftEffect) +import Foreign (readString, tagOf, unsafeReadTagged) +import Node.EventEmitter as Event +import Node.Process (uncaughtExceptionH, unhandledRejectionH) +import Node.Process as Process + +type LogR = + { actor :: + { dev :: String + , thread :: Maybe String + } + , context :: + NonEmptyArray + { path :: String + , context :: Array String + } + , buffer :: RwLock (List Log) + , outputs :: Array (Log.Log -> Aff Unit) + } + +newtype LogT :: (Type -> Type) -> Type -> Type +newtype LogT m a = LogT (ReaderT LogR m a) + +derive instance Newtype (LogT m a) _ +derive newtype instance Functor m => Functor (LogT m) +derive newtype instance (Plus m) => Plus (LogT m) +derive newtype instance (Plus m, Alternative m) => Alternative (LogT m) +derive newtype instance Alt m => Alt (LogT m) +derive newtype instance Apply m => Apply (LogT m) +derive newtype instance Applicative m => Applicative (LogT m) +derive newtype instance Bind m => Bind (LogT m) +derive newtype instance Monad m => Monad (LogT m) +derive newtype instance (Apply m, Semigroup a) => Semigroup (LogT m a) +derive newtype instance (Applicative m, Monoid a) => Monoid (LogT m a) +derive newtype instance (MonadPlus m) => MonadPlus (LogT m) +derive newtype instance (MonadEffect m) => MonadEffect (LogT m) +derive newtype instance (MonadAff m) => MonadAff (LogT m) +derive newtype instance Monad m => MonadReader LogR (LogT m) +derive newtype instance Monad m => MonadAsk LogR (LogT m) +derive newtype instance MonadCont m => MonadCont (LogT m) +derive newtype instance MonadTell w m => MonadTell w (LogT m) +derive newtype instance MonadWriter w m => MonadWriter w (LogT m) +derive newtype instance MonadRec m => MonadRec (LogT m) +derive newtype instance MonadError e m => MonadError e (LogT m) +derive newtype instance MonadThrow e m => MonadThrow e (LogT m) +derive newtype instance MonadUnliftAff m => MonadUnliftAff (LogT m) +derive newtype instance MonadUnliftEffect m => MonadUnliftEffect (LogT m) +derive newtype instance MonadFork f m => MonadFork f (LogT m) + +instance MonadKill e f m => MonadKill e f (LogT m) where + kill e f = wrap $ kill e f + +instance (MonadKill e f (LogT m), MonadError e (LogT m), MonadKill e f m, MonadError e m, MonadBracket e f m) => MonadBracket e f (LogT m) where + bracket acq rel m = wrap $ bracket (unwrap acq) (\b r -> unwrap $ rel b r) (unwrap <<< m) + uninterruptible = wrap <<< uninterruptible <<< unwrap + never = wrap $ never + +instance (Parallel f m) => Parallel (LogT f) (LogT m) where + parallel = wrap <<< parallel <<< unwrap + sequential = wrap <<< sequential <<< unwrap + +instance MonadTrans LogT where + lift = wrap <<< lift + +instance MFunctor LogT where + hoist f = wrap <<< hoist f <<< unwrap + +instance MMonad LogT where + embed f = wrap <<< embed (unwrap <<< f) <<< unwrap + +-- | A monad which can perform logs +-- | +-- | #### Stores +-- | - context - a stack trace of module paths and trace of "things being done" in those modules +-- | - actor - device / thread ID pair +-- | - outputs - actual renderers of log messages +class (MonadAff m) <= MonadLog m where + log :: Log.Level -> String -> m Unit + + logs :: m (List Log) + + getOutputs :: m (Array (Log.Log -> Aff Unit)) + getContext :: m (NonEmptyArray { path :: String, context :: Array String }) + getActor :: m { dev :: String, thread :: Maybe String } + + path :: forall a. String -> m a -> m a + context :: forall a. String -> m a -> m a + thread :: forall a. String -> m a -> m a + +instance (MonadAff m, MonadError e m) => MonadLog (LogT m) where + getOutputs = map _.outputs $ ask + getContext = map _.context $ ask + getActor = map _.actor $ ask + context c = + let + withContext r = + let + init = Array.NonEmpty.fromArray $ Array.NonEmpty.init r.context + last = Array.NonEmpty.last r.context + newLast = last { context = last.context <> [ c ] } + in + r { context = maybe (pure newLast) (_ <> pure newLast) init } + in + local withContext + path p = + let + withPath r = r { context = r.context <> pure { path: p, context: [] } } + in + local withPath + thread t = + let + withThread r = r { actor = r.actor { thread = Just t } } + in + local withThread + logs = do + buf <- asks _.buffer + runWith buf asyncGet + log level msg = do + outputs' <- getOutputs + actor <- getActor + context <- getContext + liftAff $ sequence_ $ outputs' <*> [ Log.Log { level, msg, actor: wrap actor, context } ] +else instance (MonadAff (t l), MMonad t, MonadLog l) => MonadLog (t l) where + logs = lift logs + getOutputs = lift getOutputs + getActor = lift getActor + getContext = lift getContext + path = hoist <<< path + thread = hoist <<< thread + context = hoist <<< context + log l m = lift $ log l m + +runLog :: forall m a. { buffer :: RwLock (List Log), outputs :: Array (Log.Log -> Aff Unit), dev :: String } -> LogT m a -> m a +runLog { buffer, outputs, dev } t = (unwrap $ unwrap t) { outputs, actor: { dev, thread: Nothing }, context: pure { path: "Main", context: [] }, buffer } + +logError :: forall m. MonadLog m => Error -> m Unit +logError e = + let + msg = Error.message e + stack = fromMaybe "" $ Error.stack e + in + log Log.Error $ msg <> "\n" <> stack + +withLogError :: forall m a. MonadError Error m => MonadLog m => m a -> m a +withLogError = flip catchError \e -> do + logError e + throwError e + +catchLog :: forall m. MonadError Error m => MonadLog m => m Unit -> m Unit +catchLog = flip catchError \e -> do + logError e + +logUnhandled :: forall m. MonadUnliftAff m => MonadLog m => MonadAff m => m Unit +logUnhandled = + let + tryError e = unsafeReadTagged "Error" e + tryString e = error <$> readString e + fallthrough e = error $ "unknown error type: " <> tagOf e + coerceError e = either (const $ fallthrough e) identity $ runExcept (tryError e <|> tryString e) + in + withUnliftAff \(UnliftAff mToAff) -> do + let + launchM = launchAff_ <<< mToAff + liftEffect $ Event.on_ uncaughtExceptionH (\e _ -> launchM $ logError e) Process.process + liftEffect $ Event.on_ unhandledRejectionH (\f _ -> launchM $ logError $ coerceError f) Process.process diff --git a/src/Data.Log.Backend.js b/src/Data.Log.Backend.js new file mode 100644 index 0000000..555b565 --- /dev/null +++ b/src/Data.Log.Backend.js @@ -0,0 +1,2 @@ +/** @type {(a: T) => string} */ +export const _prettyJson = a => JSON.stringify(a, null, 2) diff --git a/src/Data.Log.Backend.purs b/src/Data.Log.Backend.purs new file mode 100644 index 0000000..2800591 --- /dev/null +++ b/src/Data.Log.Backend.purs @@ -0,0 +1,92 @@ +module Data.Log.Backend where + +import Prelude + +import Control.Monad.State.Async as AsyncState +import Data.Array.NonEmpty as Array.NonEmpty +import Data.Async.RwLock (RwLock) +import Data.DateTime.Instant (Instant) +import Data.DateTime.Instant as Instant +import Data.Foldable (intercalate) +import Data.JSDate as Date +import Data.List (List) +import Data.List as List +import Data.Log.Types (Actor(..), Level(..), Log, actor, context, level, message) +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Newtype (unwrap) +import Effect (Effect) +import Effect.Aff (Aff) +import Effect.Class (liftEffect) +import Effect.Console as Console +import Effect.Now as Now +import Effect.Unsafe (unsafePerformEffect) +import Node.Buffer as Buffer +import Node.Encoding (Encoding(..)) +import Node.FS.Aff as FS +import Simple.JSON (class WriteForeign, writeImpl) + +foreign import _prettyJson :: forall a. a -> String + +pretty :: Log -> String +pretty log = + let + level' = case level log of + Debug -> "[DEBUG]" + Trace -> "[TRACE]" + Info -> "[INFO ]" + Warn -> "[WARN ]" + Error -> "[ERROR]" + actor' = case actor log of Actor { thread } -> fromMaybe "" thread + context' = (\{ path: p, context: cs } -> show p <> " " <> (intercalate " > " cs)) $ Array.NonEmpty.last $ context log + in + intercalate "" [ level', actor', context', message log ] + +json :: Instant -> Log -> String +json now log = do + prettyJson + { level: show $ level log + , context: context log + , message: message log + , ts: unwrap $ Instant.unInstant now + , time: unsafePerformEffect $ Date.toISOString $ Date.fromInstant now + , actor: unwrap $ actor log + } + +prettyJson :: forall a. WriteForeign a => a -> String +prettyJson = _prettyJson <<< writeImpl + +consoleMethod :: Level -> String -> Effect Unit +consoleMethod lv = case lv of + Debug -> Console.debug + Trace -> Console.debug + Info -> Console.log + Warn -> Console.warn + Error -> Console.error + +backendFromString :: Level -> String -> Maybe (Log -> Aff Unit) +backendFromString filter "console_pretty" = Just $ backendConsolePretty filter +backendFromString filter "console_json" = Just $ backendConsoleJSON filter +backendFromString _ "json_file" = Just $ backendJSONFile ".log" +backendFromString _ _ = Nothing + +backendBuffer :: RwLock (List Log) -> Log -> Aff Unit +backendBuffer rwlock log = + AsyncState.runWith rwlock + $ AsyncState.asyncModify + $ pure <<< List.Cons log + +backendConsolePretty :: Level -> Log -> Aff Unit +backendConsolePretty filter log = when (level log >= filter) $ liftEffect $ consoleMethod (level log) $ pretty log + +backendConsoleJSON :: Level -> Log -> Aff Unit +backendConsoleJSON filter log = do + now <- liftEffect Now.now + when (level log >= filter) $ liftEffect $ consoleMethod (level log) (json now log <> "\n") + +backendJSONFile :: String -> Log -> Aff Unit +backendJSONFile path log = do + now <- liftEffect Now.now + let + line = json now log <> "\n" + lineBuf <- liftEffect $ Buffer.fromString line UTF8 + FS.appendFile path lineBuf diff --git a/src/Data.Log.Types.purs b/src/Data.Log.Types.purs new file mode 100644 index 0000000..7f302af --- /dev/null +++ b/src/Data.Log.Types.purs @@ -0,0 +1,105 @@ +module Data.Log.Types where + +import Prelude + +import Data.Array.NonEmpty (NonEmptyArray) +import Data.Bounded.Generic (genericBottom, genericTop) +import Data.Enum (class BoundedEnum, class Enum) +import Data.Enum.Generic (genericCardinality, genericFromEnum, genericPred, genericSucc, genericToEnum) +import Data.Generic.Rep (class Generic) +import Data.Maybe (Maybe(..)) +import Data.Newtype (class Newtype, unwrap) +import Data.Show.Generic (genericShow) +import Data.String as String +import Simple.JSON (class WriteForeign, writeImpl) + +-- | An identifier describing a combination of device (computer) and thread +newtype Actor = Actor + { dev :: String + , thread :: Maybe String + } + +derive instance Newtype Actor _ +derive instance Generic Actor _ +instance Show Actor where + show = genericShow + +instance WriteForeign Actor where + writeImpl = writeImpl <<< unwrap + +data Level + = Debug + | Trace + | Info + | Warn + | Error + +derive instance Generic Level _ +derive instance Eq Level +derive instance Ord Level +instance Enum Level where + succ = genericSucc + pred = genericPred + +instance Bounded Level where + top = genericTop + bottom = genericBottom + +instance BoundedEnum Level where + cardinality = genericCardinality + toEnum = genericToEnum + fromEnum = genericFromEnum + +instance Show Level where + show = genericShow + +instance WriteForeign Level where + writeImpl = writeImpl <<< String.toLower <<< show + +levelFromString :: String -> Maybe Level +levelFromString = + let + impl "default" = Just Info + impl "info" = Just Info + impl "trace" = Just Trace + impl "verbose" = Just Trace + impl "v" = Just Trace + impl "vv" = Just Debug + impl "vverbose" = Just Debug + impl "veryverbose" = Just Debug + impl "very-verbose" = Just Debug + impl "debug" = Just Debug + impl "warn" = Just Warn + impl "warning" = Just Warn + impl "warnings" = Just Warn + impl "err" = Just Error + impl "quiet" = Just Error + impl "error" = Just Error + impl "errors" = Just Error + impl _ = Nothing + in + impl <<< String.toLower + +newtype Log = Log + { context :: NonEmptyArray { path :: String, context :: Array String } + , actor :: Actor + , msg :: String + , level :: Level + } + +derive instance Newtype Log _ + +instance WriteForeign Log where + writeImpl = writeImpl <<< unwrap + +level :: Log -> Level +level (Log r) = r.level + +actor :: Log -> Actor +actor (Log r) = r.actor + +message :: Log -> String +message (Log r) = r.msg + +context :: Log -> NonEmptyArray { path :: String, context :: Array String } +context (Log r) = r.context diff --git a/src/Data.Log.purs b/src/Data.Log.purs new file mode 100644 index 0000000..fd6895e --- /dev/null +++ b/src/Data.Log.purs @@ -0,0 +1,5 @@ +module Data.Log + ( module X + ) where + +import Data.Log.Types (Actor(..), Level(..), Log(..), actor, context, level, levelFromString, message) as X diff --git a/src/Main.purs b/src/Main.purs deleted file mode 100644 index ee561ac..0000000 --- a/src/Main.purs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Prelude -import Effect (Effect) - -main :: Effect Unit -main = pure unit