mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor(users/Profpatsch/whatcd-resolver): move AppT & Html out

Browse source 
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 <mail@profpatsch.de>
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-03-16 14:17:24 +01:00 committed by clbot
parent 803d726ed5
commit 0b06dda9a6
5 changed files with 212 additions and 172 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
users/Profpatsch/whatcd-resolver/default.nix
View file

@ -11,6 +11,8 @@ let
./whatcd-resolver.cabal
./Main.hs
./src/WhatcdResolver.hs
./src/AppT.hs
./src/Html.hs
];
libraryHaskellDepends = [

120
users/Profpatsch/whatcd-resolver/src/AppT.hs Normal file
View file

@ -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

69
users/Profpatsch/whatcd-resolver/src/Html.hs Normal file
View file

@ -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>
|]

183
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -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

10
users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
View file

@ -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,