{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module WhatcdResolver where
import Control.Category qualified as Cat
import Control.Monad.Logger qualified as Logger
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
import Data.HashMap.Strict qualified as HashMap
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Pool (Pool)
import Data.Pool qualified as Pool
import Data.Scientific (Scientific)
import Data.Text qualified as Text
import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
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' (..))
import FieldParser qualified as Field
import GHC.Records (HasField (..))
import GHC.Stack qualified
import IHP.HSX.QQ (hsx)
import Json qualified
import Json.Enc (Enc)
import Json.Enc qualified as Enc
import Label
import Multipart2 qualified as Multipart
import Network.HTTP.Conduit qualified as Http
import Network.HTTP.Simple qualified as Http
import Network.HTTP.Types
import Network.HTTP.Types qualified as Http
import Network.Wai qualified as Wai
import Network.Wai.Handler.Warp qualified as Warp
import Network.Wai.Parse qualified as Wai
import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
import OpenTelemetry.Trace.Monad qualified as Otel
import PossehlAnalyticsPrelude
import Postgres.Decoder qualified as Dec
import Postgres.MonadPostgres
import Pretty
import RunCommand (runCommandExpect0)
import System.Directory qualified as Dir
import System.Directory qualified as Xdg
import System.Environment qualified as Env
import System.FilePath (())
import System.IO qualified as IO
import Text.Blaze.Html (Html)
import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty
import Text.Blaze.Html.Renderer.Utf8 qualified as Html
import Text.Blaze.Html5 qualified as Html
import Tool (Tool, readTool, readTools)
import UnliftIO
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 :: App ()
htmlUi = do
let debug = True
withRunInIO $ \runInIO -> Warp.run 9092 $ \req respond -> do
let catchAppException act =
try act >>= \case
Right a -> pure a
Left (AppException err) -> do
runInIO (logError err)
respond (Wai.responseLBS Http.status500 [] "")
catchAppException $ do
let renderHtml =
if debug
then Html.Pretty.renderHtml >>> stringToText >>> textToBytesUtf8 >>> toLazyBytes
else Html.renderHtml
let h route act =
runInIO $
Otel.inSpan'
[fmt|Route {route }|]
( Otel.defaultSpanArguments
{ Otel.attributes =
HashMap.fromList
[ ("server.path", Otel.toAttribute @Text route)
]
}
)
( \span -> withRunInIO $ \runInIO' -> do
res <- runInIO' $ act span
respond . Wai.responseLBS Http.ok200 [("Content-Type", "text/html")] . renderHtml $ res
)
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"))
)
case req & Wai.pathInfo & Text.intercalate "/" of
"" -> h "/" (\_span -> mainHtml)
"snips/redacted/search" -> do
h "/snips/redacted/search" $ \span -> do
dat <-
mp
span
( do
label @"searchstr" <$> Multipart.field "redacted-search" Cat.id
)
snipsRedactedSearch dat
"snips/redacted/torrentDataJson" -> h "/snips/redacted/torrentDataJson" $ \span -> do
dat <- torrentIdMp span
mkVal <$> (runTransaction $ getTorrentById dat)
"snips/redacted/getTorrentFile" -> h "/snips/redacted/getTorrentFile" $ \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" -> h "/snips/redacted/startTorrentFile" $ \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" -> h "/snips/transmission/getTorrentState" $ \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|]
otherRoute -> h [fmt|/{otherRoute}|] (\_span -> mainHtml)
where
everySecond :: Text -> Enc -> Html -> Html
everySecond call extraData innerHtml = [hsx|
{innerHtml}
|]
mainHtml = runTransaction $ do
bestTorrentsTable <- getBestTorrentsTable
transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
pure $
Html.docTypeHtml
[hsx|
{bestTorrentsTable}
{transmissionTorrentsTable}
|]
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}
|]
-- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps.
newtype Percentage = Percentage {unPercentage :: Int}
deriving stock (Show)
-- | Parse a scientific into a Percentage
scientificPercentage :: FieldParser' Error Scientific Percentage
scientificPercentage =
Field.boundedScientificRealFloat @Float
>>> ( FieldParser $ \f ->
if
| f < 0 -> Left "percentage cannot be negative"
| f > 1 -> Left "percentage cannot be over 100%"
| otherwise -> Right $ Percentage $ ceiling (f * 100)
)
-- | Fetch the current status from transmission, and remove the tranmission hash from our database
-- iff it does not exist in transmission anymore
getAndUpdateTransmissionTorrentsStatus ::
( MonadTransmission m,
MonadThrow m,
MonadLogger m,
MonadPostgres m,
Otel.MonadTracer m,
MonadUnliftIO m
) =>
Map (Label "torrentHash" Text) () ->
(Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage)))
getAndUpdateTransmissionTorrentsStatus knownTorrents = do
let fields = ["hashString", "percentDone"]
actualTorrents <-
lift @Transaction $
doTransmissionRequest'
( transmissionRequestListOnlyTorrents
( T2
(label @"fields" fields)
(label @"ids" (Map.keys knownTorrents))
)
$ do
torrentHash <- Json.keyLabel @"torrentHash" "hashString" Json.asText
percentDone <- Json.keyLabel @"percentDone" "percentDone" (Field.jsonParser $ Field.jsonNumber >>> scientificPercentage)
pure (torrentHash, percentDone)
)
<&> Map.fromList
let toDelete = Map.difference knownTorrents actualTorrents
execute
[fmt|
UPDATE redacted.torrents_json
SET transmission_torrent_hash = NULL
WHERE transmission_torrent_hash = ANY (?::text[])
|]
$ Only (toDelete & Map.keys <&> (.torrentHash) & PGArray :: PGArray Text)
pure actualTorrents
getTransmissionTorrentsTable ::
(MonadTransmission m, MonadThrow m, MonadLogger m, Otel.MonadTracer m, MonadUnliftIO m) => m Html
getTransmissionTorrentsTable = do
let fields =
[ "hashString",
"name",
"percentDone",
"percentComplete",
"downloadDir",
"files"
]
doTransmissionRequest'
( transmissionRequestListAllTorrents fields $ do
Json.asObject <&> KeyMap.toMapText
)
<&> \resp ->
toTable
( resp
& List.sortOn (\m -> m & Map.lookup "percentDone" & fromMaybe (Json.Number 0))
<&> Map.toList
-- TODO
& List.take 100
)
-- | Render an arbitrary json value to HTML in a more-or-less reasonable fashion.
mkVal :: Json.Value -> Html
mkVal = \case
Json.Number n -> Html.toHtml @Text $ showToText n
Json.String s -> Html.toHtml @Text s
Json.Bool True -> [hsx|true|]
Json.Bool False -> [hsx|false|]
Json.Null -> [hsx|null|]
Json.Array arr ->
arr
& foldMap (\el -> Html.li $ mkVal el)
& Html.ol
Json.Object obj ->
obj
& KeyMap.toMapText
& Map.toList
& foldMap (\(k, v) -> Html.dt (Html.toHtml @Text k) <> Html.dd (mkVal v))
& Html.dl
-- | Render a table-like structure of json values as an HTML table.
toTable :: [[(Text, Json.Value)]] -> Html
toTable xs =
case xs & nonEmpty of
Nothing ->
[hsx|
No results.
|]
Just xs' -> do
let headers = xs' & NonEmpty.head <&> fst <&> (\h -> [hsx|