From 3953fd7030faa34f8484b13aa42009def659285f Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Thu, 16 Jan 2025 20:18:34 +0100 Subject: [PATCH] feat(users/Profpatsch/whatcd-resolver): add simple settings For now just a setting whether we want to use freeleech tokens. Change-Id: I1c0228031df8c79c2ec26ec5bdfef6dde1cb373e Reviewed-on: https://cl.tvl.fyi/c/depot/+/13007 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- .../htmx-experiment/src/HtmxExperiment.hs | 20 +- users/Profpatsch/my-prelude/src/MyPrelude.hs | 11 + .../my-prelude/src/Postgres/MonadPostgres.hs | 26 +++ .../Profpatsch/my-webstuff/src/Multipart2.hs | 43 ++-- .../whatcd-resolver/src/Redacted.hs | 31 +-- .../whatcd-resolver/src/WhatcdResolver.hs | 213 ++++++++++++++++-- 6 files changed, 286 insertions(+), 58 deletions(-) diff --git a/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs index 225206a58..f01572482 100644 --- a/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs +++ b/users/Profpatsch/htmx-experiment/src/HtmxExperiment.hs @@ -18,7 +18,6 @@ import Data.Maybe qualified as Maybe import Data.Monoid qualified as Monoid import Data.Text qualified as Text import FieldParser hiding (nonEmpty) -import GHC.TypeLits (KnownSymbol, symbolVal) import IHP.HSX.QQ (hsx) import Label import Multipart2 (FormValidation (FormValidation), FormValidationResult, MultipartParseT, failFormValidation) @@ -152,12 +151,6 @@ fixed route handler inner = Router $ \from -> \case -- [final] | route == final -> (Just handler, label @route (Handler from)) -- _ -> (Nothing, label @route handler) --- | Get the text of a symbol via TypeApplications -symbolText :: forall sym. KnownSymbol sym => Text -symbolText = do - symbolVal (Proxy :: Proxy sym) - & stringToText - main :: IO () main = runStderrLoggingT @IO $ do withRunInIO @(LoggingT IO) $ \runInIO -> do @@ -208,7 +201,7 @@ main = runStderrLoggingT @IO $ do parsePostBody :: (MonadIO m, MonadThrow m, MonadLogger m) => - MultipartParseT backend m b -> + MultipartParseT m b -> Wai.Request -> m b parsePostBody parser req = @@ -333,18 +326,17 @@ registerForm validationErrors = |] registerFormValidate :: - Applicative m => + (Applicative m) => MultipartParseT - w m (FormValidation (T2 "email" ByteString "password" ByteString)) registerFormValidate = do let emailFP = FieldParser $ \b -> if - | Bytes.elem (charToWordUnsafe '@') b -> Right b - | otherwise -> Left [fmt|This is not an email address: "{b & bytesToTextUtf8Unsafe}"|] + | Bytes.elem (charToWordUnsafe '@') b -> Right b + | otherwise -> Left [fmt|This is not an email address: "{b & bytesToTextUtf8Unsafe}"|] - getCompose @(MultipartParseT _ _) @FormValidation $ do + getCompose @(MultipartParseT _) @FormValidation $ do email <- Compose $ Multipart.fieldLabel' @"email" "email" emailFP password <- aEqB @@ -364,7 +356,7 @@ registerFormValidate = do pure $ if compare == validate then Just validate else Nothing -- | A lifted version of 'Data.Maybe.fromMaybe'. -fromMaybeS :: Selective f => f a -> f (Maybe a) -> f a +fromMaybeS :: (Selective f) => f a -> f (Maybe a) -> f a fromMaybeS ifNothing fma = select ( fma <&> \case diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 8ed475236..d535902f2 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs @@ -80,6 +80,9 @@ module MyPrelude MonadTrans, lift, + -- * Kinds + Type, + -- * Data types Coercible, coerce, @@ -154,6 +157,7 @@ module MyPrelude Category, (>>>), (&>>), + cconst, Any, -- * Enum definition @@ -174,6 +178,7 @@ where import Control.Applicative ((<|>)) import Control.Category (Category, (>>>)) +import Control.Category qualified as Category import Control.Foldl.NonEmpty qualified as Foldl1 import Control.Monad (guard, join, unless, when) import Control.Monad.Catch (MonadThrow (throwM)) @@ -200,6 +205,7 @@ import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) import Data.Functor.Identity (Identity (runIdentity)) +import Data.Kind (Type) import Data.List (zip4) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) @@ -286,6 +292,11 @@ infixl 5 >&< -- like >>> infixr 1 &>> +-- | Categorical constant function, +-- like 'const' but works for anything that’s a category and profunctor. +cconst :: (Category c, Profunctor c) => b -> c a b +cconst b = Category.id & rmap (\_ -> b) + -- | encode a Text to a UTF-8 encoded Bytestring textToBytesUtf8 :: Text -> ByteString textToBytesUtf8 = Data.Text.Encoding.encodeUtf8 diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs index 4fe19b41e..39f087725 100644 --- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs +++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs @@ -250,6 +250,32 @@ ensureNoneOrSingleRow = \case List.length more } +-- | Run a query, passing parameters, and fold over the resulting rows. +-- +-- This doesn’t have to realize the full list of results in memory, +-- rather results are streamed incrementally from the database. +-- +-- When dealing with small results, it may be simpler (and perhaps faster) to use query instead. +-- +-- The results are folded strictly into the Monoid returned by the decoder. +-- +-- If you need more complex folding logic, use 'foldRowsWith' with a 'Fold'. +-- +-- If you can, prefer aggregating in the database itself. +foldRowsWithMonoid :: + forall row params m. + ( MonadPostgres m, + PG.ToRow params, + Typeable row, + Typeable params, + Monoid row + ) => + PG.Query -> + params -> + Decoder row -> + Transaction m row +foldRowsWithMonoid qry params decoder = foldRowsWith qry params decoder Fold.mconcat + -- | Run a query, passing parameters, and fold over the resulting rows. -- -- This doesn’t have to realize the full list of results in memory, diff --git a/users/Profpatsch/my-webstuff/src/Multipart2.hs b/users/Profpatsch/my-webstuff/src/Multipart2.hs index 5c283a3c1..90718bb78 100644 --- a/users/Profpatsch/my-webstuff/src/Multipart2.hs +++ b/users/Profpatsch/my-webstuff/src/Multipart2.hs @@ -23,7 +23,7 @@ data FormFields = FormFields } -- | A parser for a HTTP multipart form (a form sent by the browser) -newtype MultipartParseT backend m a = MultipartParseT +newtype MultipartParseT m a = MultipartParseT { unMultipartParseT :: FormFields -> m (Validation (NonEmpty Error) a) @@ -32,7 +32,9 @@ newtype MultipartParseT backend m a = MultipartParseT (Functor, Applicative, Selective) via (ValidationParseT FormFields m) --- | After parsing a form, either we get the result or a list of form fields that failed +-- | After parsing a form, either we get the result or a list of form fields that failed. +-- +-- Using this via Applicative you get either a valid result (@Just a@), or a list of validation errors. newtype FormValidation a = FormValidation (DList FormValidationResult, Maybe a) @@ -87,7 +89,7 @@ failFormValidation form err = parseMultipartOrThrow :: (MonadLogger m, MonadIO m) => (ErrorTree -> m a) -> - MultipartParseT backend m a -> + MultipartParseT m a -> Wai.Request -> m a parseMultipartOrThrow throwF parser req = do @@ -108,17 +110,32 @@ parseMultipartOrThrow throwF parser req = do Success a -> pure a -- | Parse the field out of the multipart message -field :: (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT backend m a +field :: (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT m a field fieldName fieldParser = MultipartParseT $ \mp -> mp.inputs & findMaybe (\input -> if fst input == fieldName then Just (snd input) else Nothing) & annotate [fmt|Field "{fieldName}" does not exist in the multipart form|] >>= runFieldParser fieldParser - & eitherToListValidation - & pure + & eitherToListValidation + & pure -- | Parse the field out of the multipart message -field' :: (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation a) +fieldMay :: (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT m (Maybe a) +fieldMay fieldName fieldParser = MultipartParseT $ \mp -> + mp.inputs + & findMaybe (\input -> if fst input == fieldName then Just (snd input) else Nothing) + & \case + Nothing -> pure $ Success Nothing + Just b -> + b + & runFieldParser fieldParser + & eitherToListValidation + <&> Just + & pure + +-- | Parse the field out of the multipart message +-- TODO: what is this for?? +field' :: (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT m (FormValidation a) field' fieldName fieldParser = MultipartParseT $ \mp -> mp.inputs & findMaybe (\input -> if fst input == fieldName then Just $ snd input else Nothing) @@ -136,15 +153,15 @@ field' fieldName fieldParser = MultipartParseT $ \mp -> & pure -- | Parse the field out of the multipart message, and into a 'Label' of the given name. -fieldLabel :: forall lbl backend m a. (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (Label lbl a) +fieldLabel :: forall lbl m a. (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT m (Label lbl a) fieldLabel fieldName fieldParser = label @lbl <$> field fieldName fieldParser -- | Parse the field out of the multipart message, and into a 'Label' of the given name. -fieldLabel' :: forall lbl backend m a. (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT backend m (FormValidation (Label lbl a)) +fieldLabel' :: forall lbl m a. (Applicative m) => ByteString -> FieldParser ByteString a -> MultipartParseT m (FormValidation (Label lbl a)) fieldLabel' fieldName fieldParser = fmap (label @lbl) <$> field' fieldName fieldParser -- | parse all fields out of the multipart message, with the same parser -allFields :: (Applicative m) => FieldParser (T2 "key" ByteString "value" ByteString) b -> MultipartParseT backend m [b] +allFields :: (Applicative m) => FieldParser (T2 "key" ByteString "value" ByteString) b -> MultipartParseT m [b] allFields fieldParser = MultipartParseT $ \mp -> mp.inputs <&> tupToT2 @"key" @"value" @@ -159,7 +176,7 @@ tupToT2 (a, b) = T2 (label a) (label b) file :: (Applicative m) => ByteString -> - MultipartParseT backend m (MultipartFile Lazy.ByteString) + MultipartParseT m (MultipartFile Lazy.ByteString) file fieldName = MultipartParseT $ \mp -> mp.files & List.find (\input -> input.multipartNameAttribute == fieldName) @@ -173,14 +190,14 @@ file fieldName = MultipartParseT $ \mp -> -- | Return all files from the multipart message allFiles :: (Applicative m) => - MultipartParseT backend m [MultipartFile Lazy.ByteString] + MultipartParseT m [MultipartFile Lazy.ByteString] allFiles = MultipartParseT $ \mp -> do pure $ Success $ mp.files -- | Ensure there is exactly one file and return it (ignoring the field name) exactlyOneFile :: (Applicative m) => - MultipartParseT backend m (MultipartFile Lazy.ByteString) + MultipartParseT m (MultipartFile Lazy.ByteString) exactlyOneFile = MultipartParseT $ \mp -> mp.files & \case diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 30a75ff73..47538434a 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -112,25 +112,29 @@ redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, HasField "torrentId" dat Int, + HasField "useFreeleechTokens" dat Bool, MonadOtel m, MonadRedacted m ) => dat -> m ByteString redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do - req <- - mkRedactedApiRequest - ( T2 - (label @"action" "download") - ( label @"actionArgs" - [ ("id", Just (buildBytes intDecimalB dat.torrentId)) - -- try using tokens as long as we have them (TODO: what if there’s no tokens left? - -- ANSWER: it breaks: - -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", - -- ("usetoken", Just "1") - ] - ) - ) + let actionArgs = + [ ("id", Just (buildBytes intDecimalB dat.torrentId)) + ] + -- try using tokens as long as we have them (TODO: what if there’s no tokens left? + -- ANSWER: it breaks: + -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", + <> (if dat.useFreeleechTokens then [("usetoken", Just "1")] else []) + let reqDat = + ( T2 + (label @"action" "download") + ( label @"actionArgs" $ actionArgs + ) + ) + addAttribute span "redacted.request" (toOtelJsonAttr reqDat) + req <- mkRedactedApiRequest reqDat + httpTorrent span req mkRedactedTorrentLink :: Arg "torrentGroupId" Int -> Text @@ -447,6 +451,7 @@ redactedPagedSearchAndInsert innerParser pagedRequest = do redactedGetTorrentFileAndInsert :: ( HasField "torrentId" r Int, + HasField "useFreeleechTokens" r Bool, MonadPostgres m, MonadThrow m, MonadLogger m, diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index acce73171..040aa5340 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -35,6 +35,7 @@ import Json.Enc (Enc) import Json.Enc qualified as Enc import JsonLd import Label +import Multipart2 (MultipartParseT) import Multipart2 qualified as Multipart import MyPrelude import Network.HTTP.Client.Conduit qualified as Http @@ -47,6 +48,7 @@ import Network.Wai (ResponseReceived) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import OpenTelemetry.Attributes qualified as Otel +import OpenTelemetry.Context.ThreadLocal qualified as Otel import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import Parse (Parse) @@ -106,15 +108,10 @@ htmlUi = do respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do - let mp span parser = - Multipart.parseMultipartOrThrow - (appThrow span . AppExceptionTree) - parser - req - let torrentIdMp span = - mp + parseMultipartOrThrow span + req ( do label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) ) @@ -131,8 +128,9 @@ htmlUi = do Html $ \span -> do dat <- - mp + parseMultipartOrThrow span + req ( do label @"searchstr" <$> Multipart.field "redacted-search" Cat.id ) @@ -167,7 +165,8 @@ htmlUi = do HtmlOrReferer $ \span -> do dat <- torrentIdMp span runTransaction $ do - inserted <- redactedGetTorrentFileAndInsert dat + settings <- getSettings + inserted <- redactedGetTorrentFileAndInsert (T2 dat (getLabel @"useFreeleechTokens" settings)) running <- lift @Transaction $ doTransmissionRequest' (transmissionRequestAddTorrent inserted) @@ -208,7 +207,7 @@ htmlUi = do ), ( "snips/transmission/getTorrentState", Html $ \span -> do - dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 + dat <- parseMultipartOrThrow span req $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 status <- doTransmissionRequest' ( transmissionRequestListOnlyTorrents @@ -238,6 +237,26 @@ htmlUi = do pure $ renderJsonld jsonld ) ), + ( "settings", + PostAndRedirect + ( do + settings <- runTransaction getSettings + pure $ do + returnTo <- Multipart.fieldLabel @"returnTo" "returnTo" Field.utf8 + parsed <- label @"settings" <$> settingsMultipartParser settings + pure $ T2 returnTo parsed + ) + $ \_span (s :: T2 "returnTo" Text "settings" Settings) -> do + let Settings {useFreeleechTokens} = s.settings + runTransaction $ do + _ <- + writeSettings + [ T2 + (label @"key" "useFreeleechTokens") + (label @"val" $ Json.Bool useFreeleechTokens) + ] + pure $ label @"redirectTo" (s.returnTo & textToBytesUtf8) + ), ( "artist", do HtmlWithQueryArgs @@ -251,8 +270,9 @@ htmlUi = do HtmlOrRedirect $ \span -> do dat <- - mp + parseMultipartOrThrow span + req (label @"artistId" <$> Multipart.field "artist-id" Field.utf8) t <- redactedRefreshArtist dat runTransaction $ do @@ -297,12 +317,17 @@ htmlUi = do -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" -- ) -- <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable (label @"groupByReleaseType" False) Nothing + (bestTorrentsTable, settings) <- + concurrentlyTraced + (getBestTorrentsTable (label @"groupByReleaseType" False) Nothing) + (getSettings) -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable + let returnUrl = (label @"returnUrl" "/") pure $ htmlPageChrome "whatcd-resolver" [hsx| + {settingButtons returnUrl settings}
@@ -330,6 +355,27 @@ htmlUi = do /> |] +-- | Run two actions concurrently, and add them to the current Otel trace +concurrentlyTraced :: (MonadUnliftIO m) => m a -> m b -> m (a, b) +concurrentlyTraced act1 act2 = do + ctx <- Otel.getContext + concurrently + ( do + _old <- Otel.attachContext ctx + act1 + ) + ( do + _old <- Otel.attachContext ctx + act2 + ) + +parseMultipartOrThrow :: (MonadLogger m, MonadIO m, MonadThrow m) => Otel.Span -> Wai.Request -> Multipart.MultipartParseT m a -> m a +parseMultipartOrThrow span req parser = + Multipart.parseMultipartOrThrow + (appThrow span . AppExceptionTree) + parser + req + -- | Reload the current page (via the Referer header) if the browser has Javascript disabled (and thus htmx does not work). This should make post requests work out of the box. htmxOrReferer :: Wai.Request -> Wai.Response -> Wai.Response htmxOrReferer req resp = do @@ -391,12 +437,18 @@ artistPage :: dat -> m Html artistPage dat = runTransaction $ do - fresh <- - getBestTorrentsData - (Just $ E22 (getLabel @"artistRedactedId" dat)) + (fresh, settings) <- + concurrentlyTraced + ( getBestTorrentsData + (Just $ E22 (getLabel @"artistRedactedId" dat)) + ) + (getSettings) 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 (label @"groupByReleaseType" True) fresh + let returnUrl = + label @"returnUrl" $ + mkArtistLink (label @"artistId" (dat.artistRedactedId & fromIntegral @Natural @Int)) pure $ htmlPageChrome ( case artistName of @@ -404,6 +456,7 @@ artistPage dat = runTransaction $ do Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] ) [hsx| + {settingButtons returnUrl settings}

Artist ID: {dat.artistRedactedId}

@@ -433,12 +486,17 @@ data HandlerResponse m where HtmlWithQueryArgs :: Parse Query a -> (a -> Otel.Span -> m Html) -> HandlerResponse m -- | render html or reload the page via the Referer header if no htmx HtmlOrReferer :: (Otel.Span -> m Html) -> HandlerResponse m + -- | parse the request as POST submission, then redirect to the given endpoint + PostAndRedirect :: + m (MultipartParseT m dat) -> + (Otel.Span -> dat -> m (Label "redirectTo" ByteString)) -> + HandlerResponse m -- | render a plain wai response Plain :: m Wai.Response -> HandlerResponse m runHandlers :: forall m. - (MonadOtel m) => + (MonadOtel m, MonadLogger m, MonadThrow m) => (HandlerResponse m) -> (Map Text (HandlerResponse m)) -> Wai.Request -> @@ -446,7 +504,7 @@ runHandlers :: m ResponseReceived runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do let path = req & Wai.pathInfo & Text.intercalate "/" - let html' resp act = + let inRouteSpan = Otel.inSpan' [fmt|Route /{path}|] ( Otel.defaultSpanArguments @@ -457,6 +515,8 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do ] } ) + let html' resp act = + inRouteSpan ( \span -> do res <- act span <&> (\h -> label @"html" h) addEventSimple span "Got Html result, rendering…" @@ -473,6 +533,18 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do r.redirectTo (\status header -> Wai.responseLBS status [header] "") req + let postAndRedirect :: + MultipartParseT m dat -> + (Otel.Span -> dat -> m (Label "redirectTo" ByteString)) -> + m ResponseReceived + postAndRedirect parser act = inRouteSpan $ \span -> do + if (req & Wai.requestMethod) == "POST" + then do + dat <- parseMultipartOrThrow span req parser + res <- act span dat + liftIO $ respond (Wai.responseLBS Http.seeOther303 [("Location", res.redirectTo)] "") + else do + liftIO $ respond (Wai.responseLBS Http.methodNotAllowed405 [] "") let 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) @@ -492,6 +564,7 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do 
{err & prettyErrorTree}
|] ) + let handler = handlers & Map.lookup path @@ -501,6 +574,7 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do HtmlOrRedirect act -> htmlOrRedirect act HtmlWithQueryArgs parser act -> htmlWithQueryArgs parser act HtmlOrReferer act -> htmlOrReferer act + PostAndRedirect mParser act -> mParser >>= \parser -> postAndRedirect parser act Plain act -> liftIO $ runInIO act >>= respond runInIO handler @@ -689,7 +763,7 @@ mkBestTorrentsTable opts fresh = do b.artists <&> ( \a -> T2 - (label @"url" [fmt|/artist?redacted_id={a.artistId}|]) + (label @"url" $ mkArtistLink a) (label @"content" $ Html.toHtml @Text a.artistName) ) & mkLinkList @@ -759,6 +833,9 @@ mkLinkList xs = & List.intersperse ", " & mconcat +mkArtistLink :: (HasField "artistId" r Int) => r -> Text +mkArtistLink a = [fmt|/artist?redacted_id={a.artistId}|] + getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html getTransmissionTorrentsTable = do @@ -806,6 +883,12 @@ migrate = inSpan "Database Migration" $ do [sql| CREATE SCHEMA IF NOT EXISTS redacted; + CREATE TABLE IF NOT EXISTS redacted.settings ( + id SERIAL PRIMARY KEY, + key TEXT NOT NULL UNIQUE, + value JSONB + ); + CREATE TABLE IF NOT EXISTS redacted.torrent_groups ( id SERIAL PRIMARY KEY, group_id INTEGER, @@ -990,3 +1073,97 @@ withDb act = do -- print [fmt|data dir: {db & TmpPg.toDataDirectory}|] -- print [fmt|conn string: {db & TmpPg.toConnectionString}|] act db + +data Settings = Settings + { useFreeleechTokens :: Bool + } + deriving stock (Generic) + +settingFreeleechToken :: Bool -> Settings +settingFreeleechToken b = Settings {useFreeleechTokens = b} + +instance Semigroup Settings where + a <> b = Settings {useFreeleechTokens = a.useFreeleechTokens || b.useFreeleechTokens} + +instance Monoid Settings where + mempty = Settings {useFreeleechTokens = False} + +submitSettingForm :: (HasField "returnUrl" r Text, ToHtml a) => r -> a -> Html +submitSettingForm opts inputs = + [hsx| + + + {inputs} + + |] + +settingButtons :: (HasField "returnUrl" opts Text) => opts -> Settings -> Html +settingButtons opts s = + if s.useFreeleechTokens + then + submitSettingForm + opts + [hsx|

Using freeleech tokens!

|] + else + submitSettingForm + opts + [hsx|

Not using freeleech tokens

|] + +settingsMultipartParser :: (Applicative m) => Settings -> MultipartParseT m Settings +settingsMultipartParser old = do + useFreeleechTokens <- do + on <- + Multipart.fieldMay + "useFreeleechTokensON" + (cconst $ True) + off <- + Multipart.fieldMay + "useFreeleechTokensOFF" + (cconst $ False) + pure $ (on <|> off) & fromMaybe old.useFreeleechTokens + pure $ Settings {..} + +getSettings :: (MonadPostgres m, MonadOtel m) => Transaction m Settings +getSettings = inSpan' "Get Settings" $ \span -> do + res <- + foldRowsWithMonoid + [sql| + SELECT key, value + FROM redacted.settings + |] + () + ( do + key <- Dec.text + Dec.jsonMay + ( case key of + "useFreeleechTokens" -> settingFreeleechToken <$> Json.asBool + _ -> pure mempty + ) + <&> fromMaybe mempty + ) + lift $ addAttribute span "settings" (toOtelAttrGenericStruct res) + pure res + +writeSettings :: + (MonadPostgres m, MonadOtel m) => + [T2 "key" Text "val" Json.Value] -> + Transaction m (Label "numberOfRowsAffected" Natural) +writeSettings settings = inSpan' "Write Settings" $ \span -> do + addAttribute + span + "settings" + ( toOtelJsonAttr $ + Enc.list + (\s -> Enc.tuple2 Enc.text Enc.value (s.key, s.val)) + settings + ) + execute + [sql| + INSERT INTO redacted.settings (key, value) + SELECT * FROM UNNEST(?::text[], ?::jsonb[]) + ON CONFLICT (key) DO UPDATE SET value = EXCLUDED.value + |] + (settings & unzipPGArray @"key" @Text @"val" @Json.Value)