about summary refs log tree commit diff
path: root/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
diff options
context:
space:
mode:
authorProfpatsch <mail@profpatsch.de>2024-03-03T13·19+0100
committerProfpatsch <mail@profpatsch.de>2024-03-03T13·31+0000
commit9a7246ea1dac200648976be4558e29c3e9aa7eb7 (patch)
tree4d14135dce68934f9ffc879e35a235af81d5fa0c /users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
parentde5790aba84fafaea11fdd88c9a664d29bb6d191 (diff)
chore(users/Profpatsch/whatcd-resolver): slight changes r/7639
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>
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
-rw-r--r--users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs112
1 files changed, 51 insertions, 61 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index 6b8efd8a78c0..420861a2035b 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -7,8 +7,6 @@ module WhatcdResolver where
 
 import Control.Category qualified as Cat
 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.CallStack
 import Control.Monad.Reader
@@ -42,7 +40,6 @@ import Json.Enc qualified as Enc
 import Label
 import Multipart2 qualified as Multipart
 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.Types
 import Network.HTTP.Types qualified as Http
@@ -86,7 +83,7 @@ main =
     <&> first showToError
     >>= expectIOError "could not start whatcd-resolver"
 
-htmlUi :: App ()
+htmlUi :: AppT IO ()
 htmlUi = do
   let debug = True
   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>|]
 
     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
       -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
       pure $
@@ -243,7 +240,7 @@ htmlUi = do
         </style>
       </head>
       <body>
-        {jsonld}
+        {""::Text {-jsonld-}}
         <form
           hx-post="/snips/redacted/search"
           hx-target="#redacted-search-results">
@@ -425,21 +422,21 @@ 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
+      | 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
@@ -490,9 +487,9 @@ 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)
+              | 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
@@ -834,10 +831,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
           (label @"action" "download")
           ( label @"actionArgs"
               [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
-              -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
-              -- ANSWER: it breaks:
-              -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
-              -- ("usetoken", Just "1")
+                -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
+                -- ANSWER: it breaks:
+                -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
+                -- ("usetoken", Just "1")
               ]
           )
       )
@@ -1256,11 +1253,11 @@ getBestTorrents = do
           TorrentData
             { torrentStatus =
                 if
-                    | not hasTorrentFile -> NoTorrentFileYet
-                    | Nothing <- transmissionTorrentHash -> NotInTransmissionYet
-                    | Just hash <- transmissionTorrentHash ->
-                        InTransmission $
-                          T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()),
+                  | not hasTorrentFile -> NoTorrentFileYet
+                  | Nothing <- transmissionTorrentHash -> NotInTransmissionYet
+                  | Just hash <- transmissionTorrentHash ->
+                      InTransmission $
+                        T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()),
               ..
             }
     )
@@ -1353,16 +1350,16 @@ httpTorrent span req =
                   <&> 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}|]
+            | 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}|]
       )
 
 newtype Optional a = OptionalInternal (Maybe a)
@@ -1401,17 +1398,17 @@ httpJson opts span parser req = do
                   <&> Wai.parseContentType
                   <&> (\(ct, _mimeAttributes) -> ct)
           if
-              | statusCode == 200,
-                Just ct <- contentType,
-                ct == opts'.contentType ->
-                  Right $ (resp & Http.responseBody)
-              | statusCode == 200,
-                Just otherType <- contentType ->
-                  Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
-              | statusCode == 200,
-                Nothing <- contentType ->
-                  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}|]
+            | statusCode == 200,
+              Just ct <- contentType,
+              ct == opts'.contentType ->
+                Right $ (resp & Http.responseBody)
+            | statusCode == 200,
+              Just otherType <- contentType ->
+                Left [fmt|Server returned a non-json body, with content-type "{otherType}"|]
+            | statusCode == 200,
+              Nothing <- contentType ->
+                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}|]
       )
     >>= assertM
       span
@@ -1512,8 +1509,6 @@ data Context = Context
 newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
 
-type App a = AppT IO a
-
 data AppException = AppException Text
   deriving stock (Show)
   deriving anyclass (Exception)
@@ -1594,8 +1589,3 @@ runPGTransaction (Transaction transaction) = do
   withRunInIO $ \unliftIO ->
     withPGTransaction pool $ \conn -> do
       unliftIO $ runReaderT transaction conn
-
-data HasQueryParams param
-  = HasNoParams
-  | HasSingleParam param
-  | HasMultiParams [param]
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-09T00·48+0000