|]
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 an URI.
textToURI :: Parse Text URI
textToURI =
Parse.fieldParser
( FieldParser $ \text ->
text
& textToString
& Network.URI.parseURI
& annotate [fmt|Cannot parse this as a URL: "{text}"|]
)
-- | Make sure we can parse the given URI into a Request.
--
-- This tries to work around the horrible, horrible interface in Http.Client.
uriToHttpClientRequest :: Parse URI Http.Request
uriToHttpClientRequest =
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,
MonadOtel 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,
MonadOtel 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}
|]
-- | A recursive `json+ld` structure.
data Jsonld
= JsonldObject JsonldObject
| JsonldAnonymousObject JsonldAnonymousObject
| JsonldArray [Jsonld]
| JsonldField Json.Value
deriving stock (Show, Eq)
-- | A json+ld object, that is something which can be further expanded by following the URL in its `id_` field.
data JsonldObject = JsonldObject'
{ -- | `@type` field; currently just the plain value without taking into account the json+ld context
type_ :: Set Text,
-- | `@id` field, usually a link to follow for expanding the object to its full glory
id_ :: Text,
-- | any fields of this object that remote deemed important enough to already pre-emptively include in the object; to get all fields resolve the URL in `id_`.
previewFields :: Map Text Jsonld
}
deriving stock (Show, Eq)
-- | A json+ld object that cannot be inspected further by resolving its ID
data JsonldAnonymousObject = JsonldAnonymousObject'
{ -- | `@type` field; currently just the plain value without taking into account the json+ld context
type_ :: Set Text,
-- | fields of this anonymous object
fields :: 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
type_ <-
Json.keyMay "@type" (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText))
<&> fromMaybe Set.empty
idMay <- Json.keyMay "@id" $ Json.asText
fields <-
Json.asObjectMap jsonldParser
<&> Map.delete "@type"
<&> Map.delete "@id"
if
| Just id_ <- idMay -> do
pure $ JsonldObject $ JsonldObject' {previewFields = fields, ..}
| otherwise -> pure $ JsonldAnonymousObject $ JsonldAnonymousObject' {..}
| Json.Array _ <- cur -> do
JsonldArray <$> Json.eachInArray jsonldParser
| otherwise -> pure $ JsonldField cur
renderJsonld :: Jsonld -> Html
renderJsonld = \case
JsonldObject obj -> renderObject obj (Just obj.id_) obj.previewFields
JsonldAnonymousObject obj -> renderObject obj Nothing obj.fields
JsonldArray arr ->
Html.toOrderedList renderJsonld arr
JsonldField f -> Html.mkVal f
where
renderObject obj mId_ fields = do
let id_ =
mId_ <&> \i ->
[hsx|
|]
snippetHref target =
Builder.toLazyByteString $
"/snips/jsonld/render"
<> Url.renderQueryBuilder True [("target", Just (textToBytesUtf8 target))]
schemaTypes xs =
xs
<&> schemaType
& List.intersperse ", "
& mconcat
schemaType t =
let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|{t}|]
getTransmissionTorrentsTable ::
(MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html
getTransmissionTorrentsTable = do
let fields =
[ "hashString",
"name",
"percentDone",
"percentComplete",
"downloadDir",
"files"
]
doTransmissionRequest'
( transmissionRequestListAllTorrents fields $ do
Json.asObject <&> KeyMap.toMapText
)
<&> \resp ->
Html.toTable
( resp
& List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
<&> Map.toList
-- TODO
& List.take 100
)
unzip3PGArray :: [(a1, a2, a3)] -> (PGArray a1, PGArray a2, PGArray a3)
unzip3PGArray xs = xs & unzip3 & \(a, b, c) -> (PGArray a, PGArray b, PGArray c)
assertOneUpdated ::
(HasField "numberOfRowsAffected" r Natural, MonadThrow m, MonadIO m) =>
Otel.Span ->
Text ->
r ->
m ()
assertOneUpdated span name x = case x.numberOfRowsAffected of
1 -> pure ()
n -> appThrowTree span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|])
migrate ::
( MonadPostgres m,
MonadOtel m
) =>
Transaction m (Label "numberOfRowsAffected" Natural)
migrate = inSpan "Database Migration" $ do
execute
[sql|
CREATE SCHEMA IF NOT EXISTS redacted;
CREATE TABLE IF NOT EXISTS redacted.torrent_groups (
id SERIAL PRIMARY KEY,
group_id INTEGER,
group_name TEXT,
full_json_result JSONB,
UNIQUE(group_id)
);
CREATE TABLE IF NOT EXISTS redacted.torrents_json (
id SERIAL PRIMARY KEY,
torrent_id INTEGER,
torrent_group SERIAL NOT NULL REFERENCES redacted.torrent_groups(id) ON DELETE CASCADE,
full_json_result JSONB,
UNIQUE(torrent_id)
);
ALTER TABLE redacted.torrents_json
ADD COLUMN IF NOT EXISTS torrent_file bytea NULL;
ALTER TABLE redacted.torrents_json
ADD COLUMN IF NOT EXISTS transmission_torrent_hash text NULL;
-- inflect out values of the full json
CREATE OR REPLACE VIEW redacted.torrents AS
SELECT
t.id,
t.torrent_id,
t.torrent_group,
-- the seeding weight is used to find the best torrent in a group.
( ((full_json_result->'seeders')::integer*3
+ (full_json_result->'snatches')::integer
)
-- prefer remasters by multiplying them with 3
* (CASE
WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%'
THEN 3
ELSE 1
END)
)
AS seeding_weight,
t.full_json_result,
t.torrent_file,
t.transmission_torrent_hash
FROM redacted.torrents_json t;
CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer));
CREATE INDEX IF NOT EXISTS torrents_json_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer));
|]
()
httpGetJsonLd :: (MonadThrow m, MonadOtel m) => (URI, Http.Request) -> m Jsonld
httpGetJsonLd (uri, req) = inSpan' "Fetch json+ld" $ \span -> do
addAttribute span "json+ld.targetUrl" (uri & showToText)
httpJson
(mkOptional (label @"contentType" "application/ld+json"))
jsonldParser
( req
& Http.setRequestMethod "GET"
& Http.setRequestHeader "Accept" ["application/ld+json"]
)
httpTorrent ::
( MonadIO m,
MonadThrow m
) =>
Otel.Span ->
Http.Request ->
m ByteString
httpTorrent span req =
Http.httpBS req
>>= assertM
span
( \resp -> do
let statusCode = resp & Http.responseStatus & (.statusCode)
contentType =
resp
& Http.responseHeaders
& List.lookup "content-type"
<&> Wai.parseContentType
<&> (\(ct, _mimeAttributes) -> ct)
if
| statusCode == 200,
Just "application/x-bittorrent" <- contentType ->
Right $ (resp & Http.responseBody)
| statusCode == 200,
Just otherType <- contentType ->
Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|]
| statusCode == 200,
Nothing <- contentType ->
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}|]
)
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format")
let config = label @"logDatabaseQueries" LogDatabaseQueries
pgConnPool <-
Pool.newPool $
Pool.defaultPoolConfig
{- resource init action -} (Postgres.connectPostgreSQL (db & TmpPg.toConnectionString))
{- resource destruction -} Postgres.close
{- unusedResourceOpenTime -} 10
{- max resources across all stripes -} 20
transmissionSessionId <- newEmptyMVar
let newAppT = do
logInfo [fmt|Running with config: {showPretty config}|]
logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|]
appT
runReaderT newAppT.unAppT Context {..}
withTracer :: (Otel.Tracer -> IO c) -> IO c
withTracer f = do
setDefaultEnv "OTEL_SERVICE_NAME" "whatcd-resolver"
bracket
-- Install the SDK, pulling configuration from the environment
Otel.initializeGlobalTracerProvider
-- Ensure that any spans that haven't been exported yet are flushed
Otel.shutdownTracerProvider
-- Get a tracer so you can create spans
(\tracerProvider -> f $ Otel.makeTracer tracerProvider "whatcd-resolver" Otel.tracerOptions)
setDefaultEnv :: String -> String -> IO ()
setDefaultEnv envName defaultValue = do
Env.lookupEnv envName >>= \case
Just _env -> pure ()
Nothing -> Env.setEnv envName defaultValue
withDb :: (TmpPg.DB -> IO a) -> IO (Either TmpPg.StartError a)
withDb act = do
dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver"
let databaseDir = dataDir "database"
let socketDir = dataDir "database-socket"
Dir.createDirectoryIfMissing True socketDir
initDbConfig <-
Dir.doesDirectoryExist databaseDir >>= \case
True -> pure TmpPg.Zlich
False -> do
putStderrLn [fmt|Database does not exist yet, creating in "{databaseDir}"|]
Dir.createDirectoryIfMissing True databaseDir
pure TmpPg.DontCare
let cfg =
mempty
{ TmpPg.dataDirectory = TmpPg.Permanent (databaseDir),
TmpPg.socketDirectory = TmpPg.Permanent socketDir,
TmpPg.port = pure $ Just 5431,
TmpPg.initDbConfig
}
TmpPg.withConfig cfg $ \db -> do
-- print [fmt|data dir: {db & TmpPg.toDataDirectory}|]
-- print [fmt|conn string: {db & TmpPg.toConnectionString}|]
act db