From 0b06dda9a6a31954e5add72cad3562c446d92a35 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 16 Mar 2024 14:17:24 +0100 Subject: refactor(users/Profpatsch/whatcd-resolver): move AppT & Html out These functions are just general setup and html helpers, the main file is getting a bit long otherwise. Change-Id: I194e9f7f4caa4ce204d510c885dcf5af63d0e76e Reviewed-on: https://cl.tvl.fyi/c/depot/+/11165 Autosubmit: Profpatsch Reviewed-by: Profpatsch Tested-by: BuildkiteCI --- users/Profpatsch/whatcd-resolver/default.nix | 2 + users/Profpatsch/whatcd-resolver/src/AppT.hs | 120 ++++++++++++++ users/Profpatsch/whatcd-resolver/src/Html.hs | 69 ++++++++ .../whatcd-resolver/src/WhatcdResolver.hs | 183 ++------------------- .../whatcd-resolver/whatcd-resolver.cabal | 10 +- 5 files changed, 212 insertions(+), 172 deletions(-) create mode 100644 users/Profpatsch/whatcd-resolver/src/AppT.hs create mode 100644 users/Profpatsch/whatcd-resolver/src/Html.hs (limited to 'users') diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index 17b6505c87..d209d65876 100644 --- a/users/Profpatsch/whatcd-resolver/default.nix +++ b/users/Profpatsch/whatcd-resolver/default.nix @@ -11,6 +11,8 @@ let ./whatcd-resolver.cabal ./Main.hs ./src/WhatcdResolver.hs + ./src/AppT.hs + ./src/Html.hs ]; libraryHaskellDepends = [ diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs new file mode 100644 index 0000000000..bc94fc4ed5 --- /dev/null +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module AppT where + +import Control.Monad.Logger qualified as Logger +import Control.Monad.Logger.CallStack +import Control.Monad.Reader +import Data.Error.Tree +import Data.HashMap.Strict qualified as HashMap +import Data.Pool (Pool) +import Data.Text qualified as Text +import Database.PostgreSQL.Simple qualified as Postgres +import GHC.Stack qualified +import Label +import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') +import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') +import OpenTelemetry.Trace.Monad qualified as Otel +import PossehlAnalyticsPrelude +import Postgres.MonadPostgres +import System.IO qualified as IO +import Tool (Tool) +import UnliftIO +import Prelude hiding (span) + +data Context = Context + { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, + tracer :: Otel.Tracer, + pgFormat :: Tool, + pgConnPool :: Pool Postgres.Connection, + transmissionSessionId :: MVar ByteString + } + +newtype AppT m a = AppT {unAppT :: ReaderT Context m a} + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow) + +data AppException = AppException Text + deriving stock (Show) + deriving anyclass (Exception) + +-- * Logging & Opentelemetry + +instance (MonadIO m) => MonadLogger (AppT m) where + monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg) + +instance (Monad m) => Otel.MonadTracer (AppT m) where + getTracer = AppT $ asks (.tracer) + +inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a +inSpan name = Otel.inSpan name Otel.defaultSpanArguments + +inSpan' :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> (Otel.Span -> m a) -> m a +inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments + +appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a +appThrowTree span exc = do + let msg = prettyErrorTree exc + recordException + span + ( T2 + (label @"type_" "AppException") + (label @"message" msg) + ) + throwM $ AppException msg + +orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a +orAppThrowTree span = \case + Left err -> appThrowTree span err + Right a -> pure a + +assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a +assertM span f v = case f v of + Right a -> pure a + Left err -> appThrowTree span err + +-- | A specialized variant of @addEvent@ that records attributes conforming to +-- the OpenTelemetry specification's +-- +-- +-- @since 0.0.1.0 +recordException :: + ( MonadIO m, + HasField "message" r Text, + HasField "type_" r Text + ) => + Otel.Span -> + r -> + m () +recordException span dat = liftIO $ do + callStack <- GHC.Stack.whoCreated dat.message + newEventTimestamp <- Just <$> Otel.getTimestamp + Otel.addEvent span $ + Otel.NewEvent + { newEventName = "exception", + newEventAttributes = + HashMap.fromList + [ ("exception.type", Otel.toAttribute @Text dat.type_), + ("exception.message", Otel.toAttribute @Text dat.message), + ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack) + ], + .. + } + +-- * Postgres + +instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where + execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + execute_ = executeImpl_ (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + queryWith_ = queryWithImpl_ (AppT ask) + foldRows = foldRowsImpl (AppT ask) + runTransaction = runPGTransaction + +runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a +runPGTransaction (Transaction transaction) = do + pool <- AppT ask <&> (.pgConnPool) + withRunInIO $ \unliftIO -> + withPGTransaction pool $ \conn -> do + unliftIO $ runReaderT transaction conn diff --git a/users/Profpatsch/whatcd-resolver/src/Html.hs b/users/Profpatsch/whatcd-resolver/src/Html.hs new file mode 100644 index 0000000000..49b87b23dc --- /dev/null +++ b/users/Profpatsch/whatcd-resolver/src/Html.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Html where + +import Data.Aeson qualified as Json +import Data.Aeson.KeyMap qualified as KeyMap +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import IHP.HSX.QQ (hsx) +import PossehlAnalyticsPrelude +import Text.Blaze.Html (Html) +import Text.Blaze.Html5 qualified as Html +import Prelude hiding (span) + +-- | Render an arbitrary json value to HTML in a more-or-less reasonable fashion. +mkVal :: Json.Value -> Html +mkVal = \case + Json.Number n -> Html.toHtml @Text $ showToText n + Json.String s -> Html.toHtml @Text s + Json.Bool True -> [hsx|true|] + Json.Bool False -> [hsx|false|] + Json.Null -> [hsx|null|] + Json.Array arr -> toOrderedList mkVal arr + Json.Object obj -> + obj + & KeyMap.toMapText + & toDefinitionList (Html.toHtml @Text) mkVal + +toOrderedList :: (Foldable t1) => (t2 -> Html) -> t1 t2 -> Html +toOrderedList mkValFn arr = + arr + & foldMap (\el -> Html.li $ mkValFn el) + & Html.ol + +toUnorderedList :: (Foldable t1) => (t2 -> Html) -> t1 t2 -> Html +toUnorderedList mkValFn arr = + arr + & foldMap (\el -> Html.li $ mkValFn el) + & Html.ul + +-- | Render a definition list from a Map +toDefinitionList :: (Text -> Html) -> (t -> Html) -> Map Text t -> Html +toDefinitionList mkKeyFn mkValFn obj = + obj + & Map.toList + & foldMap (\(k, v) -> Html.dt (mkKeyFn k) <> Html.dd (mkValFn v)) + & Html.dl + +-- | Render a table-like structure of json values as an HTML table. +toTable :: [[(Text, Json.Value)]] -> Html +toTable xs = + case xs & nonEmpty of + Nothing -> + [hsx|

