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 <mail@profpatsch.de> Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI
This commit is contained in:
		
							parent
							
								
									803d726ed5
								
							
						
					
					
						commit
						0b06dda9a6
					
				
					 5 changed files with 212 additions and 172 deletions
				
			
		| 
						 | 
					@ -11,6 +11,8 @@ let
 | 
				
			||||||
      ./whatcd-resolver.cabal
 | 
					      ./whatcd-resolver.cabal
 | 
				
			||||||
      ./Main.hs
 | 
					      ./Main.hs
 | 
				
			||||||
      ./src/WhatcdResolver.hs
 | 
					      ./src/WhatcdResolver.hs
 | 
				
			||||||
 | 
					      ./src/AppT.hs
 | 
				
			||||||
 | 
					      ./src/Html.hs
 | 
				
			||||||
    ];
 | 
					    ];
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    libraryHaskellDepends = [
 | 
					    libraryHaskellDepends = [
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
							
								
								
									
										120
									
								
								users/Profpatsch/whatcd-resolver/src/AppT.hs
									
										
									
									
									
										Normal file
									
								
							
							
						
						
									
										120
									
								
								users/Profpatsch/whatcd-resolver/src/AppT.hs
									
										
									
									
									
										Normal 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
									
								
							
							
						
						
									
										69
									
								
								users/Profpatsch/whatcd-resolver/src/Html.hs
									
										
									
									
									
										Normal 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>
 | 
				
			||||||
 | 
					          |]
 | 
				
			||||||
| 
						 | 
					@ -1,13 +1,10 @@
 | 
				
			||||||
{-# LANGUAGE DeriveAnyClass #-}
 | 
					 | 
				
			||||||
{-# LANGUAGE DuplicateRecordFields #-}
 | 
					 | 
				
			||||||
{-# LANGUAGE QuasiQuotes #-}
 | 
					{-# LANGUAGE QuasiQuotes #-}
 | 
				
			||||||
{-# LANGUAGE ScopedTypeVariables #-}
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
module WhatcdResolver where
 | 
					module WhatcdResolver where
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					import AppT
 | 
				
			||||||
import Control.Category qualified as Cat
 | 
					import Control.Category qualified as Cat
 | 
				
			||||||
import Control.Monad.Catch.Pure (runCatch)
 | 
					import Control.Monad.Catch.Pure (runCatch)
 | 
				
			||||||
import Control.Monad.Logger qualified as Logger
 | 
					 | 
				
			||||||
import Control.Monad.Logger.CallStack
 | 
					import Control.Monad.Logger.CallStack
 | 
				
			||||||
import Control.Monad.Reader
 | 
					import Control.Monad.Reader
 | 
				
			||||||
import Data.Aeson qualified as Json
 | 
					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 qualified as List
 | 
				
			||||||
import Data.List.NonEmpty qualified as NonEmpty
 | 
					import Data.List.NonEmpty qualified as NonEmpty
 | 
				
			||||||
import Data.Map.Strict qualified as Map
 | 
					import Data.Map.Strict qualified as Map
 | 
				
			||||||
import Data.Pool (Pool)
 | 
					 | 
				
			||||||
import Data.Pool qualified as Pool
 | 
					import Data.Pool qualified as Pool
 | 
				
			||||||
import Data.Set (Set)
 | 
					import Data.Set (Set)
 | 
				
			||||||
import Data.Set qualified as Set
 | 
					import Data.Set qualified as Set
 | 
				
			||||||
| 
						 | 
					@ -32,7 +28,7 @@ import Database.Postgres.Temp qualified as TmpPg
 | 
				
			||||||
import FieldParser (FieldParser, FieldParser' (..))
 | 
					import FieldParser (FieldParser, FieldParser' (..))
 | 
				
			||||||
import FieldParser qualified as Field
 | 
					import FieldParser qualified as Field
 | 
				
			||||||
import GHC.Records (HasField (..))
 | 
					import GHC.Records (HasField (..))
 | 
				
			||||||
import GHC.Stack qualified
 | 
					import Html qualified
 | 
				
			||||||
import IHP.HSX.QQ (hsx)
 | 
					import IHP.HSX.QQ (hsx)
 | 
				
			||||||
import Json qualified
 | 
					import Json qualified
 | 
				
			||||||
import Json.Enc (Enc)
 | 
					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.Handler.Warp qualified as Warp
 | 
				
			||||||
import Network.Wai.Parse qualified as Wai
 | 
					import Network.Wai.Parse qualified as Wai
 | 
				
			||||||
import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 | 
					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 OpenTelemetry.Trace.Monad qualified as Otel
 | 
				
			||||||
import Parse (Parse)
 | 
					import Parse (Parse)
 | 
				
			||||||
import Parse qualified
 | 
					import Parse qualified
 | 
				
			||||||
| 
						 | 
					@ -62,12 +57,11 @@ import System.Directory qualified as Dir
 | 
				
			||||||
import System.Directory qualified as Xdg
 | 
					import System.Directory qualified as Xdg
 | 
				
			||||||
import System.Environment qualified as Env
 | 
					import System.Environment qualified as Env
 | 
				
			||||||
import System.FilePath ((</>))
 | 
					import System.FilePath ((</>))
 | 
				
			||||||
import System.IO qualified as IO
 | 
					 | 
				
			||||||
import Text.Blaze.Html (Html)
 | 
					import Text.Blaze.Html (Html)
 | 
				
			||||||
import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty
 | 
					import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty
 | 
				
			||||||
import Text.Blaze.Html.Renderer.Utf8 qualified as Html
 | 
					import Text.Blaze.Html.Renderer.Utf8 qualified as Html
 | 
				
			||||||
import Text.Blaze.Html5 qualified as Html
 | 
					import Text.Blaze.Html5 qualified as Html
 | 
				
			||||||
import Tool (Tool, readTool, readTools)
 | 
					import Tool (readTool, readTools)
 | 
				
			||||||
import UnliftIO
 | 
					import UnliftIO
 | 
				
			||||||
import Prelude hiding (span)
 | 
					import Prelude hiding (span)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -144,7 +138,7 @@ htmlUi = do
 | 
				
			||||||
            snipsRedactedSearch dat
 | 
					            snipsRedactedSearch dat
 | 
				
			||||||
        "snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do
 | 
					        "snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do
 | 
				
			||||||
          dat <- torrentIdMp span
 | 
					          dat <- torrentIdMp span
 | 
				
			||||||
          mkVal <$> (runTransaction $ getTorrentById dat)
 | 
					          Html.mkVal <$> (runTransaction $ getTorrentById dat)
 | 
				
			||||||
        "snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \span -> do
 | 
					        "snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \span -> do
 | 
				
			||||||
          dat <- torrentIdMp span
 | 
					          dat <- torrentIdMp span
 | 
				
			||||||
          runTransaction $ do
 | 
					          runTransaction $ do
 | 
				
			||||||
| 
						 | 
					@ -449,7 +443,7 @@ renderJsonld = \case
 | 
				
			||||||
      <dd><a href={obj.id_}>{obj.id_}</a></dd>
 | 
					      <dd><a href={obj.id_}>{obj.id_}</a></dd>
 | 
				
			||||||
      <dt>Fields</dt>
 | 
					      <dt>Fields</dt>
 | 
				
			||||||
      <dd>
 | 
					      <dd>
 | 
				
			||||||
        {obj.previewFields & toDefinitionList schemaType renderJsonld}
 | 
					        {obj.previewFields & Html.toDefinitionList schemaType renderJsonld}
 | 
				
			||||||
        <div>
 | 
					        <div>
 | 
				
			||||||
          <button
 | 
					          <button
 | 
				
			||||||
            hx-get={snippetHref obj.id_}
 | 
					            hx-get={snippetHref obj.id_}
 | 
				
			||||||
| 
						 | 
					@ -474,8 +468,8 @@ renderJsonld = \case
 | 
				
			||||||
      schemaType t =
 | 
					      schemaType t =
 | 
				
			||||||
        let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|]
 | 
					        let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|]
 | 
				
			||||||
  JsonldArray arr ->
 | 
					  JsonldArray arr ->
 | 
				
			||||||
    toOrderedList renderJsonld arr
 | 
					    Html.toOrderedList renderJsonld arr
 | 
				
			||||||
  JsonldField f -> mkVal f
 | 
					  JsonldField f -> Html.mkVal f
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps.
 | 
					-- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps.
 | 
				
			||||||
newtype Percentage = Percentage {unPercentage :: Int}
 | 
					newtype Percentage = Percentage {unPercentage :: Int}
 | 
				
			||||||
| 
						 | 
					@ -546,7 +540,7 @@ getTransmissionTorrentsTable = do
 | 
				
			||||||
        Json.asObject <&> KeyMap.toMapText
 | 
					        Json.asObject <&> KeyMap.toMapText
 | 
				
			||||||
    )
 | 
					    )
 | 
				
			||||||
    <&> \resp ->
 | 
					    <&> \resp ->
 | 
				
			||||||
      toTable
 | 
					      Html.toTable
 | 
				
			||||||
        ( resp
 | 
					        ( resp
 | 
				
			||||||
            & List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
 | 
					            & List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
 | 
				
			||||||
            <&> Map.toList
 | 
					            <&> Map.toList
 | 
				
			||||||
| 
						 | 
					@ -554,62 +548,6 @@ getTransmissionTorrentsTable = do
 | 
				
			||||||
            & List.take 100
 | 
					            & 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
 | 
					data TransmissionRequest = TransmissionRequest
 | 
				
			||||||
  { method :: Text,
 | 
					  { method :: Text,
 | 
				
			||||||
    arguments :: Map Text Enc,
 | 
					    arguments :: Map Text Enc,
 | 
				
			||||||
| 
						 | 
					@ -831,10 +769,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
 | 
				
			||||||
          (label @"action" "download")
 | 
					          (label @"action" "download")
 | 
				
			||||||
          ( label @"actionArgs"
 | 
					          ( label @"actionArgs"
 | 
				
			||||||
              [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
 | 
					              [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
 | 
				
			||||||
                -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
 | 
					              -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
 | 
				
			||||||
                -- ANSWER: it breaks:
 | 
					              -- ANSWER: it breaks:
 | 
				
			||||||
                -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
 | 
					              -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
 | 
				
			||||||
                -- ("usetoken", Just "1")
 | 
					              -- ("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.
 | 
					-- | Do a request to the redacted API. If you know what that is, you know how to find the API docs.
 | 
				
			||||||
mkRedactedApiRequest ::
 | 
					mkRedactedApiRequest ::
 | 
				
			||||||
  ( MonadThrow m,
 | 
					  ( MonadThrow m,
 | 
				
			||||||
| 
						 | 
					@ -1404,11 +1332,6 @@ redactedApiRequestJson span dat parser =
 | 
				
			||||||
    mkRedactedApiRequest dat
 | 
					    mkRedactedApiRequest dat
 | 
				
			||||||
    >>= httpJson defaults span parser
 | 
					    >>= 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 IO a -> IO (Either TmpPg.StartError a)
 | 
				
			||||||
runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
 | 
					runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
 | 
				
			||||||
  pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
 | 
					  pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
 | 
				
			||||||
| 
						 | 
					@ -1469,71 +1392,6 @@ withDb act = do
 | 
				
			||||||
    -- print [fmt|conn string: {db & TmpPg.toConnectionString}|]
 | 
					    -- print [fmt|conn string: {db & TmpPg.toConnectionString}|]
 | 
				
			||||||
    act db
 | 
					    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
 | 
					class MonadTransmission m where
 | 
				
			||||||
  getTransmissionId :: m (Maybe ByteString)
 | 
					  getTransmissionId :: m (Maybe ByteString)
 | 
				
			||||||
  setTransmissionId :: ByteString -> m ()
 | 
					  setTransmissionId :: ByteString -> m ()
 | 
				
			||||||
| 
						 | 
					@ -1543,20 +1401,3 @@ instance (MonadIO m) => MonadTransmission (AppT m) where
 | 
				
			||||||
  setTransmissionId t = do
 | 
					  setTransmissionId t = do
 | 
				
			||||||
    var <- AppT $ asks (.transmissionSessionId)
 | 
					    var <- AppT $ asks (.transmissionSessionId)
 | 
				
			||||||
    putMVar var t
 | 
					    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
 | 
					 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -35,6 +35,10 @@ common common-options
 | 
				
			||||||
    -- does not export record fields as functions, use OverloadedRecordDot to access instead
 | 
					    -- does not export record fields as functions, use OverloadedRecordDot to access instead
 | 
				
			||||||
    NoFieldSelectors
 | 
					    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
 | 
					    -- Record punning
 | 
				
			||||||
    RecordWildCards
 | 
					    RecordWildCards
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -48,8 +52,10 @@ common common-options
 | 
				
			||||||
    -- to enable the `type` keyword in import lists (ormolu uses this automatically)
 | 
					    -- to enable the `type` keyword in import lists (ormolu uses this automatically)
 | 
				
			||||||
    ExplicitNamespaces
 | 
					    ExplicitNamespaces
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  default-language: GHC2021
 | 
					    -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax
 | 
				
			||||||
 | 
					    PatternSynonyms
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  default-language: GHC2021
 | 
				
			||||||
 | 
					
 | 
				
			||||||
library
 | 
					library
 | 
				
			||||||
    import: common-options
 | 
					    import: common-options
 | 
				
			||||||
| 
						 | 
					@ -58,6 +64,8 @@ library
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    exposed-modules:
 | 
					    exposed-modules:
 | 
				
			||||||
       WhatcdResolver
 | 
					       WhatcdResolver
 | 
				
			||||||
 | 
					       AppT
 | 
				
			||||||
 | 
					       Html
 | 
				
			||||||
 | 
					
 | 
				
			||||||
    build-depends:
 | 
					    build-depends:
 | 
				
			||||||
        base >=4.15 && <5,
 | 
					        base >=4.15 && <5,
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue