|]
singleQueryArgument :: Text -> FieldParser ByteString to -> Parse Http.Query to
singleQueryArgument field inner =
Parse.mkParsePushContext
field
( \(ctx, qry) -> case qry
& mapMaybe
( \(k, v) ->
if k == (field & textToBytesUtf8)
then Just v
else Nothing
) of
[] -> Left [fmt|No such query argument "{field}", at {ctx & Parse.showContext}|]
[Nothing] -> Left [fmt|Expected one query argument with a value, but "{field}" was a query flag|]
[Just one] -> Right one
more -> Left [fmt|More than one value for query argument "{field}": {show more}, at {ctx & Parse.showContext}|]
)
>>> Parse.fieldParser inner
-- | Make sure we can parse the given Text into a Request via a URI.
--
-- This tries to work around the horrible, horrible interface in Http.Client.
textToHttpClientRequest :: Parse Text Http.Request
textToHttpClientRequest =
Parse.fieldParser
( FieldParser $ \text ->
text
& textToString
& Network.URI.parseURI
& annotate [fmt|Cannot parse this as a URL: "{text}"|]
)
>>> ( Parse.mkParseNoContext
( \url ->
(url & Http.requestFromURI)
& runCatch
& first (checkException @Http.HttpException)
& \case
Left (Right (Http.InvalidUrlException urlText reason)) ->
Left [fmt|Unable to set the url "{urlText}" as request URL, reason: {reason}|]
Left (Right exc@(Http.HttpExceptionRequest _ _)) ->
Left [fmt|Weird! Should not get a HttpExceptionRequest when parsing an URL (bad library design), was {exc & displayException}|]
Left (Left someExc) ->
Left [fmt|Weird! Should not get anyhting but a HttpException when parsing an URL (bad library design), was {someExc & displayException}|]
Right req -> pure req
)
)
checkException :: (Exception b) => SomeException -> Either SomeException b
checkException some = case fromException some of
Nothing -> Left some
Just e -> Right e
snipsRedactedSearch ::
( MonadLogger m,
MonadPostgres m,
HasField "searchstr" r ByteString,
MonadThrow m,
MonadTransmission m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
r ->
m Html
snipsRedactedSearch dat = do
t <-
redactedSearchAndInsert
[ ("searchstr", dat.searchstr),
("releasetype", "album")
]
runTransaction $ do
t
getBestTorrentsTable
getBestTorrentsTable ::
( MonadTransmission m,
MonadThrow m,
MonadLogger m,
MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
Transaction m Html
getBestTorrentsTable = do
bestStale :: [TorrentData ()] <- getBestTorrents
actual <-
getAndUpdateTransmissionTorrentsStatus
( bestStale
& mapMaybe
( \td -> case td.torrentStatus of
InTransmission h -> Just h
_ -> Nothing
)
<&> (\t -> (getLabel @"torrentHash" t, t.transmissionInfo))
& Map.fromList
)
let fresh =
bestStale
-- we have to update the status of every torrent that’s not in tranmission anymore
-- TODO I feel like it’s easier (& more correct?) to just do the database request again …
<&> ( \td -> case td.torrentStatus of
InTransmission info ->
case actual & Map.lookup (getLabel @"torrentHash" info) of
-- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before,
-- which is an internal factum that is established in getBestTorrents (and might change later)
Nothing -> td {torrentStatus = NotInTransmissionYet}
Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))}
NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet}
NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet}
)
let localTorrent b = case b.torrentStatus of
NoTorrentFileYet -> [hsx||]
InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|]
NotInTransmissionYet -> [hsx||]
let bestRows =
fresh
& foldMap
( \b -> do
[hsx|
{localTorrent b}
{Html.toHtml @Int b.groupId}
{Html.toHtml @Text b.torrentGroupJson.artist}
{Html.toHtml @Text b.torrentGroupJson.groupName}
{Html.toHtml @Int b.seedingWeight}
|]
)
pure $
[hsx|
Local
Group ID
Artist
Name
Weight
Torrent
Torrent Group
{bestRows}
|]
data Jsonld
= JsonldObject JsonldObject
| JsonldArray [Jsonld]
| JsonldField Json.Value
deriving stock (Show, Eq)
data JsonldObject = JsonldObject'
{ type_ :: Set Text,
id_ :: Text,
previewFields :: Map Text Jsonld
}
deriving stock (Show, Eq)
jsonldParser :: (Monad m) => Json.ParseT err m Jsonld
jsonldParser =
Json.asValue >>= \cur -> do
if
| Json.Object _ <- cur -> do
typeMay <- Json.keyMay "@type" $ (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText))
idMay <- Json.keyMay "@id" $ Json.asText
if
| Just type_ <- typeMay,
Just id_ <- idMay -> do
previewFields <-
Json.asObjectMap jsonldParser
<&> Map.delete "@type"
<&> Map.delete "@id"
pure $ JsonldObject $ JsonldObject' {..}
| otherwise -> pure $ JsonldField cur
| Json.Array _ <- cur -> do
JsonldArray <$> Json.eachInArray jsonldParser
| otherwise -> pure $ JsonldField cur
renderJsonld :: Jsonld -> Html
renderJsonld = \case
JsonldObject obj ->
[hsx|