No results.

|] + Just xs' -> do + let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|{h}|]) & mconcat + let vals = xs' & foldMap (Html.tr . foldMap (Html.td . mkVal . snd)) + [hsx| + + + + {headers} + + + + {vals} + +
+ |] diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 6866d387cb..e5d6ba5f80 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -1,13 +1,10 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} module WhatcdResolver where +import AppT import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) -import Control.Monad.Logger qualified as Logger import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json @@ -19,7 +16,6 @@ import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map -import Data.Pool (Pool) import Data.Pool qualified as Pool import Data.Set (Set) import Data.Set qualified as Set @@ -32,7 +28,7 @@ import Database.Postgres.Temp qualified as TmpPg import FieldParser (FieldParser, FieldParser' (..)) import FieldParser qualified as Field import GHC.Records (HasField (..)) -import GHC.Stack qualified +import Html qualified import IHP.HSX.QQ (hsx) import Json qualified import Json.Enc (Enc) @@ -49,7 +45,6 @@ import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Parse qualified as Wai import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') -import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import Parse (Parse) import Parse qualified @@ -62,12 +57,11 @@ import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.Environment qualified as Env import System.FilePath (()) -import System.IO qualified as IO import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 qualified as Html -import Tool (Tool, readTool, readTools) +import Tool (readTool, readTools) import UnliftIO import Prelude hiding (span) @@ -144,7 +138,7 @@ htmlUi = do snipsRedactedSearch dat "snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do dat <- torrentIdMp span - mkVal <$> (runTransaction $ getTorrentById dat) + Html.mkVal <$> (runTransaction $ getTorrentById dat) "snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \span -> do dat <- torrentIdMp span runTransaction $ do @@ -449,7 +443,7 @@ renderJsonld = \case
{obj.id_}
Fields
- {obj.previewFields & toDefinitionList schemaType renderJsonld} + {obj.previewFields & Html.toDefinitionList schemaType renderJsonld}