diff options
Diffstat (limited to 'users')
21 files changed, 682 insertions, 265 deletions
diff --git a/users/Profpatsch/.hlint.yaml b/users/Profpatsch/.hlint.yaml index f00f78c525..12b7c61b70 100644 --- a/users/Profpatsch/.hlint.yaml +++ b/users/Profpatsch/.hlint.yaml @@ -34,6 +34,8 @@ - ignore: { name: Use tuple-section } - ignore: { name: Use forM_ } - ignore: { name: Functor law } +- ignore: { name: Use maybe } + # fst and snd are usually a code smell and should be explicit matches, _naming the ignored side. - ignore: { name: Use fst } - ignore: { name: Use snd } diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index e445115416..4bca8ea49f 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -7,6 +7,7 @@ pkgs.haskellPackages.mkDerivation { src = depot.users.Profpatsch.exactSource ./. [ ./my-prelude.cabal ./src/Aeson.hs + ./src/Arg.hs ./src/AtLeast.hs ./src/MyPrelude.hs ./src/Test.hs diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 95a8399f37..2f7882a526 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -59,6 +59,7 @@ library exposed-modules: MyPrelude Aeson + Arg AtLeast Test Postgres.Decoder diff --git a/users/Profpatsch/my-prelude/src/Arg.hs b/users/Profpatsch/my-prelude/src/Arg.hs new file mode 100644 index 0000000000..a6ffa90924 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Arg.hs @@ -0,0 +1,34 @@ +module Arg where + +import Data.String (IsString) +import GHC.Exts (IsList) +import GHC.TypeLits (Symbol) + +-- | Wrap a function argument into this helper to give it a better description for the caller without disturbing the callsite too much. +-- +-- This has instances for IsString and Num, meaning if the caller is usually a string or number literal, it should Just Work. +-- +-- e.g. +-- +-- @ +-- myFoo :: Arg "used as the name in error message" Text -> IO () +-- myFoo (Arg name) = … +-- @ +-- +-- Will display the description in the inferred type of the callsite. +-- +-- Due to IsString you can call @myFoo@ like +-- +-- @myFoo "name in error"@ +-- +-- This is mostly intended for literals, if you want to wrap arbitrary data, use @Label@. +newtype Arg (description :: Symbol) a = Arg {unArg :: a} + deriving newtype + ( Show, + Eq, + IsString, + IsList, + Num, + Monoid, + Semigroup + ) diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs index f83a6d7fcf..2c9a48d134 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -5,13 +5,20 @@ module Postgres.MonadPostgres where +import Arg import AtLeast (AtLeast) import Control.Exception + ( Exception (displayException), + Handler (Handler), + catches, + try, + ) import Control.Foldl qualified as Fold import Control.Monad.Logger.CallStack (MonadLogger, logDebug, logWarn) import Control.Monad.Reader (MonadReader (ask), ReaderT (..)) import Control.Monad.Trans.Resource import Data.Aeson (FromJSON) +import Data.ByteString qualified as ByteString import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.Int (Int64) @@ -28,8 +35,10 @@ import Database.PostgreSQL.Simple.FromRow qualified as PG import Database.PostgreSQL.Simple.ToField (ToField) import Database.PostgreSQL.Simple.ToRow (ToRow (toRow)) import Database.PostgreSQL.Simple.Types (Query (..)) +import GHC.IO.Handle (Handle) import GHC.Records (getField) import Label +import OpenTelemetry.Trace.Core (NewEvent (newEventName)) import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import PossehlAnalyticsPrelude @@ -39,7 +48,9 @@ import Pretty (showPretty) import Seconds import System.Exit (ExitCode (..)) import Tool -import UnliftIO (MonadUnliftIO (withRunInIO)) +import UnliftIO (MonadUnliftIO (withRunInIO), bracket, hClose, mask_) +import UnliftIO.Concurrent (forkIO) +import UnliftIO.Process (ProcessHandle) import UnliftIO.Process qualified as Process import UnliftIO.Resource qualified as Resource import Prelude hiding (init, span) @@ -357,7 +368,7 @@ handlePGException :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Text -> @@ -405,6 +416,104 @@ withPGTransaction connPool f = connPool (\conn -> Postgres.withTransaction conn (f conn)) +-- | `pg_formatter` is a perl script that does not support any kind of streaming. +-- Thus we initialize a pool with a bunch of these scripts running, waiting for input. This way we can have somewhat fast SQL formatting. +-- +-- Call `initPgFormatPool` to initialize, then use `runPgFormat` to format some sql. +data PgFormatPool = PgFormatPool + { pool :: Pool PgFormatProcess, + pgFormat :: Tool + } + +data PgFormatProcess = PgFormatProcess + { stdinHdl :: Handle, + stdoutHdl :: Handle, + stderrHdl :: Handle, + procHdl :: ProcessHandle, + startedAt :: Otel.Timestamp + } + +initPgFormatPool :: (HasField "pgFormat" tools Tool) => tools -> IO PgFormatPool +initPgFormatPool tools = do + pool <- + Pool.newPool + ( Pool.defaultPoolConfig + (pgFormatStartCommandWaitForInput tools) + ( \pgFmt -> do + Process.terminateProcess pgFmt.procHdl + -- make sure we don’t leave any zombies + _ <- forkIO $ do + _ <- Process.waitForProcess pgFmt.procHdl + pure () + pure () + ) + -- unused resource time + 100 + -- number of resources + 10 + ) + + -- fill the pool with resources + let go = + Pool.tryWithResource pool (\_ -> go) >>= \case + Nothing -> pure () + Just () -> pure () + _ <- go + pure (PgFormatPool {pool, pgFormat = tools.pgFormat}) + +destroyPgFormatPool :: PgFormatPool -> IO () +destroyPgFormatPool pool = Pool.destroyAllResources pool.pool + +-- | Get the oldest resource from the pool, or stop if you find a resource that’s older than `cutoffPointMs`. +takeOldestResource :: PgFormatPool -> Arg "cutoffPointMs" Integer -> IO (PgFormatProcess, Pool.LocalPool PgFormatProcess) +takeOldestResource pool cutoffPointMs = do + now <- Otel.getTimestamp + mask_ $ do + a <- Pool.takeResource pool.pool + (putBack, res) <- go now [] a + -- make sure we don’t leak any resources we didn’t use in the end + for_ putBack $ \(x, xLocal) -> Pool.putResource xLocal x + pure res + where + mkMs ts = (ts & Otel.timestampNanoseconds & toInteger) `div` 1000_000 + go now putBack a@(a', _) = + if abs (mkMs now - mkMs a'.startedAt) > cutoffPointMs.unArg + then pure (putBack, a) + else + Pool.tryTakeResource pool.pool >>= \case + Nothing -> pure (putBack, a) + Just b@(b', _) -> do + if a'.startedAt < b'.startedAt + then go now (b : putBack) a + else go now (a : putBack) b + +-- | Format the given SQL with pg_formatter. Will use the pool of already running formatters to speed up execution. +runPgFormat :: PgFormatPool -> ByteString -> IO (T3 "exitCode" ExitCode "formatted" ByteString "stderr" ByteString) +runPgFormat pool sqlStatement = do + bracket + (takeOldestResource pool 200) + ( \(a, localPool) -> do + -- we always destroy the resource, because the process exited + Pool.destroyResource pool.pool localPool a + -- create a new process to keep the pool “warm” + new <- pgFormatStartCommandWaitForInput pool + Pool.putResource localPool new + ) + ( \(pgFmt, _localPool) -> do + ByteString.hPut pgFmt.stdinHdl sqlStatement + -- close stdin to make pg_formatter format (it exits …) + -- issue: https://github.com/darold/pgFormatter/issues/333 + hClose pgFmt.stdinHdl + formatted <- ByteString.hGetContents pgFmt.stdoutHdl + errs <- ByteString.hGetContents pgFmt.stderrHdl + exitCode <- Process.waitForProcess pgFmt.procHdl + pure $ + T3 + (label @"exitCode" exitCode) + (label @"formatted" formatted) + (label @"stderr" errs) + ) + runPGTransactionImpl :: (MonadUnliftIO m) => m (Pool Postgres.Connection) -> @@ -418,7 +527,7 @@ runPGTransactionImpl zoom (Transaction transaction) = do unliftIO $ runReaderT transaction conn executeImpl :: - (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => m tools -> m DebugLogDatabaseQueries -> Query -> @@ -436,7 +545,7 @@ executeImpl zoomTools zoomDebugLogDatabaseQueries qry params = >>= toNumberOfRowsAffected "executeImpl" executeImpl_ :: - (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => + (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => m tools -> m DebugLogDatabaseQueries -> Query -> @@ -453,14 +562,14 @@ executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry = >>= toNumberOfRowsAffected "executeImpl_" executeManyImpl :: - (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => m tools -> m DebugLogDatabaseQueries -> Query -> NonEmpty params -> Transaction m (Label "numberOfRowsAffected" Natural) executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params = - Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do + Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do tools <- lift @Transaction zoomTools logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) @@ -480,7 +589,7 @@ toNumberOfRowsAffected functionName i64 = <&> label @"numberOfRowsAffected" executeManyReturningWithImpl :: - (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) => + (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) => m tools -> m DebugLogDatabaseQueries -> Query -> @@ -489,7 +598,7 @@ executeManyReturningWithImpl :: Transaction m [r] {-# INLINE executeManyReturningWithImpl #-} executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do - Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do + Otel.inSpan' "Postgres Query (executeManyReturning)" Otel.defaultSpanArguments $ \span -> do tools <- lift @Transaction zoomTools logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params) @@ -501,7 +610,7 @@ foldRowsWithAccImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -535,7 +644,7 @@ foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder ro ) pgFormatQueryNoParams' :: - (MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) => + (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) => tools -> Query -> Transaction m Text @@ -571,7 +680,7 @@ queryWithImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -582,7 +691,7 @@ queryWithImpl :: Transaction m [r] {-# INLINE queryWithImpl #-} queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do - Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do + Otel.inSpan' "Postgres Query (queryWith)" Otel.defaultSpanArguments $ \span -> do tools <- lift @Transaction zoomTools logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params) @@ -593,7 +702,7 @@ queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) queryWithImpl_ :: ( MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => m tools -> Query -> @@ -619,7 +728,7 @@ pgFormatQuery' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -633,7 +742,7 @@ pgFormatQueryMany' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -650,33 +759,58 @@ postgresToolsParser = label @"pgFormat" <$> readTool "pg_format" pgFormatQueryByteString :: ( MonadIO m, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> ByteString -> m Text pgFormatQueryByteString tools queryBytes = do + res <- + liftIO $ + runPgFormat + tools.pgFormat + (queryBytes) + case res.exitCode of + ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient) + ExitFailure status -> do + logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|] + logDebug + ( prettyErrorTree + ( nestedMultiError + "pg_format output" + ( nestedError "stdout" (singleError (res.formatted & bytesToTextUtf8Lenient & newError)) + :| [(nestedError "stderr" (singleError (res.stderr & bytesToTextUtf8Lenient & newError)))] + ) + ) + ) + logDebug [fmt|pg_format stdout: stderr|] + pure (queryBytes & bytesToTextUtf8Lenient) + +pgFormatStartCommandWaitForInput :: + ( MonadIO m, + HasField "pgFormat" tools Tool, + MonadFail m + ) => + tools -> + m PgFormatProcess +pgFormatStartCommandWaitForInput tools = do do - (exitCode, stdout, stderr) <- - Process.readProcessWithExitCode - tools.pgFormat.toolPath - ["-"] - (queryBytes & bytesToTextUtf8Lenient & textToString) - case exitCode of - ExitSuccess -> pure (stdout & stringToText) - ExitFailure status -> do - logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|] - logDebug - ( prettyErrorTree - ( nestedMultiError - "pg_format output" - ( nestedError "stdout" (singleError (stdout & stringToText & newError)) - :| [(nestedError "stderr" (singleError (stderr & stringToText & newError)))] - ) - ) + startedAt <- Otel.getTimestamp + (Just stdinHdl, Just stdoutHdl, Just stderrHdl, procHdl) <- + Process.createProcess + ( ( Process.proc + tools.pgFormat.toolPath + [ "--no-rcfile", + "-" + ] ) - logDebug [fmt|pg_format stdout: stderr|] - pure (queryBytes & bytesToTextUtf8Lenient) + { Process.std_in = Process.CreatePipe, + Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe + } + ) + + pure PgFormatProcess {..} data DebugLogDatabaseQueries = -- | Do not log the database queries @@ -697,7 +831,7 @@ traceQueryIfEnabled :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => tools -> @@ -708,20 +842,25 @@ traceQueryIfEnabled :: Transaction m () traceQueryIfEnabled tools span logDatabaseQueries qry params = do -- In case we have query logging enabled, we want to do that - let formattedQuery = case params of - HasNoParams -> pgFormatQueryNoParams' tools qry - HasSingleParam p -> pgFormatQuery' tools qry p - HasMultiParams ps -> pgFormatQueryMany' tools qry ps + let formattedQuery = do + withEvent + span + "Query Format start" + "Query Format end" + $ case params of + HasNoParams -> pgFormatQueryNoParams' tools qry + HasSingleParam p -> pgFormatQuery' tools qry p + HasMultiParams ps -> pgFormatQueryMany' tools qry ps + let doLog errs = Otel.addAttributes span $ HashMap.fromList $ ( ("_.postgres.query", Otel.toAttribute @Text errs.query) : ( errs.explain - & foldMap - ( \ex -> - [("_.postgres.explain", Otel.toAttribute @Text ex)] - ) + & \case + Nothing -> [] + Just ex -> [("_.postgres.explain", Otel.toAttribute @Text ex)] ) ) let doExplain = do @@ -750,6 +889,37 @@ traceQueryIfEnabled tools span logDatabaseQueries qry params = do ex <- doExplain doLog (T2 (label @"query" q) (label @"explain" (Just ex))) +-- | Add a start and end event to the span, and figure out how long the difference was. +-- +-- This is more lightweight than starting an extra span for timing things. +withEvent :: (MonadIO f) => Otel.Span -> Text -> Text -> f b -> f b +withEvent span start end act = do + let mkMs ts = (ts & Otel.timestampNanoseconds & toInteger) `div` 1000_000 + s <- Otel.getTimestamp + Otel.addEvent + span + ( Otel.NewEvent + { newEventName = start, + newEventAttributes = mempty, + newEventTimestamp = Just s + } + ) + res <- act + e <- Otel.getTimestamp + let tookMs = + (mkMs e - mkMs s) + -- should be small enough + & fromInteger @Int + Otel.addEvent + span + ( Otel.NewEvent + { newEventName = end, + newEventAttributes = HashMap.fromList [("took ms", Otel.toAttribute tookMs)], + newEventTimestamp = Just e + } + ) + pure res + instance (ToField t1) => ToRow (Label l1 t1) where toRow t2 = toRow $ PG.Only $ getField @l1 t2 diff --git a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs index 9fe51aba18..16f1b626ac 100644 --- a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs +++ b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs @@ -151,12 +151,12 @@ runApp = withTracer $ \tracer -> do ) ] if - -- If the last cache update is newer or equal to the requested version, we can tell the browser it’s fine - | Just modifiedSince <- req'.ifModifiedSince, - modifiedSince >= new.lastModified -> - pure $ Wai.responseLBS Http.status304 cacheToHeaders "" - | otherwise -> - pure $ h cacheToHeaders (new.result & toLazyBytes) + -- If the last cache update is newer or equal to the requested version, we can tell the browser it’s fine + | Just modifiedSince <- req'.ifModifiedSince, + modifiedSince >= new.lastModified -> + pure $ Wai.responseLBS Http.status304 cacheToHeaders "" + | otherwise -> + pure $ h cacheToHeaders (new.result & toLazyBytes) ) } ] @@ -198,7 +198,7 @@ runApp = withTracer $ \tracer -> do (Parse.maybe $ Parse.fieldParser parseHeaderTime) & rmap (fmap mkSecondTime) -parseRequest :: (MonadThrow f, MonadIO f) => Otel.Span -> Parse from a -> from -> f a +parseRequest :: (MonadThrow f) => Otel.Span -> Parse from a -> from -> f a parseRequest span parser req = Parse.runParse "Unable to parse the HTTP request" parser req & assertM span id @@ -220,9 +220,9 @@ heatmap = do t & firstSection (match (Soup.TagOpen ("") [("class", "heatmap")])) >>= firstSection (match (Soup.TagOpen "table" [])) - <&> getTable - <&> (<> htmlToTags [hsx|<figcaption>source: <a href={mapallSpaceOla} target="_blank">mapall.space</a></figcaption>|]) - <&> wrapTagStream (T2 (label @"el" "figure") (label @"attrs" [])) + <&> getTable + <&> (<> htmlToTags [hsx|<figcaption>source: <a href={mapallSpaceOla} target="_blank">mapall.space</a></figcaption>|]) + <&> wrapTagStream (T2 (label @"el" "figure") (label @"attrs" [])) -- get the table from opening tag to closing tag (allowing nested tables) getTable = go 0 @@ -310,8 +310,8 @@ runHandlers runApplication handlers = 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 +inSpan' :: Text -> (Otel.Span -> m a) -> m a +-- inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments inSpan' _name act = act (error "todo telemetry disabled") zipT2 :: @@ -379,17 +379,17 @@ httpJson opts span parser req = do <&> Wai.parseContentType <&> (\(ct, _mimeAttributes) -> ct) if - | statusCode == 200, - Just ct <- contentType, - ct == opts'.contentType -> - Right $ (resp & Http.responseBody) - | statusCode == 200, - Just otherType <- contentType -> - Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] - | statusCode == 200, - Nothing <- contentType -> - Left [fmt|Server returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] + | statusCode == 200, + Just ct <- contentType, + ct == opts'.contentType -> + Right $ (resp & Http.responseBody) + | statusCode == 200, + Just otherType <- contentType -> + Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] + | statusCode == 200, + Nothing <- contentType -> + Left [fmt|Server returned a body with unspecified content type|] + | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] ) >>= assertM span @@ -398,7 +398,7 @@ httpJson opts span parser req = do & first (Json.parseErrorTree "could not parse redacted response") ) -assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a +assertM :: (MonadThrow 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 @@ -419,7 +419,7 @@ data Cache a = Cache lastModified :: !SecondTime, result :: !a } - deriving (Show) + deriving stock (Show) newCache :: Text -> a -> IO (TVar (Cache a)) newCache name result = do @@ -528,8 +528,8 @@ recordException span dat = liftIO $ do .. } -appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a -appThrowTree span exc = do +appThrowTree :: (MonadThrow m) => Otel.Span -> ErrorTree -> m a +appThrowTree _span exc = do let msg = prettyErrorTree exc -- recordException -- span @@ -539,7 +539,7 @@ appThrowTree span exc = do -- ) throwM $ AppException msg -orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a +orAppThrowTree :: (MonadThrow m) => Otel.Span -> Either ErrorTree a -> m a orAppThrowTree span = \case Left err -> appThrowTree span err Right a -> pure a diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index b5095d476f..ec3326fe86 100644 --- a/users/Profpatsch/shell.nix +++ b/users/Profpatsch/shell.nix @@ -45,7 +45,7 @@ pkgs.mkShell { h.unix h.tagsoup h.attoparsec - h.iCalendar + # h.iCalendar h.case-insensitive h.hscolour h.nicify-lib diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 7afd430745..3232004122 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -19,16 +19,15 @@ 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, + pgFormat :: PgFormatPool, pgConnPool :: Pool Postgres.Connection, - transmissionSessionId :: MVar ByteString + transmissionSessionId :: IORef (Maybe ByteString) } newtype AppT m a = AppT {unAppT :: ReaderT Context m a} diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index 4fdbb306ad..487d55c21d 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/users/Profpatsch/whatcd-resolver/src/Http.hs @@ -16,16 +16,14 @@ where import AppT import Data.CaseInsensitive (CI (original)) import Data.Char qualified as Char -import Data.Int (Int64) import Data.List qualified as List import Data.Text qualified as Text -import Data.Text.Lazy qualified as Lazy.Text import Data.Text.Punycode qualified as Punycode import Json.Enc qualified as Enc import MyPrelude import Network.HTTP.Client import Network.HTTP.Simple -import OpenTelemetry.Attributes qualified as Otel +import Network.HTTP.Types.Status (Status (..)) import Optional import Prelude hiding (span) @@ -55,20 +53,24 @@ doRequestJson :: Enc.Enc -> m (Response ByteString) doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do - let x = requestToXhCommandLine opts val - let attrs = [100, 200 .. fromIntegral @Int @Int64 (x & Text.length)] - for_ attrs $ \n -> do - addAttribute span [fmt|request.xh.{n}|] (Lazy.Text.repeat 'x' & Lazy.Text.take n & toStrict & Otel.TextAttribute) addAttribute span "request.xh" (requestToXhCommandLine opts val) - defaultRequest {secure = not (opts & optsUsePlainHttp)} - & setRequestHost (opts & optsHost) - & setRequestPort (opts & optsPort) - -- TODO: is this automatically escaped by the library? - & setRequestPath (opts & optsPath) - & setRequestHeaders (opts & optsHeaders) - & setRequestMethod opts.method - & setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) - & httpBS + resp <- + defaultRequest {secure = not (opts & optsUsePlainHttp)} + & setRequestHost (opts & optsHost) + & setRequestPort (opts & optsPort) + -- TODO: is this automatically escaped by the library? + & setRequestPath (opts & optsPath) + & setRequestHeaders (opts & optsHeaders) + & setRequestMethod opts.method + & setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) + & httpBS + let code = resp & getResponseStatus & (.statusCode) + let msg = resp & getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient + addAttribute + span + "request.response.status" + ([fmt|{code} {msg}|] :: Text) + pure resp optsHost :: RequestOptions -> ByteString optsHost opts = diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs index 16b1ab991b..1a021b706c 100644 --- a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs +++ b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs @@ -3,7 +3,6 @@ module JsonLd where import AppT -import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.ByteString.Builder qualified as Builder diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 4369c18408..c0ad9071af 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -3,6 +3,7 @@ module Redacted where import AppT +import Arg import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json @@ -67,12 +68,8 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do ) httpTorrent span req --- fix --- ( \io -> do --- logInfo "delay" --- liftIO $ threadDelay 10_000_000 --- io --- ) +mkRedactedTorrentLink :: Arg "torrentGroupId" Int -> Text +mkRedactedTorrentLink torrentId = [fmt|https://redacted.ch/torrents.php?id={torrentId.unArg}|] exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m) => m (Transaction m ()) exampleSearch = do @@ -360,11 +357,17 @@ data TorrentData transmissionInfo = TorrentData { groupId :: Int, torrentId :: Int, seedingWeight :: Int, + artists :: [T2 "artistId" Int "artistName" Text], torrentJson :: Json.Value, - torrentGroupJson :: T3 "artist" Text "groupName" Text "groupYear" Int, + torrentGroupJson :: TorrentGroupJson, torrentStatus :: TorrentStatus transmissionInfo } +data TorrentGroupJson = TorrentGroupJson + { groupName :: Text, + groupYear :: Int + } + data TorrentStatus transmissionInfo = NoTorrentFileYet | NotInTransmissionYet @@ -381,38 +384,70 @@ getTorrentById dat = do (Dec.json Json.asValue) >>= ensureSingleRow +data GetBestTorrentsFilter = GetBestTorrentsFilter + { onlyDownloaded :: Bool, + onlyArtist :: Maybe (Label "artistRedactedId" Natural) + } + -- | Find the best torrent for each torrent group (based on the seeding_weight) -getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()] -getBestTorrents = do +getBestTorrents :: + (MonadPostgres m) => + GetBestTorrentsFilter -> + Transaction m [TorrentData ()] +getBestTorrents opts = do queryWith [sql| - SELECT * FROM ( - SELECT DISTINCT ON (group_id) - tg.group_id, - t.torrent_id, - seeding_weight, - t.full_json_result AS torrent_json, - tg.full_json_result AS torrent_group_json, - t.torrent_file IS NOT NULL, - t.transmission_torrent_hash - FROM redacted.torrents t - JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group - ORDER BY group_id, seeding_weight DESC - ) as _ + WITH filtered_torrents AS ( + SELECT DISTINCT ON (torrent_group) + id + FROM + redacted.torrents + WHERE + -- onlyDownloaded + ((NOT ?::bool) OR torrent_file IS NOT NULL) + -- filter by artist id + AND + (?::bool OR (to_jsonb(?::int) <@ (jsonb_path_query_array(full_json_result, '$.artists[*].id')))) + ORDER BY torrent_group, seeding_weight DESC + ) + SELECT + tg.group_id, + t.torrent_id, + t.seeding_weight, + t.full_json_result AS torrent_json, + tg.full_json_result AS torrent_group_json, + t.torrent_file IS NOT NULL AS has_torrent_file, + t.transmission_torrent_hash + FROM filtered_torrents f + JOIN redacted.torrents t ON t.id = f.id + JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group ORDER BY seeding_weight DESC |] - () + ( do + let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of + Nothing -> (True, 0) + Just a -> (False, a.artistRedactedId) + ( opts.onlyDownloaded :: Bool, + onlyArtistB :: Bool, + onlyArtistId & fromIntegral @Natural @Int + ) + ) ( do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int - torrentJson <- Dec.json Json.asValue + (torrentJson, artists) <- Dec.json $ do + val <- Json.asValue + artists <- Json.keyOrDefault "artists" [] $ Json.eachInArray $ do + id_ <- Json.keyLabel @"artistId" "id" (Json.asIntegral @_ @Int) + name <- Json.keyLabel @"artistName" "name" Json.asText + pure $ T2 id_ name + pure (val, artists) torrentGroupJson <- ( Dec.json $ do - artist <- Json.keyLabel @"artist" "artist" Json.asText - groupName <- Json.keyLabel @"groupName" "groupName" Json.asText - groupYear <- Json.keyLabel @"groupYear" "groupYear" (Json.asIntegral @_ @Int) - pure $ T3 artist groupName groupYear + groupName <- Json.key "groupName" Json.asText + groupYear <- Json.key "groupYear" (Json.asIntegral @_ @Int) + pure $ TorrentGroupJson {..} ) hasTorrentFile <- Dec.fromField @Bool transmissionTorrentHash <- diff --git a/users/Profpatsch/whatcd-resolver/src/Transmission.hs b/users/Profpatsch/whatcd-resolver/src/Transmission.hs index 66dbeb9ce7..acbab00162 100644 --- a/users/Profpatsch/whatcd-resolver/src/Transmission.hs +++ b/users/Profpatsch/whatcd-resolver/src/Transmission.hs @@ -25,6 +25,7 @@ import Json.Enc qualified as Enc import Label import MyPrelude import Network.HTTP.Types +import OpenTelemetry.Attributes (ToAttribute (toAttribute)) import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import Optional import Postgres.MonadPostgres @@ -226,7 +227,7 @@ doTransmissionRequest :: (TransmissionRequest, Json.Parse Error output) -> m (TransmissionResponse output) doTransmissionRequest span dat (req, parser) = do - sessionId <- getTransmissionId + sessionId <- getCurrentTransmissionSessionId let textArg t = (Enc.text t, Otel.toAttribute @Text t) let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty) let intArg i = (Enc.int i, Otel.toAttribute @Int i) @@ -257,7 +258,7 @@ doTransmissionRequest span dat (req, parser) = do (body <&> second fst & Enc.object) -- Implement the CSRF protection thingy case resp & Http.getResponseStatus & (.statusCode) of - 409 -> do + 409 -> inSpan' "New Transmission Session ID" $ \span' -> do tid <- resp & Http.getResponseHeader "X-Transmission-Session-Id" @@ -266,9 +267,21 @@ doTransmissionRequest span dat (req, parser) = do & unwrapIOError & liftIO <&> NonEmpty.head - setTransmissionId tid + + addAttributes span' $ + HashMap.fromList + [ ("transmission.new_session_id", tid & bytesToTextUtf8Lenient & toAttribute), + ("transmission.old_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute) + ] + + updateTransmissionSessionId tid + doTransmissionRequest span dat (req, parser) - 200 -> + 200 -> do + addAttributes span $ + HashMap.fromList + [ ("transmission.valid_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute) + ] resp & Http.getResponseBody & Json.parseStrict @@ -296,11 +309,11 @@ doTransmissionRequest span dat (req, parser) = do _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|] class MonadTransmission m where - getTransmissionId :: m (Maybe ByteString) - setTransmissionId :: ByteString -> m () + getCurrentTransmissionSessionId :: m (Maybe ByteString) + updateTransmissionSessionId :: ByteString -> m () instance (MonadIO m) => MonadTransmission (AppT m) where - getTransmissionId = AppT (asks (.transmissionSessionId)) >>= tryTakeMVar - setTransmissionId t = do + getCurrentTransmissionSessionId = AppT (asks (.transmissionSessionId)) >>= readIORef + updateTransmissionSessionId t = do var <- AppT $ asks (.transmissionSessionId) - putMVar var t + writeIORef var (Just t) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index f1902bac8c..73a9dccb12 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -3,6 +3,7 @@ module WhatcdResolver where import AppT +import Arg import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack @@ -10,6 +11,7 @@ import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap +import Data.Error.Tree (prettyErrorTree) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map @@ -23,6 +25,7 @@ import FieldParser (FieldParser, FieldParser' (..)) import FieldParser qualified as Field import Html qualified import IHP.HSX.QQ (hsx) +import IHP.HSX.ToHtml (ToHtml) import Json qualified import Json.Enc (Enc) import Json.Enc qualified as Enc @@ -36,7 +39,6 @@ import Network.HTTP.Types import Network.HTTP.Types qualified as Http import Network.URI (URI) import Network.URI qualified -import Network.URI qualified as URI import Network.Wai (ResponseReceived) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp @@ -55,7 +57,6 @@ import System.Directory qualified as Xdg import System.Environment qualified as Env import System.FilePath ((</>)) 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 (readTool, readTools) @@ -77,7 +78,6 @@ main = htmlUi :: AppT IO () htmlUi = do - let debug = True uniqueRunId <- runTransaction $ querySingleRowWith @@ -87,13 +87,13 @@ htmlUi = do () (Dec.fromField @Text) - withRunInIO $ \runInIO -> Warp.run 9093 $ \req respond -> do + withRunInIO $ \runInIO -> Warp.run 9093 $ \req respondOrig -> do let catchAppException act = try act >>= \case Right a -> pure a Left (AppException err) -> do runInIO (logError err) - respond (Wai.responseLBS Http.status500 [] "") + respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = @@ -108,9 +108,6 @@ htmlUi = do ( do label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) ) - let parseQueryArgs span parser = - Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req - & assertM span id let parseQueryArgsNewSpan spanName parser = Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req @@ -119,9 +116,9 @@ htmlUi = do let handlers :: Handlers (AppT IO) handlers respond = Map.fromList - [ ("", respond.h (mainHtml uniqueRunId)), + [ ("", respond.html (mainHtml uniqueRunId)), ( "snips/redacted/search", - respond.h $ + respond.html $ \span -> do dat <- mp @@ -132,12 +129,12 @@ htmlUi = do snipsRedactedSearch dat ), ( "snips/redacted/torrentDataJson", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span Html.mkVal <$> (runTransaction $ getTorrentById dat) ), ( "snips/redacted/getTorrentFile", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do inserted <- redactedGetTorrentFileAndInsert dat @@ -157,7 +154,7 @@ htmlUi = do ), -- TODO: this is bad duplication?? ( "snips/redacted/startTorrentFile", - respond.h $ \span -> do + respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do file <- @@ -180,7 +177,7 @@ htmlUi = do "Starting" ), ( "snips/transmission/getTorrentState", - respond.h $ \span -> do + respond.html $ \span -> do dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 status <- doTransmissionRequest' @@ -199,17 +196,29 @@ htmlUi = do Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", - respond.h $ \span -> do - qry <- - parseQueryArgs - span - ( label @"target" - <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) - & Parse.andParse uriToHttpClientRequest - ) - ) - jsonld <- httpGetJsonLd (qry.target) - pure $ renderJsonld jsonld + do + let HandlerResponses {htmlWithQueryArgs} = respond + htmlWithQueryArgs + ( label @"target" + <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) + & Parse.andParse uriToHttpClientRequest + ) + ) + ( \qry _span -> do + jsonld <- httpGetJsonLd (qry.target) + pure $ renderJsonld jsonld + ) + ), + ( "artist", + do + let HandlerResponses {htmlWithQueryArgs} = respond + + htmlWithQueryArgs + ( label @"artistRedactedId" + <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) + ) + $ \qry _span -> do + artistPage qry ), ( "autorefresh", respond.plain $ do @@ -233,30 +242,62 @@ htmlUi = do ] runInIO $ runHandlers - debug - (\respond -> respond.h $ (mainHtml uniqueRunId)) + (\respond -> respond.html $ (mainHtml uniqueRunId)) handlers req - respond + respondOrig where everySecond :: Text -> Enc -> Html -> Html everySecond call extraData innerHtml = [hsx|<div hx-trigger="every 1s" hx-swap="outerHTML" hx-post={call} hx-vals={Enc.encToBytesUtf8 extraData}>{innerHtml}</div>|] mainHtml :: Text -> Otel.Span -> AppT IO Html mainHtml uniqueRunId _span = runTransaction $ do - jsonld <- - httpGetJsonLd - ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, - "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" - ) - <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable + -- jsonld <- + -- httpGetJsonLd + -- ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError, + -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" + -- ) + -- <&> renderJsonld + bestTorrentsTable <- getBestTorrentsTable Nothing -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ - Html.docTypeHtml + htmlPageChrome + "whatcd-resolver" [hsx| + <form + hx-post="/snips/redacted/search" + hx-target="#redacted-search-results"> + <label for="redacted-search">Redacted Search</label> + <input + id="redacted-search" + type="text" + name="redacted-search" /> + <button type="submit" hx-disabled-elt="this">Search</button> + <div class="htmx-indicator">Search running!</div> + </form> + <div id="redacted-search-results"> + {bestTorrentsTable} + </div> + <!-- refresh the page if the uniqueRunId is different --> + <input + hidden + type="text" + id="autorefresh" + name="hasItBeenRestarted" + value={uniqueRunId} + hx-get="/autorefresh" + hx-trigger="every 5s" + hx-swap="none" + /> + |] + +htmlPageChrome :: (ToHtml a) => Text -> a -> Html +htmlPageChrome title body = + Html.docTypeHtml $ + [hsx| <head> - <title>whatcd-resolver</title> + <!-- TODO: set nice page title for each page --> + <title>{title}</title> <meta charset="utf-8"> <meta name="viewport" content="width=device-width, initial-scale=1"> <link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" crossorigin="anonymous"> @@ -271,73 +312,96 @@ htmlUi = do </style> </head> <body> - {jsonld} - <form - hx-post="/snips/redacted/search" - hx-target="#redacted-search-results"> - <label for="redacted-search">Redacted Search</label> - <input - id="redacted-search" - type="text" - name="redacted-search" /> - <button type="submit" hx-disabled-elt="this">Search</button> - <div class="htmx-indicator">Search running!</div> - </form> - <div id="redacted-search-results"> - {bestTorrentsTable} - </div> - <!-- refresh the page if the uniqueRunId is different --> - <input - hidden - type="text" - id="autorefresh" - name="hasItBeenRestarted" - value={uniqueRunId} - hx-get="/autorefresh" - hx-trigger="every 5s" - hx-swap="none" - /> + {body} </body> |] +artistPage :: + ( HasField "artistRedactedId" dat Natural, + MonadPostgres m, + MonadOtel m, + MonadLogger m, + MonadThrow m, + MonadTransmission m + ) => + dat -> + m Html +artistPage dat = runTransaction $ do + fresh <- getBestTorrentsData (Just $ getLabel @"artistRedactedId" dat) + let artistName = fresh & findMaybe (\t -> t.artists & findMaybe (\a -> if a.artistId == (dat.artistRedactedId & fromIntegral @Natural @Int) then Just a.artistName else Nothing)) + let torrents = mkBestTorrentsTable fresh + pure $ + htmlPageChrome + ( case artistName of + Nothing -> "whatcd-resolver" + Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] + ) + [hsx| + Artist ID: {dat.artistRedactedId} + + {torrents} + |] + type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) -type HandlerResponses m = T2 "h" ((Otel.Span -> m Html) -> m ResponseReceived) "plain" (m Wai.Response -> m ResponseReceived) +data HandlerResponses m = HandlerResponses + { -- | render html + html :: (Otel.Span -> m Html) -> m ResponseReceived, + -- | render html after parsing some query arguments + htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived), + -- | render a plain wai response + plain :: (m Wai.Response -> m ResponseReceived) + } runHandlers :: (MonadOtel m) => - Bool -> (HandlerResponses m -> m ResponseReceived) -> (HandlerResponses m -> Map Text (m ResponseReceived)) -> Wai.Request -> (Wai.Response -> IO ResponseReceived) -> m ResponseReceived -runHandlers debug defaultHandler handlers req respond = withRunInIO $ \runInIO -> do - let renderHtml = - if debug - then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes - else Html.renderHtml - let hh route act = +runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do + let path = req & Wai.pathInfo & Text.intercalate "/" + let html act = Otel.inSpan' - [fmt|Route {route }|] + [fmt|Route /{path}|] ( Otel.defaultSpanArguments { Otel.attributes = HashMap.fromList - [ ("server.path", Otel.toAttribute @Text route) + [ ("_.server.path", Otel.toAttribute @Text path), + ("_.server.query_args", Otel.toAttribute @Text (req.rawQueryString & bytesToTextUtf8Lenient)) ] } ) ( \span -> do - res <- act span - liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . renderHtml $ res.html + res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" [])) + liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html ) - let h route act = hh route (\span -> act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" []))) - let path = (req & Wai.pathInfo & Text.intercalate "/") let handlerResponses = - ( T2 - (label @"h" (h path)) - (label @"plain" (\m -> liftIO $ runInIO m >>= respond)) + ( HandlerResponses + { plain = (\m -> liftIO $ runInIO m >>= respond), + html, + htmlWithQueryArgs = \parser act -> + case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of + Right a -> html (act a) + Left err -> + html + ( \span -> do + recordException + span + ( T2 + (label @"type_" "Query Parse Exception") + (label @"message" (prettyErrorTree err)) + ) + + pure + [hsx| + <h1>Error:</h1> + <pre>{err & prettyErrorTree}</pre> + |] + ) + } ) let handler = (handlers handlerResponses) @@ -417,7 +481,11 @@ snipsRedactedSearch dat = do ] runTransaction $ do t - getBestTorrentsTable + getBestTorrentsTable (Nothing :: Maybe (Label "artistRedactedId" Natural)) + +data ArtistFilter = ArtistFilter + { onlyArtist :: Maybe (Label "artistId" Text) + } getBestTorrentsTable :: ( MonadTransmission m, @@ -426,9 +494,23 @@ getBestTorrentsTable :: MonadPostgres m, MonadOtel m ) => + Maybe (Label "artistRedactedId" Natural) -> Transaction m Html -getBestTorrentsTable = do - bestStale :: [TorrentData ()] <- getBestTorrents +getBestTorrentsTable dat = do + fresh <- getBestTorrentsData dat + pure $ mkBestTorrentsTable fresh + +getBestTorrentsData :: + ( MonadTransmission m, + MonadThrow m, + MonadLogger m, + MonadPostgres m, + MonadOtel m + ) => + Maybe (Label "artistRedactedId" Natural) -> + Transaction m [TorrentData (Label "percentDone" Percentage)] +getBestTorrentsData artistFilter = do + bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} actual <- getAndUpdateTransmissionTorrentsStatus ( bestStale @@ -440,20 +522,23 @@ getBestTorrentsTable = do <&> (\t -> (getLabel @"torrentHash" t, t.transmissionInfo)) & Map.fromList ) - let fresh = - bestStale - -- we have to update the status of every torrent that’s not in tranmission anymore - -- TODO I feel like it’s easier (& more correct?) to just do the database request again … - <&> ( \td -> case td.torrentStatus of - InTransmission info -> - case actual & Map.lookup (getLabel @"torrentHash" info) of - -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, - -- which is an internal factum that is established in getBestTorrents (and might change later) - Nothing -> td {torrentStatus = NotInTransmissionYet} - Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} - NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} - NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} - ) + pure $ + bestStale + -- we have to update the status of every torrent that’s not in tranmission anymore + -- TODO I feel like it’s easier (& more correct?) to just do the database request again … + <&> ( \td -> case td.torrentStatus of + InTransmission info -> + case actual & Map.lookup (getLabel @"torrentHash" info) of + -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, + -- which is an internal factum that is established in getBestTorrents (and might change later) + Nothing -> td {torrentStatus = NotInTransmissionYet} + Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} + NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} + NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} + ) + +mkBestTorrentsTable :: [TorrentData (Label "percentDone" Percentage)] -> Html +mkBestTorrentsTable fresh = do let localTorrent b = case b.torrentStatus of NoTorrentFileYet -> [hsx|<button hx-post="snips/redacted/getTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button>|] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] @@ -462,19 +547,34 @@ getBestTorrentsTable = do fresh & foldMap ( \b -> do + let artists = + b.artists + <&> ( \a -> + T2 + (label @"url" [fmt|/artist?redacted_id={a.artistId}|]) + (label @"content" $ Html.toHtml @Text a.artistName) + ) + & mkLinkList + [hsx| <tr> <td>{localTorrent b}</td> <td>{Html.toHtml @Int b.groupId}</td> - <td>{Html.toHtml @Text b.torrentGroupJson.artist}</td> - <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td> + <td> + {artists} + </td> + <td> + <a href={mkRedactedTorrentLink (Arg b.groupId)} target="_blank"> + {Html.toHtml @Text b.torrentGroupJson.groupName} + </a> + </td> + <td>{Html.toHtml @Int b.torrentGroupJson.groupYear}</td> <td>{Html.toHtml @Int b.seedingWeight}</td> <td><details hx-trigger="toggle once" hx-post="snips/redacted/torrentDataJson" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}></details></td> </tr> |] ) - pure $ - [hsx| + [hsx| <table class="table"> <thead> <tr> @@ -482,6 +582,7 @@ getBestTorrentsTable = do <th>Group ID</th> <th>Artist</th> <th>Name</th> + <th>Year</th> <th>Weight</th> <th>Torrent</th> <th>Torrent Group</th> @@ -493,6 +594,15 @@ getBestTorrentsTable = do </table> |] +mkLinkList :: [T2 "url" Text "content" Html] -> Html +mkLinkList xs = + xs + <&> ( \x -> do + [hsx|<a href={x.url}>{x.content}</a>|] + ) + & List.intersperse ", " + & mconcat + getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html getTransmissionTorrentsTable = do @@ -556,35 +666,48 @@ migrate = inSpan "Database Migration" $ do UNIQUE(torrent_id) ); + CREATE INDEX IF NOT EXISTS redacted_torrents_json_torrent_group_fk ON redacted.torrents_json (torrent_group); + + ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS torrent_file bytea NULL; ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS transmission_torrent_hash text NULL; - -- inflect out values of the full json + -- the seeding weight is used to find the best torrent in a group. + CREATE OR REPLACE FUNCTION calc_seeding_weight(full_json_result jsonb) RETURNS int AS $$ + BEGIN + RETURN + ((full_json_result->'seeders')::integer*3 + + (full_json_result->'snatches')::integer + ) + -- prefer remasters by multiplying them with 3 + * (CASE + WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' + THEN 3 + ELSE 1 + END); + END; + $$ LANGUAGE plpgsql IMMUTABLE; + + ALTER TABLE redacted.torrents_json + ADD COLUMN IF NOT EXISTS seeding_weight int GENERATED ALWAYS AS (calc_seeding_weight(full_json_result)) STORED; + + -- inflect out values of the full json CREATE OR REPLACE VIEW redacted.torrents AS SELECT t.id, t.torrent_id, t.torrent_group, -- the seeding weight is used to find the best torrent in a group. - ( ((full_json_result->'seeders')::integer*3 - + (full_json_result->'snatches')::integer - ) - -- prefer remasters by multiplying them with 3 - * (CASE - WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' - THEN 3 - ELSE 1 - END) - ) - AS seeding_weight, + t.seeding_weight, t.full_json_result, t.torrent_file, t.transmission_torrent_hash FROM redacted.torrents_json t; + CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer)); CREATE INDEX IF NOT EXISTS torrents_json_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer)); |] @@ -624,7 +747,8 @@ httpTorrent span req = 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") + tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") + pgFormat <- initPgFormatPool (label @"pgFormat" tool) let config = label @"logDatabaseQueries" LogDatabaseQueries pgConnPool <- Pool.newPool $ @@ -633,7 +757,7 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do {- resource destruction -} Postgres.close {- unusedResourceOpenTime -} 10 {- max resources across all stripes -} 20 - transmissionSessionId <- newEmptyMVar + transmissionSessionId <- newIORef Nothing let newAppT = do logInfo [fmt|Running with config: {showPretty config}|] logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|] diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index a9bd04827b..8b3258bb5f 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -119,3 +119,7 @@ executable whatcd-resolver build-depends: base >=4.15 && <5, whatcd-resolver + + ghc-options: + -threaded + diff --git a/users/amjoseph/OWNERS b/users/amjoseph/OWNERS new file mode 100644 index 0000000000..a99992be60 --- /dev/null +++ b/users/amjoseph/OWNERS @@ -0,0 +1,3 @@ +set noparent + +amjoseph diff --git a/users/amjoseph/keys.nix b/users/amjoseph/keys.nix new file mode 100644 index 0000000000..8cc2f24369 --- /dev/null +++ b/users/amjoseph/keys.nix @@ -0,0 +1,22 @@ +{ ... }: + +let + # Long-term, air-gapped PGP key. This key is used only for signing other + # keys. It is a minor hassle for me to access this key. + airgap = "F0B74D717CDE8412A3E0D4D5F29AC8080DA8E1E0"; + + # Stored in an HSM. Signed by the above key. + current = "D930411B675A011EB9590713DC4AB809B13BE76D"; + + # Chat protocols that depend on DNS, WebPKI, or E.164 are lame. This is not. + ricochet = "emhxygy5mezcovm5a6q5hze5eqfqgieww56eh4ttwmrolwqmzgb6qiyd"; + + # This ssh key is for depot. Please don't use it elsewhere, except to give + # me the ability to set a system-specific key elsewhere. Not currently + # stored in an HSM, but I'm working on that. + ssh-for-depot = "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOE5e0HrwQTI5KOaU12J0AJG5zDpWn4g/U+oFXz7SkbD"; + +in +{ + all = [ ssh-for-depot ]; +} diff --git a/users/flokli/archeology/default.nix b/users/flokli/archeology/default.nix index d642399cbe..690944403b 100644 --- a/users/flokli/archeology/default.nix +++ b/users/flokli/archeology/default.nix @@ -10,7 +10,7 @@ let ''; # clickhouse has a very odd AWS config concept. # Configure it to be a bit more sane. - clickhoseLocalFixedAWS = pkgs.runCommand "clickhouse-local-fixed" + clickhouseLocalFixedAWS = pkgs.runCommand "clickhouse-local-fixed" { nativeBuildInputs = [ pkgs.makeWrapper ]; } '' @@ -21,19 +21,19 @@ let in depot.nix.readTree.drvTargets { - inherit clickhoseLocalFixedAWS; + inherit clickhouseLocalFixedAWS; parse-bucket-logs = pkgs.runCommand "archeology-parse-bucket-logs" { nativeBuildInputs = [ pkgs.makeWrapper ]; } '' mkdir -p $out/bin makeWrapper ${(pkgs.writers.writeRust "parse-bucket-logs-unwrapped" {} ./parse_bucket_logs.rs)} $out/bin/archeology-parse-bucket-logs \ - --prefix PATH : ${pkgs.lib.makeBinPath [ clickhoseLocalFixedAWS ]} + --prefix PATH : ${pkgs.lib.makeBinPath [ clickhouseLocalFixedAWS ]} ''; shell = pkgs.mkShell { name = "archeology-shell"; - packages = with pkgs; [ awscli2 clickhoseLocalFixedAWS rust-analyzer rustc rustfmt ]; + packages = with pkgs; [ awscli2 clickhouseLocalFixedAWS rust-analyzer rustc rustfmt ]; AWS_PROFILE = "sso"; AWS_CONFIG_FILE = pkgs.writeText "aws-config" '' diff --git a/users/flokli/keyboards/dilemma/default.nix b/users/flokli/keyboards/dilemma/default.nix index 265f8e56db..cd05b288e8 100644 --- a/users/flokli/keyboards/dilemma/default.nix +++ b/users/flokli/keyboards/dilemma/default.nix @@ -1,16 +1,18 @@ { depot, pkgs, ... }: rec { + qmk_firmware_src = pkgs.fetchFromGitHub { + owner = "qmk"; + repo = "qmk_firmware"; + rev = "0.24.8"; + hash = "sha256-DRHPfJXF1KF1+EwkbeGhqhVrpfp21JY2spOZxesZFbA="; + fetchSubmodules = true; + }; + firmware = pkgs.stdenv.mkDerivation { name = "keychron-bastardkb-dilemma-firmware"; - src = pkgs.fetchFromGitHub { - owner = "qmk"; - repo = "qmk_firmware"; - rev = "728aa576b0cd65c6fb7cf77132fdcd06fcedb643"; # develop branch - hash = "sha256-YmdX8nEsB1R8d265HAmvwejPjEHJdoTnm4QNigzrcyw="; - fetchSubmodules = true; - }; + src = qmk_firmware_src; patches = [ ./enable-taps.patch ]; @@ -38,7 +40,7 @@ rec { }; flash = pkgs.writeShellScript "flash.sh" '' - ${pkgs.qmk}/bin/qmk flash ${firmware}/bastardkb_dilemma_3x5_3_flokli.uf2 + QMK_HOME=${qmk_firmware_src} ${pkgs.qmk}/bin/qmk flash ${firmware}/bastardkb_dilemma_3x5_3_flokli.uf2 ''; meta.ci.targets = [ "firmware" ]; diff --git a/users/flokli/keyboards/k6_pro/default.nix b/users/flokli/keyboards/k6_pro/default.nix index 708bec7313..49945b88ae 100644 --- a/users/flokli/keyboards/k6_pro/default.nix +++ b/users/flokli/keyboards/k6_pro/default.nix @@ -1,16 +1,18 @@ { depot, pkgs, ... }: rec { + qmk_firmware_src = pkgs.fetchFromGitHub { + owner = "Keychron"; # the Keychron fork of qmk/qmk_firmware + repo = "qmk_firmware"; + rev = "e0a48783e7cde92d1edfc53a8fff511c45e869d4"; # bluetooth_playground branch + hash = "sha256-Pk9kXktmej9JyvSt7UMEW2FDrBg7k1lOssh6HjrP5ro="; + fetchSubmodules = true; + }; + firmware = pkgs.stdenv.mkDerivation { name = "keychron-k6_pro-firmware"; - src = pkgs.fetchFromGitHub { - owner = "Keychron"; # the Keychron fork of qmk/qmk_firmware - repo = "qmk_firmware"; - rev = "e0a48783e7cde92d1edfc53a8fff511c45e869d4"; # bluetooth_playground branch - hash = "sha256-Pk9kXktmej9JyvSt7UMEW2FDrBg7k1lOssh6HjrP5ro="; - fetchSubmodules = true; - }; + src = qmk_firmware_src; nativeBuildInputs = [ pkgs.qmk @@ -32,7 +34,7 @@ rec { }; flash = pkgs.writeShellScript "flash.sh" '' - ${pkgs.qmk}/bin/qmk flash ${firmware}/keychron_k6_pro_ansi_rgb_flokli.bin + QMK_HOME=${qmk_firmware_src} ${pkgs.qmk}/bin/qmk flash ${firmware}/keychron_k6_pro_ansi_rgb_flokli.bin ''; meta.ci.targets = [ "firmware" ]; diff --git a/users/tazjin/emacs/config/settings.el b/users/tazjin/emacs/config/settings.el index 6c66ca608d..afe181b70b 100644 --- a/users/tazjin/emacs/config/settings.el +++ b/users/tazjin/emacs/config/settings.el @@ -19,6 +19,9 @@ ediff-split-window-function 'split-window-horizontally initial-major-mode 'emacs-lisp-mode) +(setq-default tab-width 4) +(setq-default fill-column 80) + (add-to-list 'safe-local-variable-values '(lexical-binding . t)) (add-to-list 'safe-local-variable-values '(whitespace-line-column . 80)) diff --git a/users/tazjin/nixos/modules/physical.nix b/users/tazjin/nixos/modules/physical.nix index bb85c6fb98..d469da7e5a 100644 --- a/users/tazjin/nixos/modules/physical.nix +++ b/users/tazjin/nixos/modules/physical.nix @@ -24,6 +24,7 @@ in users.tazjin.chase-geese config.tazjin.emacs third_party.agenix.cli + tools.when ]) ++ # programs from nixpkgs |