mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

chore(users/Profpatsch/whatcd-resolver): slight changes

Browse source 
Change-Id: I57b0fcf9bd3953951dd0cffbee1fbfab5abbeb47
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11089
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2024-03-03 14:19:52 +01:00
parent de5790aba8
commit 9a7246ea1d
1 changed files with 51 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

112
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -7,8 +7,6 @@ module WhatcdResolver where
import Control.Category qualified as Cat import Control.Category qualified as Cat
import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Catch.Pure (runCatch)
import Control.Monad.Error (catchError)
import Control.Monad.Except (runExcept)
import Control.Monad.Logger qualified as Logger import Control.Monad.Logger qualified as Logger
import Control.Monad.Logger.CallStack import Control.Monad.Logger.CallStack
import Control.Monad.Reader import Control.Monad.Reader
@ -42,7 +40,6 @@ import Json.Enc qualified as Enc
import Label import Label
import Multipart2 qualified as Multipart import Multipart2 qualified as Multipart
import Network.HTTP.Client.Conduit qualified as Http import Network.HTTP.Client.Conduit qualified as Http
import Network.HTTP.Conduit qualified as Http
import Network.HTTP.Simple qualified as Http import Network.HTTP.Simple qualified as Http
import Network.HTTP.Types import Network.HTTP.Types
import Network.HTTP.Types qualified as Http import Network.HTTP.Types qualified as Http
@ -86,7 +83,7 @@ main =
<&> first showToError <&> first showToError
>>= expectIOError "could not start whatcd-resolver" >>= expectIOError "could not start whatcd-resolver"
htmlUi :: App () htmlUi :: AppT IO ()
htmlUi = do htmlUi = do
let debug = True let debug = True
withRunInIO $ \runInIO -> Warp.run 9092 $ \req respond -> do withRunInIO $ \runInIO -> Warp.run 9092 $ \req respond -> do
@ -222,7 +219,7 @@ htmlUi = do
everySecond call extraData innerHtml = [hsx|<div hx-trigger="every 1s" hx-swap="outerHTML" hx-post={call} hx-vals={Enc.encToBytesUtf8 extraData}>{innerHtml}</div>|] everySecond call extraData innerHtml = [hsx|<div hx-trigger="every 1s" hx-swap="outerHTML" hx-post={call} hx-vals={Enc.encToBytesUtf8 extraData}>{innerHtml}</div>|]
mainHtml span = runTransaction $ do mainHtml span = runTransaction $ do
jsonld <- httpGetJsonLd span "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" <&> renderJsonld -- jsonld <- httpGetJsonLd span "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" <&> renderJsonld
bestTorrentsTable <- getBestTorrentsTable bestTorrentsTable <- getBestTorrentsTable
-- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
pure $ pure $
@ -243,7 +240,7 @@ htmlUi = do
</style> </style>
</head> </head>
<body> <body>
{jsonld} {""::Text {-jsonld-}}
<form <form
hx-post="/snips/redacted/search" hx-post="/snips/redacted/search"
hx-target="#redacted-search-results"> hx-target="#redacted-search-results">
@ -425,21 +422,21 @@ jsonldParser :: (Monad m) => Json.ParseT err m Jsonld
jsonldParser = jsonldParser =
Json.asValue >>= \cur -> do Json.asValue >>= \cur -> do
if if
| Json.Object _ <- cur -> do | Json.Object _ <- cur -> do
typeMay <- Json.keyMay "@type" $ (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText)) typeMay <- Json.keyMay "@type" $ (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText))
idMay <- Json.keyMay "@id" $ Json.asText idMay <- Json.keyMay "@id" $ Json.asText
if if
| Just type_ <- typeMay, | Just type_ <- typeMay,
Just id_ <- idMay -> do Just id_ <- idMay -> do
previewFields <- previewFields <-
Json.asObjectMap jsonldParser Json.asObjectMap jsonldParser
<&> Map.delete "@type" <&> Map.delete "@type"
<&> Map.delete "@id" <&> Map.delete "@id"
pure $ JsonldObject $ JsonldObject' {..} pure $ JsonldObject $ JsonldObject' {..}
| otherwise -> pure $ JsonldField cur | otherwise -> pure $ JsonldField cur
| Json.Array _ <- cur -> do | Json.Array _ <- cur -> do
JsonldArray <$> Json.eachInArray jsonldParser JsonldArray <$> Json.eachInArray jsonldParser
| otherwise -> pure $ JsonldField cur | otherwise -> pure $ JsonldField cur
renderJsonld :: Jsonld -> Html renderJsonld :: Jsonld -> Html
renderJsonld = \case renderJsonld = \case
@ -490,9 +487,9 @@ scientificPercentage =
Field.boundedScientificRealFloat @Float Field.boundedScientificRealFloat @Float
>>> ( FieldParser $ \f -> >>> ( FieldParser $ \f ->
if if
| f < 0 -> Left "percentage cannot be negative" | f < 0 -> Left "percentage cannot be negative"
| f > 1 -> Left "percentage cannot be over 100%" | f > 1 -> Left "percentage cannot be over 100%"
| otherwise -> Right $ Percentage $ ceiling (f * 100) | otherwise -> Right $ Percentage $ ceiling (f * 100)
) )
-- | Fetch the current status from transmission, and remove the tranmission hash from our database -- | Fetch the current status from transmission, and remove the tranmission hash from our database
@ -834,10 +831,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
(label @"action" "download") (label @"action" "download")
( label @"actionArgs" ( label @"actionArgs"
[ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8)) [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
-- try using tokens as long as we have them (TODO: what if there’s no tokens left? -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
-- ANSWER: it breaks: -- ANSWER: it breaks:
-- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
-- ("usetoken", Just "1") -- ("usetoken", Just "1")
] ]
) )
) )
@ -1256,11 +1253,11 @@ getBestTorrents = do
TorrentData TorrentData
{ torrentStatus = { torrentStatus =
if if
| not hasTorrentFile -> NoTorrentFileYet | not hasTorrentFile -> NoTorrentFileYet
| Nothing <- transmissionTorrentHash -> NotInTransmissionYet | Nothing <- transmissionTorrentHash -> NotInTransmissionYet
| Just hash <- transmissionTorrentHash -> | Just hash <- transmissionTorrentHash ->
InTransmission $ InTransmission $
T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()), T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()),
.. ..
} }
) )
@ -1353,16 +1350,16 @@ httpTorrent span req =
<&> Wai.parseContentType <&> Wai.parseContentType
<&> (\(ct, _mimeAttributes) -> ct) <&> (\(ct, _mimeAttributes) -> ct)
if if
| statusCode == 200, | statusCode == 200,
Just "application/x-bittorrent" <- contentType -> Just "application/x-bittorrent" <- contentType ->
Right $ (resp & Http.responseBody) Right $ (resp & Http.responseBody)
| statusCode == 200, | statusCode == 200,
Just otherType <- contentType -> Just otherType <- contentType ->
Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|] Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|]
| statusCode == 200, | statusCode == 200,
Nothing <- contentType -> Nothing <- contentType ->
Left [fmt|Redacted returned a body with unspecified content type|] Left [fmt|Redacted returned a body with unspecified content type|]
| code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|]
) )
newtype Optional a = OptionalInternal (Maybe a) newtype Optional a = OptionalInternal (Maybe a)
@ -1401,17 +1398,17 @@ httpJson opts span parser req = do
<&> Wai.parseContentType <&> Wai.parseContentType
<&> (\(ct, _mimeAttributes) -> ct) <&> (\(ct, _mimeAttributes) -> ct)
if if
| statusCode == 200, | statusCode == 200,
Just ct <- contentType, Just ct <- contentType,
ct == opts'.contentType -> ct == opts'.contentType ->
Right $ (resp & Http.responseBody) Right $ (resp & Http.responseBody)
| statusCode == 200, | statusCode == 200,
Just otherType <- contentType -> Just otherType <- contentType ->
Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
| statusCode == 200, | statusCode == 200,
Nothing <- contentType -> Nothing <- contentType ->
Left [fmt|Server returned a body with unspecified content type|] 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}|] | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|]
) )
>>= assertM >>= assertM
span span
@ -1512,8 +1509,6 @@ data Context = Context
newtype AppT m a = AppT {unAppT :: ReaderT Context m a} newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow) deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
type App a = AppT IO a
data AppException = AppException Text data AppException = AppException Text
deriving stock (Show) deriving stock (Show)
deriving anyclass (Exception) deriving anyclass (Exception)
@ -1594,8 +1589,3 @@ runPGTransaction (Transaction transaction) = do
withRunInIO $ \unliftIO -> withRunInIO $ \unliftIO ->
withPGTransaction pool $ \conn -> do withPGTransaction pool $ \conn -> do
unliftIO $ runReaderT transaction conn unliftIO $ runReaderT transaction conn
data HasQueryParams param
= HasNoParams
| HasSingleParam param
| HasMultiParams [param]