{-# LANGUAGE QuasiQuotes #-} module WhatcdResolver where import AppT import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap import Data.Error.Tree (prettyErrorTree) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Pool qualified as Pool import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.Postgres.Temp qualified as TmpPg import FieldParser (FieldParser, FieldParser' (..)) import FieldParser qualified as Field import Html qualified import IHP.HSX.QQ (hsx) import IHP.HSX.ToHtml (ToHtml) import Json qualified import Json.Enc (Enc) import Json.Enc qualified as Enc import JsonLd import Label import Multipart2 qualified as Multipart import MyPrelude import Network.HTTP.Client.Conduit qualified as Http import Network.HTTP.Simple qualified as Http import Network.HTTP.Types import Network.HTTP.Types qualified as Http import Network.URI (URI) import Network.URI qualified import Network.Wai (ResponseReceived) import Network.Wai qualified as Wai import Network.Wai.Handler.Warp qualified as Warp import Network.Wai.Parse qualified as Wai import OpenTelemetry.Attributes qualified as Otel import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import Parse (Parse) import Parse qualified import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty import Redacted import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.Environment qualified as Env import System.FilePath ((>)) import Text.Blaze.Html (Html) import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 qualified as Html import Tool (readTool, readTools) import Transmission import UnliftIO hiding (Handler) import Prelude hiding (span) main :: IO () main = runAppWith ( do -- todo: trace that to the init functions as well Otel.inSpan "whatcd-resolver main function" Otel.defaultSpanArguments $ do _ <- runTransaction migrate htmlUi ) <&> first showToError >>= expectIOError "could not start whatcd-resolver" htmlUi :: AppT IO () htmlUi = do uniqueRunId <- runTransaction $ querySingleRowWith [sql| SELECT gen_random_uuid()::text |] () (Dec.fromField @Text) withRunInIO $ \runInIO -> Warp.run 9093 $ \req respondOrig -> do let catchAppException act = try act >>= \case Right a -> pure a Left (AppException err) -> do runInIO (logError err) respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = Multipart.parseMultipartOrThrow (appThrowTree span) parser req let torrentIdMp span = mp span ( do label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) ) let parseQueryArgsNewSpan spanName parser = Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req & assertMNewSpan spanName id let handlers :: Handlers (AppT IO) handlers respond = Map.fromList [ ("", respond.html (mainHtml uniqueRunId)), ( "snips/redacted/search", respond.html $ \span -> do dat <- mp span ( do label @"searchstr" <$> Multipart.field "redacted-search" Cat.id ) snipsRedactedSearch dat ), ( "snips/redacted/torrentDataJson", respond.html $ \span -> do dat <- torrentIdMp span Html.mkVal <$> (runTransaction $ getTorrentById dat) ), ( "snips/redacted/getTorrentFile", respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do inserted <- redactedGetTorrentFileAndInsert dat running <- lift @Transaction $ doTransmissionRequest' (transmissionRequestAddTorrent inserted) updateTransmissionTorrentHashById ( T2 (getLabel @"torrentHash" running) (getLabel @"torrentId" dat) ) pure $ everySecond "snips/transmission/getTorrentState" (Enc.object [("torrent-hash", Enc.text running.torrentHash)]) "Starting" ), -- TODO: this is bad duplication?? ( "snips/redacted/startTorrentFile", respond.html $ \span -> do dat <- torrentIdMp span runTransaction $ do file <- getTorrentFileById dat <&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|] >>= orAppThrowTree span running <- lift @Transaction $ doTransmissionRequest' (transmissionRequestAddTorrent file) updateTransmissionTorrentHashById ( T2 (getLabel @"torrentHash" running) (getLabel @"torrentId" dat) ) pure $ everySecond "snips/transmission/getTorrentState" (Enc.object [("torrent-hash", Enc.text running.torrentHash)]) "Starting" ), ( "snips/transmission/getTorrentState", respond.html $ \span -> do dat <- mp span $ label @"torrentHash" <$> Multipart.field "torrent-hash" Field.utf8 status <- doTransmissionRequest' ( transmissionRequestListOnlyTorrents ( T2 (label @"ids" [label @"torrentHash" dat.torrentHash]) (label @"fields" ["hashString"]) ) (Json.keyLabel @"torrentHash" "hashString" Json.asText) ) <&> List.find (\torrent -> torrent.torrentHash == dat.torrentHash) pure $ case status of Nothing -> [hsx|ERROR unknown|] Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", do let HandlerResponses {htmlWithQueryArgs} = respond htmlWithQueryArgs ( label @"target" <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) & Parse.andParse uriToHttpClientRequest ) ) ( \qry _span -> do jsonld <- httpGetJsonLd (qry.target) pure $ renderJsonld jsonld ) ), ( "artist", do let HandlerResponses {htmlWithQueryArgs} = respond htmlWithQueryArgs ( label @"redactedId" <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) ) $ \qry _span -> do artistPage qry ), ( "autorefresh", respond.plain $ do qry <- parseQueryArgsNewSpan "Autorefresh Query Parse" ( label @"hasItBeenRestarted" <$> singleQueryArgument "hasItBeenRestarted" Field.utf8 ) pure $ Wai.responseLBS Http.ok200 ( [("Content-Type", "text/html")] <> if uniqueRunId /= qry.hasItBeenRestarted then -- cause the client side to refresh [("HX-Refresh", "true")] else [] ) "" ) ] runInIO $ runHandlers (\respond -> respond.html $ (mainHtml uniqueRunId)) handlers req respondOrig where everySecond :: Text -> Enc -> Html -> Html everySecond call extraData innerHtml = [hsx|
{err & prettyErrorTree}|] ) } ) let handler = (handlers handlerResponses) & Map.lookup path & fromMaybe (defaultHandler handlerResponses) runInIO handler 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 (Nothing :: Maybe (Label "redactedId" Natural)) data ArtistFilter = ArtistFilter { onlyArtist :: Maybe (Label "artistId" Text) } getBestTorrentsTable :: ( MonadTransmission m, MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m ) => Maybe (Label "redactedId" Natural) -> Transaction m Html getBestTorrentsTable artistFilter = do bestStale :: [TorrentData ()] <- getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} 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 let artists = b.artists <&> ( \a -> T2 (label @"url" [fmt|/artist?redacted_id={a.artistId}|]) (label @"content" $ Html.toHtml @Text a.artistName) ) & mkLinkList [hsx|
Local | Group ID | Artist | Name | Weight | Torrent | Torrent Group |
---|