diff options
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Postgres/Decoder.hs | 63 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/AppT.hs | 10 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 24 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 27 |
4 files changed, 104 insertions, 20 deletions
diff --git a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs index 008b89b4ba3d..92fe5cc7d2fe 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs @@ -8,6 +8,8 @@ import Data.Typeable (Typeable) import Database.PostgreSQL.Simple (Binary (fromBinary)) import Database.PostgreSQL.Simple.FromField qualified as PG import Database.PostgreSQL.Simple.FromRow qualified as PG +import FieldParser (FieldParser) +import FieldParser qualified as Field import Json qualified import Label import PossehlAnalyticsPrelude @@ -24,12 +26,65 @@ bytea = fromField @(Binary ByteString) <&> (.fromBinary) byteaMay :: Decoder (Maybe ByteString) byteaMay = fromField @(Maybe (Binary ByteString)) <&> fmap (.fromBinary) +-- | Parse a `text` field. +text :: Decoder Text +text = fromField @Text + +-- | Parse a nullable `text` field. +textMay :: Decoder (Maybe Text) +textMay = fromField @(Maybe Text) + +-- | Parse a `text` field, and then use a 'FieldParser' to convert the result further. +textParse :: (Typeable to) => FieldParser Text to -> Decoder to +textParse = parse @Text + +-- | Parse a nullable `text` field, and then use a 'FieldParser' to convert the result further. +textParseMay :: (Typeable to) => FieldParser Text to -> Decoder (Maybe to) +textParseMay = parseMay @Text + +-- | Parse a type implementing 'FromField', and then use a 'FieldParser' to convert the result further. +parse :: + forall from to. + ( PG.FromField from, + Typeable to + ) => + FieldParser from to -> + Decoder to +parse parser = Decoder $ PG.fieldWith $ \field bytes -> do + val <- PG.fromField @from field bytes + case Field.runFieldParser parser val of + Left err -> + PG.returnError + PG.ConversionFailed + field + (err & prettyError & textToString) + Right a -> pure a + +-- | Parse a nullable type implementing 'FromField', and then use a 'FieldParser' to convert the result further. +parseMay :: + forall from to. + ( PG.FromField from, + Typeable to + ) => + FieldParser from to -> + Decoder (Maybe to) +parseMay parser = Decoder $ PG.fieldWith $ \field bytes -> do + val <- PG.fromField @(Maybe from) field bytes + case Field.runFieldParser parser <$> val of + Nothing -> pure Nothing + Just (Left err) -> + PG.returnError + PG.ConversionFailed + field + (err & prettyError & textToString) + Just (Right a) -> pure (Just a) + -- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions: -- -- @ -- fromField @Text :: Decoder Text -- @ -fromField :: PG.FromField a => Decoder a +fromField :: (PG.FromField a) => Decoder a fromField = Decoder $ PG.fieldWith PG.fromField -- | Turn any type that implements 'PG.fromField' into a 'Decoder' and wrap the result into the given 'Label'. Use type applications to prevent accidental conversions: @@ -37,7 +92,7 @@ fromField = Decoder $ PG.fieldWith PG.fromField -- @ -- fromField @"myField" @Text :: Decoder (Label "myField" Text) -- @ -fromFieldLabel :: forall lbl a. PG.FromField a => Decoder (Label lbl a) +fromFieldLabel :: forall lbl a. (PG.FromField a) => Decoder (Label lbl a) fromFieldLabel = label @lbl <$> fromField -- | Parse fields out of a json value returned from the database. @@ -55,7 +110,7 @@ fromFieldLabel = label @lbl <$> fromField -- -- Also note: `->>` will coerce the json value to @text@, regardless of the content. -- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@. -json :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder a +json :: (Typeable a) => Json.ParseT ErrorTree Identity a -> Decoder a json parser = Decoder $ PG.fieldWith $ \field bytes -> do val <- PG.fromField @Json.Value field bytes case Json.parseValue parser val of @@ -81,7 +136,7 @@ json parser = Decoder $ PG.fieldWith $ \field bytes -> do -- -- Also note: `->>` will coerce the json value to @text@, regardless of the content. -- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@. -jsonMay :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a) +jsonMay :: (Typeable a) => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a) jsonMay parser = Decoder $ PG.fieldWith $ \field bytes -> do val <- PG.fromField @(Maybe Json.Value) field bytes case Json.parseValue parser <$> val of diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 397ea5c33b2f..6a8637bb1660 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -74,6 +74,16 @@ addAttribute span key a = Otel.addAttribute span ("_." <> key) a addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m () addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>) +addEventSimple :: (MonadIO m) => Otel.Span -> Text -> m () +addEventSimple span name = + Otel.addEvent + span + Otel.NewEvent + { Otel.newEventName = name, + Otel.newEventTimestamp = Nothing, + Otel.newEventAttributes = mempty + } + -- | Create an otel attribute from a json encoder jsonAttribute :: Enc -> Otel.Attribute jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 6cdb22273fad..5b6751346b18 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -364,14 +364,13 @@ data TorrentData transmissionInfo = TorrentData torrentId :: Int, seedingWeight :: Int, artists :: [T2 "artistId" Int "artistName" Text], - torrentJson :: Json.Value, torrentGroupJson :: TorrentGroupJson, torrentStatus :: TorrentStatus transmissionInfo } data TorrentGroupJson = TorrentGroupJson { groupName :: Text, - groupYear :: Int + groupYear :: Natural } data TorrentStatus transmissionInfo @@ -420,8 +419,9 @@ getBestTorrents opts = do 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.full_json_result->'artists' AS artists, + tg.full_json_result->>'groupName' AS group_name, + tg.full_json_result->>'groupYear' AS group_year, t.torrent_file IS NOT NULL AS has_torrent_file, t.transmission_torrent_hash FROM filtered_torrents f @@ -442,19 +442,15 @@ getBestTorrents opts = do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int - (torrentJson, artists) <- Dec.json $ do - val <- Json.asValue - artists <- Json.keyOrDefault "artists" [] $ Json.eachInArray $ do + artists <- Dec.json $ + 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 - groupName <- Json.key "groupName" Json.asText - groupYear <- Json.key "groupYear" (Json.asIntegral @_ @Int) - pure $ TorrentGroupJson {..} - ) + torrentGroupJson <- do + groupName <- Dec.text + groupYear <- Dec.textParse Field.decimalNatural + pure $ TorrentGroupJson {..} hasTorrentFile <- Dec.fromField @Bool transmissionTorrentHash <- Dec.fromField @(Maybe Text) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 169d3b82aa46..ad363090ffdd 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -388,6 +388,7 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do ) ( \span -> do res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" [])) + addEventSimple span "Got Html result, rendering…" liftIO $ respond (resp res) ) let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html @@ -444,6 +445,24 @@ singleQueryArgument field inner = ) >>> Parse.fieldParser inner +singleQueryArgumentMay :: Text -> FieldParser ByteString to -> Parse Http.Query (Maybe to) +singleQueryArgumentMay field inner = + Parse.mkParsePushContext + field + ( \(ctx, qry) -> case qry + & mapMaybe + ( \(k, v) -> + if k == (field & textToBytesUtf8) + then Just v + else Nothing + ) of + [] -> Right Nothing + [Nothing] -> Left [fmt|Expected one query argument with a value, but "{field}" was a query flag|] + [Just one] -> Right (Just one) + more -> Left [fmt|More than one value for query argument "{field}": {show more}, at {ctx & Parse.showContext}|] + ) + >>> Parse.maybe (Parse.fieldParser inner) + -- | Make sure we can parse the given Text into an URI. textToURI :: Parse Text URI textToURI = @@ -518,6 +537,9 @@ getBestTorrentsTable dat = do fresh <- getBestTorrentsData dat pure $ mkBestTorrentsTable fresh +doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () +doIfJust = traverse_ + getBestTorrentsData :: ( MonadTransmission m, MonadThrow m, @@ -527,7 +549,8 @@ getBestTorrentsData :: ) => Maybe (Label "artistRedactedId" Natural) -> Transaction m [TorrentData (Label "percentDone" Percentage)] -getBestTorrentsData artistFilter = do +getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> do + artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId & showToText & Otel.toAttribute)) bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} actual <- getAndUpdateTransmissionTorrentsStatus @@ -596,7 +619,7 @@ mkBestTorrentsTable fresh = do {Html.toHtml @Text b.torrentGroupJson.groupName} </a> </td> - <td>{Html.toHtml @Int b.torrentGroupJson.groupYear}</td> + <td>{Html.toHtml @Natural 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> |