diff options
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/default.nix | 2 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/AppT.hs | 120 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Html.hs | 69 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 183 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal | 10 |
5 files changed, 212 insertions, 172 deletions
diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index 17b6505c8777..d209d6587626 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 000000000000..bc94fc4ed583 --- /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 +-- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions> +-- +-- @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 000000000000..49b87b23dc1a --- /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|<em>true</em>|] + Json.Bool False -> [hsx|<em>false</em>|] + Json.Null -> [hsx|<em>null</em>|] + 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|<p>No results.</p>|] + Just xs' -> do + let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|<th>{h}</th>|]) & mconcat + let vals = xs' & foldMap (Html.tr . foldMap (Html.td . mkVal . snd)) + [hsx| + <table class="table"> + <thead> + <tr> + {headers} + </tr> + </thead> + <tbody> + {vals} + </tbody> + </table> + |] diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 6866d387cb0c..e5d6ba5f802f 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 <dd><a href={obj.id_}>{obj.id_}</a></dd> <dt>Fields</dt> <dd> - {obj.previewFields & toDefinitionList schemaType renderJsonld} + {obj.previewFields & Html.toDefinitionList schemaType renderJsonld} <div> <button hx-get={snippetHref obj.id_} @@ -474,8 +468,8 @@ renderJsonld = \case schemaType t = let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|] JsonldArray arr -> - toOrderedList renderJsonld arr - JsonldField f -> mkVal f + Html.toOrderedList renderJsonld arr + JsonldField f -> Html.mkVal f -- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps. newtype Percentage = Percentage {unPercentage :: Int} @@ -546,7 +540,7 @@ getTransmissionTorrentsTable = do Json.asObject <&> KeyMap.toMapText ) <&> \resp -> - toTable + Html.toTable ( resp & List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0)) <&> Map.toList @@ -554,62 +548,6 @@ getTransmissionTorrentsTable = do & List.take 100 ) --- | 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|<em>true</em>|] - Json.Bool False -> [hsx|<em>false</em>|] - Json.Null -> [hsx|<em>null</em>|] - 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|<p>No results.</p>|] - Just xs' -> do - let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|<th>{h}</th>|]) & mconcat - let vals = xs' & foldMap (Html.tr . foldMap (Html.td . mkVal . snd)) - [hsx| - <table class="table"> - <thead> - <tr> - {headers} - </tr> - </thead> - <tbody> - {vals} - </tbody> - </table> - |] - data TransmissionRequest = TransmissionRequest { method :: Text, arguments :: Map Text Enc, @@ -831,10 +769,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do (label @"action" "download") ( label @"actionArgs" [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8)) - -- try using tokens as long as we have them (TODO: what if there’s no tokens left? - -- ANSWER: it breaks: - -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", - -- ("usetoken", Just "1") + -- try using tokens as long as we have them (TODO: what if there’s no tokens left? + -- ANSWER: it breaks: + -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", + -- ("usetoken", Just "1") ] ) ) @@ -1262,16 +1200,6 @@ getBestTorrents = do } ) -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 - -hush :: Either a1 a2 -> Maybe a2 -hush (Left _) = Nothing -hush (Right a) = Just a - -- | Do a request to the redacted API. If you know what that is, you know how to find the API docs. mkRedactedApiRequest :: ( MonadThrow m, @@ -1404,11 +1332,6 @@ redactedApiRequestJson span dat parser = mkRedactedApiRequest dat >>= httpJson defaults span parser -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 - runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") @@ -1469,71 +1392,6 @@ withDb act = do -- print [fmt|conn string: {db & TmpPg.toConnectionString}|] act db -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) - --- | A specialized variant of @addEvent@ that records attributes conforming to --- the OpenTelemetry specification's --- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions> --- --- @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) - ], - .. - } - -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 - -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) - class MonadTransmission m where getTransmissionId :: m (Maybe ByteString) setTransmissionId :: ByteString -> m () @@ -1543,20 +1401,3 @@ instance (MonadIO m) => MonadTransmission (AppT m) where setTransmissionId t = do var <- AppT $ asks (.transmissionSessionId) putMVar var t - -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/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index cca3712a65a2..614772db2401 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -35,6 +35,10 @@ common common-options -- does not export record fields as functions, use OverloadedRecordDot to access instead NoFieldSelectors + -- Allow the same record field name to be declared twice per module. + -- This works, because we use `OverloadedRecordDot` everywhere (enforced by `NoFieldSelectors`). + DuplicateRecordFields + -- Record punning RecordWildCards @@ -48,8 +52,10 @@ common common-options -- to enable the `type` keyword in import lists (ormolu uses this automatically) ExplicitNamespaces - default-language: GHC2021 + -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax + PatternSynonyms + default-language: GHC2021 library import: common-options @@ -58,6 +64,8 @@ library exposed-modules: WhatcdResolver + AppT + Html build-depends: base >=4.15 && <5, |