diff options
Diffstat (limited to 'users')
20 files changed, 412 insertions, 131 deletions
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..a542f8c7b8 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,105 @@ 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 + putStderrLn "Running with warm pgformatter" + 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 +528,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 +546,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 +563,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 +590,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 +599,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 +611,7 @@ foldRowsWithAccImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -535,7 +645,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 +681,7 @@ queryWithImpl :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => m tools -> @@ -582,7 +692,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 +703,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 +729,7 @@ pgFormatQuery' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -633,7 +743,7 @@ pgFormatQueryMany' :: ( MonadIO m, ToRow params, MonadLogger m, - HasField "pgFormat" tools Tool + HasField "pgFormat" tools PgFormatPool ) => tools -> Query -> @@ -650,33 +760,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 +832,7 @@ traceQueryIfEnabled :: ( ToRow params, MonadUnliftIO m, MonadLogger m, - HasField "pgFormat" tools Tool, + HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m ) => tools -> @@ -708,20 +843,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 +890,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/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 7afd430745..abe8ccad4c 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -19,14 +19,13 @@ 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 } diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 4369c18408..c0c26b72d6 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -382,8 +382,8 @@ getTorrentById dat = do >>= ensureSingleRow -- | Find the best torrent for each torrent group (based on the seeding_weight) -getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()] -getBestTorrents = do +getBestTorrents :: (MonadPostgres m, HasField "onlyDownloaded" opts Bool) => opts -> Transaction m [TorrentData ()] +getBestTorrents opts = do queryWith [sql| SELECT * FROM ( @@ -393,15 +393,18 @@ getBestTorrents = do seeding_weight, t.full_json_result AS torrent_json, tg.full_json_result AS torrent_group_json, - t.torrent_file IS NOT NULL, + t.torrent_file IS NOT NULL as has_torrent_file, 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 _ + WHERE + -- onlyDownloaded + ((NOT ?::bool) OR has_torrent_file) ORDER BY seeding_weight DESC |] - () + (Only opts.onlyDownloaded :: Only Bool) ( do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index f1902bac8c..1ec23e1fc7 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -36,7 +36,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 +54,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 +75,6 @@ main = htmlUi :: AppT IO () htmlUi = do - let debug = True uniqueRunId <- runTransaction $ querySingleRowWith @@ -87,13 +84,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 = @@ -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,7 +196,7 @@ htmlUi = do Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", - respond.h $ \span -> do + respond.html $ \span -> do qry <- parseQueryArgs span @@ -211,6 +208,16 @@ htmlUi = do jsonld <- httpGetJsonLd (qry.target) pure $ renderJsonld jsonld ), + ( "artist", + respond.html $ \span -> do + qry <- + parseQueryArgs + span + ( label @"dbId" + <$> (singleQueryArgument "db_id" Field.utf8) + ) + artistPage qry + ), ( "autorefresh", respond.plain $ do qry <- @@ -233,23 +240,22 @@ 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 + -- 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 -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ @@ -271,7 +277,6 @@ htmlUi = do </style> </head> <body> - {jsonld} <form hx-post="/snips/redacted/search" hx-target="#redacted-search-results"> @@ -300,44 +305,49 @@ htmlUi = do </body> |] +artistPage :: (HasField "dbId" dat Text, Applicative m) => dat -> m Html +artistPage dat = do + pure + [hsx| + Artist ID: {dat.dbId} + |] + 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 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 = - Otel.inSpan' - [fmt|Route {route }|] - ( Otel.defaultSpanArguments - { Otel.attributes = - HashMap.fromList - [ ("server.path", Otel.toAttribute @Text route) - ] - } - ) - ( \span -> do - res <- act span - liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . 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 "/") +runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do + 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 = \act -> + Otel.inSpan' + [fmt|Route /{path}|] + ( Otel.defaultSpanArguments + { Otel.attributes = + HashMap.fromList + [ ("server.path", Otel.toAttribute @Text path) + ] + } + ) + ( \span -> do + res <- act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" [])) + liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html + ) + } ) let handler = (handlers handlerResponses) @@ -428,7 +438,7 @@ getBestTorrentsTable :: ) => Transaction m Html getBestTorrentsTable = do - bestStale :: [TorrentData ()] <- getBestTorrents + bestStale :: [TorrentData ()] <- getBestTorrents (label @"onlyDownloaded" False) actual <- getAndUpdateTransmissionTorrentsStatus ( bestStale @@ -462,11 +472,16 @@ getBestTorrentsTable = do fresh & foldMap ( \b -> do + let artistLink :: Text = [fmt|/artist?db_id={b.groupId}|] [hsx| <tr> <td>{localTorrent b}</td> <td>{Html.toHtml @Int b.groupId}</td> - <td>{Html.toHtml @Text b.torrentGroupJson.artist}</td> + <td> + <a href={artistLink}> + {Html.toHtml @Text b.torrentGroupJson.artist} + </a> + </td> <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</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> @@ -624,7 +639,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 $ 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/aspen/system/home/modules/games.nix b/users/aspen/system/home/modules/games.nix index b7653bb058..dc6331d648 100644 --- a/users/aspen/system/home/modules/games.nix +++ b/users/aspen/system/home/modules/games.nix @@ -15,14 +15,14 @@ let }); init = runCommand "init.txt" { } '' - substitute "${df-orig}/data/init/init.txt" $out \ + substitute "${df-orig}/data/init/init_default.txt" $out \ --replace "[INTRO:YES]" "[INTRO:NO]" \ --replace "[VOLUME:255]" "[VOLUME:0]" \ --replace "[FPS:NO]" "[FPS:YES]" ''; d_init = runCommand "d_init.txt" { } '' - substitute "${df-orig}/data/init/d_init.txt" $out \ + substitute "${df-orig}/data/init/d_init_default.txt" $out \ --replace "[AUTOSAVE:NONE]" "[AUTOSAVE:SEASONAL]" \ --replace "[AUTOSAVE_PAUSE:NO]" "[AUTOSAVE_PAUSE:YES]" \ --replace "[INITIAL_SAVE:NO]" "[INITIAL_SAVE:YES]" \ 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/picnoir/tvix-daemon/src/main.rs b/users/picnoir/tvix-daemon/src/main.rs index 102067fcf7..dc49b209e0 100644 --- a/users/picnoir/tvix-daemon/src/main.rs +++ b/users/picnoir/tvix-daemon/src/main.rs @@ -4,7 +4,7 @@ use tokio_listener::{self, SystemOptions, UserOptions}; use tracing::{debug, error, info, instrument, Level}; use nix_compat::worker_protocol::{self, server_handshake_client, ClientSettings, Trust}; -use nix_compat::{wire, ProtocolVersion}; +use nix_compat::ProtocolVersion; #[derive(Parser, Debug)] struct Cli { @@ -78,7 +78,9 @@ where // TODO: implement logging. For now, we'll just send // STDERR_LAST, which is good enough to get Nix respond to // us. - wire::write_u64(&mut client_connection.conn, worker_protocol::STDERR_LAST) + client_connection + .conn + .write_u64_le(worker_protocol::STDERR_LAST) .await .unwrap(); loop { @@ -109,6 +111,6 @@ where let settings = worker_protocol::read_client_settings(&mut conn.conn, conn.version).await?; // The client expects us to send some logs when we're processing // the settings. Sending STDERR_LAST signal we're done processing. - wire::write_u64(&mut conn.conn, worker_protocol::STDERR_LAST).await?; + conn.conn.write_u64_le(worker_protocol::STDERR_LAST).await?; Ok(settings) } diff --git a/users/sterni/machines/ingeborg/default.nix b/users/sterni/machines/ingeborg/default.nix index 0e5a30a7c8..2d026ae05b 100644 --- a/users/sterni/machines/ingeborg/default.nix +++ b/users/sterni/machines/ingeborg/default.nix @@ -17,6 +17,7 @@ ./http/code.sterni.lv.nix ./http/flipdot.openlab-augsburg.de.nix ./tv.nix + ./quassel.nix # Inactive: # ./http/likely-music.sterni.lv.nix diff --git a/users/sterni/machines/ingeborg/quassel.nix b/users/sterni/machines/ingeborg/quassel.nix new file mode 100644 index 0000000000..cd8dacc917 --- /dev/null +++ b/users/sterni/machines/ingeborg/quassel.nix @@ -0,0 +1,18 @@ +{ depot, ... }: + +{ + imports = [ + (depot.path.origSrc + "/ops/modules/quassel.nix") + ]; + + config = { + services.depot.quassel = { + enable = true; + acmeHost = "sterni.lv"; + bindAddresses = [ + "0.0.0.0" + "::" + ]; + }; + }; +} diff --git a/users/sterni/modules/common.nix b/users/sterni/modules/common.nix index ef039fe4de..2c513acad3 100644 --- a/users/sterni/modules/common.nix +++ b/users/sterni/modules/common.nix @@ -58,7 +58,6 @@ in }; environment.systemPackages = [ - pkgs.weechat pkgs.wget pkgs.git pkgs.stow diff --git a/users/tazjin/nixos/koptevo/default.nix b/users/tazjin/nixos/koptevo/default.nix index 39a4887c72..ea8dfd4bd8 100644 --- a/users/tazjin/nixos/koptevo/default.nix +++ b/users/tazjin/nixos/koptevo/default.nix @@ -129,10 +129,11 @@ in ''; }; - # I don't use the podcast feature, but I *have to* supply podcasts - # to gonic ... + # I don't use the podcast nor playlist feature, + # but I *have to* supply podcasts to gonic ... systemd.tmpfiles.rules = [ "d /tmp/fake-podcasts 0555 nobody nobody -" + "d /tmp/fake-playlists 0555 nobody nobody -" ]; services.gonic = { @@ -142,6 +143,7 @@ in scan-interval = 5; scan-at-start-enabled = true; podcast-path = [ "/tmp/fake-podcasts" ]; + playlists-path = [ "/tmp/fake-playlists" ]; music-path = [ "/var/lib/geesefs/tazjins-files/music" ]; }; }; diff --git a/users/tazjin/nixos/modules/physical.nix b/users/tazjin/nixos/modules/physical.nix index 6d48a076bf..d469da7e5a 100644 --- a/users/tazjin/nixos/modules/physical.nix +++ b/users/tazjin/nixos/modules/physical.nix @@ -24,7 +24,7 @@ in users.tazjin.chase-geese config.tazjin.emacs third_party.agenix.cli - third_party.josh + tools.when ]) ++ # programs from nixpkgs @@ -50,6 +50,7 @@ in hyperfine iftop imagemagick + josh jq lieer maim |