From d379e1742fc101c84fc561df379521a3d973d00e Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Mon, 10 Mar 2025 23:10:12 +0100 Subject: [PATCH] refactor(users/Profpatsch/whatcd-resolver): init MyLabel move the label stuff into its own temporary module (until we figure out what to put into pa-label). Also rewrite a few things to use t2/t3. Change-Id: I8cc8678ec01a56d6c738eb4833a3ba566a7a1e20 Reviewed-on: https://cl.tvl.fyi/c/depot/+/13242 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- users/Profpatsch/whatcd-resolver/default.nix | 1 + .../Profpatsch/whatcd-resolver/src/MyLabel.hs | 47 +++++++++++++++ .../whatcd-resolver/src/Redacted.hs | 58 ++++++++++++------- .../whatcd-resolver/src/WhatcdResolver.hs | 42 +------------- .../whatcd-resolver/whatcd-resolver.cabal | 4 ++ 5 files changed, 90 insertions(+), 62 deletions(-) create mode 100644 users/Profpatsch/whatcd-resolver/src/MyLabel.hs diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix index ab52c3225..db8c3b009 100644 --- a/users/Profpatsch/whatcd-resolver/default.nix +++ b/users/Profpatsch/whatcd-resolver/default.nix @@ -13,6 +13,7 @@ let ./src/WhatcdResolver.hs ./src/AppT.hs ./src/Bencode.hs + ./src/MyLabel.hs ./src/JsonLd.hs ./src/Optional.hs ./src/Html.hs diff --git a/users/Profpatsch/whatcd-resolver/src/MyLabel.hs b/users/Profpatsch/whatcd-resolver/src/MyLabel.hs new file mode 100644 index 000000000..5941d2875 --- /dev/null +++ b/users/Profpatsch/whatcd-resolver/src/MyLabel.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module MyLabel where + +import GHC.OverloadedLabels (IsLabel (fromLabel)) +import GHC.Records (HasField (..)) +import GHC.TypeLits (Symbol) +import Label +import MyPrelude +import Prelude hiding (span) + +-- case-match on an e2 with a t2 that provides the relevant functions +caseE2 :: + forall l1 t1 l2 t2 matcher r. + ( HasField l1 matcher (t1 -> r), + HasField l2 matcher (t2 -> r) + ) => + matcher -> + E2 l1 t1 l2 t2 -> + r +{-# INLINE caseE2 #-} +caseE2 m e2 = do + let f1 = getField @l1 m + let f2 = getField @l2 m + case e2 of + E21 a -> f1 $ getField @l1 a + E22 b -> f2 $ getField @l2 b + +t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2 t2 +{-# INLINE t2 #-} +t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b) + +t3 :: forall l1 t1 l2 t2 l3 t3. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> LabelPrx l3 -> t3 -> T3 l1 t1 l2 t2 l3 t3 +{-# INLINE t3 #-} +t3 LabelPrx a LabelPrx b LabelPrx c = T3 (label @l1 a) (label @l2 b) (label @l3 c) + +lbl :: forall l t. LabelPrx l -> t -> Label l t +{-# INLINE lbl #-} +lbl LabelPrx a = label @l a + +data LabelPrx (l :: Symbol) = LabelPrx + +instance (l ~ l') => IsLabel l (LabelPrx l') where + fromLabel = LabelPrx + +instance (t ~ t') => IsLabel l (t -> (Label l t')) where + fromLabel = label @l diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 41e55e320..14714e3a4 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -27,6 +27,7 @@ import FieldParser qualified as Field import Http qualified import Json qualified import Label +import MyLabel import MyPrelude import Network.HTTP.Types import Network.Wai.Parse qualified as Wai @@ -60,10 +61,13 @@ redactedSearch extraArguments dat parser = inSpan' "Redacted API Search" $ \span -> redactedPagedRequest span - ( T3 - (label @"action" "browse") - (getLabel @"actionArgs" extraArguments) - (getLabel @"page" dat) + ( t3 + #action + "browse" + #actionArgs + extraArguments.actionArgs + #page + dat.page ) parser @@ -81,10 +85,13 @@ redactedGetArtist dat parser = inSpan' "Redacted Get Artist" $ \span -> do redactedPagedRequest span - ( T3 - (label @"action" "artist") - (label @"actionArgs" [("id", buildBytes intDecimalB dat.artistId)]) - (getLabel @"page" dat) + ( t3 + #action + "artist" + #actionArgs + [("id", buildBytes intDecimalB dat.artistId)] + #page + (dat.page) ) parser @@ -103,14 +110,15 @@ redactedPagedRequest :: redactedPagedRequest span dat parser = redactedApiRequestJson span - ( T2 - (label @"action" dat.action) - ( label @"actionArgs" $ - (dat.actionArgs <&> second Just) - <> ( dat.page - & ifExists - (\page -> ("page", Just $ buildBytes naturalDecimalB page)) - ) + ( t2 + #action + dat.action + #actionArgs + ( (dat.actionArgs <&> second Just) + <> ( dat.page + & ifExists + (\page -> ("page", Just $ buildBytes naturalDecimalB page)) + ) ) ) parser @@ -149,7 +157,7 @@ mkRedactedTorrentLink torrentId = [fmt|https://redacted.sh/torrents.php?id={torr exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m, MonadRedacted m) => m (Transaction m ()) exampleSearch = do - t1 <- + x1 <- redactedSearchAndInsert [ ("searchstr", "cherish"), ("artistname", "kirinji"), @@ -158,7 +166,7 @@ exampleSearch = do -- ("releasetype", "album"), ("order_by", "year") ] - t3 <- + x3 <- redactedSearchAndInsert [ ("searchstr", "mouss et hakim"), ("artistname", "mouss et hakim"), @@ -167,7 +175,7 @@ exampleSearch = do -- ("releasetype", "album"), ("order_by", "year") ] - t2 <- + x2 <- redactedSearchAndInsert [ ("searchstr", "thriller"), ("artistname", "michael jackson"), @@ -176,7 +184,7 @@ exampleSearch = do -- ("releasetype", "album"), ("order_by", "year") ] - pure (t1 >> t2 >> t3 >> pure ()) + pure (x1 >> x2 >> x3 >> pure ()) redactedRefreshArtist :: ( MonadLogger m, @@ -190,7 +198,15 @@ redactedRefreshArtist :: m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) redactedRefreshArtist dat = do redactedPagedSearchAndInsert - (Json.key "torrentgroup" $ parseTourGroups (T2 (label @"torrentFieldName" "torrent") (label @"torrentIdName" "id"))) + ( Json.key "torrentgroup" $ + parseTourGroups + ( t2 + #torrentFieldName + "torrent" + #torrentIdName + "id" + ) + ) ( \page -> redactedGetArtist ( T2 diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index a516136c8..77f031cfa 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE QuasiQuotes #-} -{-# OPTIONS_GHC -Wno-orphans #-} module WhatcdResolver where @@ -32,9 +30,7 @@ import Database.PostgreSQL.Simple.Types (Only (..), PGArray (PGArray)) import Database.Postgres.Temp qualified as TmpPg import FieldParser (FieldParser) import FieldParser qualified as Field -import GHC.OverloadedLabels (IsLabel (fromLabel)) import GHC.Records (HasField (..)) -import GHC.TypeLits (Symbol) import Html qualified import Http import IHP.HSX.QQ (hsx) @@ -46,6 +42,7 @@ import JsonLd import Label import Multipart2 (MultipartParseT) import Multipart2 qualified as Multipart +import MyLabel import MyPrelude import Network.HTTP.Client.Conduit qualified as Http import Network.HTTP.Simple qualified as Http @@ -1559,40 +1556,3 @@ prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrity (toLazyBytes $ bodyStrict) ) | code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp] - --- case-match on an e2 with a t2 that provides the relevant functions -caseE2 :: - forall l1 t1 l2 t2 matcher r. - ( HasField l1 matcher (t1 -> r), - HasField l2 matcher (t2 -> r) - ) => - matcher -> - E2 l1 t1 l2 t2 -> - r -{-# INLINE caseE2 #-} -caseE2 m e2 = do - let f1 = getField @l1 m - let f2 = getField @l2 m - case e2 of - E21 a -> f1 $ getField @l1 a - E22 b -> f2 $ getField @l2 b - -t2 :: forall l1 t1 l2 t2. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> T2 l1 t1 l2 t2 -{-# INLINE t2 #-} -t2 LabelPrx a LabelPrx b = T2 (label @l1 a) (label @l2 b) - -t3 :: forall l1 t1 l2 t2 l3 t3. LabelPrx l1 -> t1 -> LabelPrx l2 -> t2 -> LabelPrx l3 -> t3 -> T3 l1 t1 l2 t2 l3 t3 -{-# INLINE t3 #-} -t3 LabelPrx a LabelPrx b LabelPrx c = T3 (label @l1 a) (label @l2 b) (label @l3 c) - -lbl :: forall l t. LabelPrx l -> t -> Label l t -{-# INLINE lbl #-} -lbl LabelPrx a = label @l a - -data LabelPrx (l :: Symbol) = LabelPrx - -instance (l ~ l') => IsLabel l (LabelPrx l') where - fromLabel = LabelPrx - -instance (t ~ t') => IsLabel l (t -> (Label l t')) where - fromLabel = label @l diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 1df1ac277..0f798a443 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -32,6 +32,9 @@ common common-options -- known as RecordDotSyntax OverloadedRecordDot + -- Make #labels available + OverloadedLabels + -- does not export record fields as functions, use OverloadedRecordDot to access instead NoFieldSelectors @@ -68,6 +71,7 @@ library Bencode JsonLd Optional + MyLabel Http Html Transmission