feat(users/Profpatsch/whatcd-resolver): INSERT red search results
Change-Id: Ice7fdb2e265cfb99734ed41d17b62ac98f7a4869 Reviewed-on: https://cl.tvl.fyi/c/depot/+/8840 Reviewed-by: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI
This commit is contained in:
		
							parent
							
								
									98e38339f2
								
							
						
					
					
						commit
						70da4318f5
					
				
					 2 changed files with 231 additions and 52 deletions
				
			
		| 
						 | 
					@ -3,6 +3,7 @@
 | 
				
			||||||
{-# LANGUAGE QuasiQuotes #-}
 | 
					{-# LANGUAGE QuasiQuotes #-}
 | 
				
			||||||
{-# LANGUAGE TypeFamilyDependencies #-}
 | 
					{-# LANGUAGE TypeFamilyDependencies #-}
 | 
				
			||||||
{-# LANGUAGE UndecidableInstances #-}
 | 
					{-# LANGUAGE UndecidableInstances #-}
 | 
				
			||||||
 | 
					{-# OPTIONS_GHC -Wno-orphans #-}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
module Postgres.MonadPostgres where
 | 
					module Postgres.MonadPostgres where
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -18,6 +19,10 @@ import Data.Typeable (Typeable)
 | 
				
			||||||
import Database.PostgreSQL.Simple (Connection, FormatError, FromRow, Query, QueryError, ResultError, SqlError, ToRow)
 | 
					import Database.PostgreSQL.Simple (Connection, FormatError, FromRow, Query, QueryError, ResultError, SqlError, ToRow)
 | 
				
			||||||
import Database.PostgreSQL.Simple qualified as PG
 | 
					import Database.PostgreSQL.Simple qualified as PG
 | 
				
			||||||
import Database.PostgreSQL.Simple.FromRow qualified as PG
 | 
					import Database.PostgreSQL.Simple.FromRow qualified as PG
 | 
				
			||||||
 | 
					import Database.PostgreSQL.Simple.ToField (ToField)
 | 
				
			||||||
 | 
					import Database.PostgreSQL.Simple.ToRow (ToRow (toRow))
 | 
				
			||||||
 | 
					import Database.PostgreSQL.Simple.Types (fromQuery)
 | 
				
			||||||
 | 
					import GHC.Records (HasField (..))
 | 
				
			||||||
import Label
 | 
					import Label
 | 
				
			||||||
import PossehlAnalyticsPrelude
 | 
					import PossehlAnalyticsPrelude
 | 
				
			||||||
import Postgres.Decoder
 | 
					import Postgres.Decoder
 | 
				
			||||||
| 
						 | 
					@ -33,10 +38,15 @@ import UnliftIO.Process qualified as Process
 | 
				
			||||||
-- and will behave the same unless othewise documented.
 | 
					-- and will behave the same unless othewise documented.
 | 
				
			||||||
class Monad m => MonadPostgres (m :: Type -> Type) where
 | 
					class Monad m => MonadPostgres (m :: Type -> Type) where
 | 
				
			||||||
  -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results.
 | 
					  -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results.
 | 
				
			||||||
 | 
					  --
 | 
				
			||||||
  -- Returns the number of rows affected.
 | 
					  -- Returns the number of rows affected.
 | 
				
			||||||
  execute :: (ToRow params, Typeable params) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural)
 | 
					  execute :: (ToRow params, Typeable params) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. Does not perform parameter substitution.
 | 
				
			||||||
 | 
					  --
 | 
				
			||||||
 | 
					  -- Returns the number of rows affected.
 | 
				
			||||||
 | 
					  execute_ :: Query -> Transaction m (Label "numberOfRowsAffected" Natural)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  -- | Execute a multi-row INSERT, UPDATE, or other SQL query that is not expected to return results.
 | 
					  -- | Execute a multi-row INSERT, UPDATE, or other SQL query that is not expected to return results.
 | 
				
			||||||
  --
 | 
					  --
 | 
				
			||||||
  -- Returns the number of rows affected. If the list of parameters is empty, this function will simply return 0 without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
 | 
					  -- Returns the number of rows affected. If the list of parameters is empty, this function will simply return 0 without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
 | 
				
			||||||
| 
						 | 
					@ -45,7 +55,7 @@ class Monad m => MonadPostgres (m :: Type -> Type) where
 | 
				
			||||||
  -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING, or other SQL query that accepts multi-row input and is expected to return results. Note that it is possible to write query conn "INSERT ... RETURNING ..." ... in cases where you are only inserting a single row, and do not need functionality analogous to 'executeMany'.
 | 
					  -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING, or other SQL query that accepts multi-row input and is expected to return results. Note that it is possible to write query conn "INSERT ... RETURNING ..." ... in cases where you are only inserting a single row, and do not need functionality analogous to 'executeMany'.
 | 
				
			||||||
  --
 | 
					  --
 | 
				
			||||||
  -- If the list of parameters is empty, this function will simply return [] without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
 | 
					  -- If the list of parameters is empty, this function will simply return [] without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
 | 
				
			||||||
  executeManyReturning :: (ToRow q, FromRow r) => Query -> [q] -> Transaction m [r]
 | 
					  executeManyReturningWith :: (ToRow q) => Query -> [q] -> Decoder r -> Transaction m [r]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  -- | Run a query, passing parameters and result row parser.
 | 
					  -- | Run a query, passing parameters and result row parser.
 | 
				
			||||||
  queryWith :: (PG.ToRow params, Typeable params, Typeable r) => PG.Query -> params -> Decoder r -> Transaction m [r]
 | 
					  queryWith :: (PG.ToRow params, Typeable params, Typeable r) => PG.Query -> params -> Decoder r -> Transaction m [r]
 | 
				
			||||||
| 
						 | 
					@ -145,27 +155,6 @@ ensureSingleRow = \case
 | 
				
			||||||
            List.length more
 | 
					            List.length more
 | 
				
			||||||
        }
 | 
					        }
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- | A better `query`
 | 
					 | 
				
			||||||
--
 | 
					 | 
				
			||||||
-- Parameters are passed first,
 | 
					 | 
				
			||||||
-- then a Proxy which you should annotate with the return type of the query.
 | 
					 | 
				
			||||||
-- This way it’s right before the @SELECT@,
 | 
					 | 
				
			||||||
-- meaning it’s easy to see whether the two correspond.
 | 
					 | 
				
			||||||
--
 | 
					 | 
				
			||||||
-- TODO: maybe replace the query function in the class with this?
 | 
					 | 
				
			||||||
queryBetter ::
 | 
					 | 
				
			||||||
  ( MonadPostgres m,
 | 
					 | 
				
			||||||
    ToRow params,
 | 
					 | 
				
			||||||
    FromRow res,
 | 
					 | 
				
			||||||
    Typeable params,
 | 
					 | 
				
			||||||
    Typeable res
 | 
					 | 
				
			||||||
  ) =>
 | 
					 | 
				
			||||||
  params ->
 | 
					 | 
				
			||||||
  Proxy res ->
 | 
					 | 
				
			||||||
  Query ->
 | 
					 | 
				
			||||||
  Transaction m [res]
 | 
					 | 
				
			||||||
queryBetter params Proxy q = query q params
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)}
 | 
					newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)}
 | 
				
			||||||
  deriving newtype
 | 
					  deriving newtype
 | 
				
			||||||
    ( Functor,
 | 
					    ( Functor,
 | 
				
			||||||
| 
						 | 
					@ -251,11 +240,11 @@ toNumberOfRowsAffected functionName i64 =
 | 
				
			||||||
    & liftIO
 | 
					    & liftIO
 | 
				
			||||||
    <&> label @"numberOfRowsAffected"
 | 
					    <&> label @"numberOfRowsAffected"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
pgExecuteManyReturning :: (ToRow params, FromRow r, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Transaction m [r]
 | 
					pgExecuteManyReturningWith :: (ToRow params, MonadUnliftIO m, MonadLogger m, MonadTools m) => Query -> [params] -> Decoder r -> Transaction m [r]
 | 
				
			||||||
pgExecuteManyReturning qry params =
 | 
					pgExecuteManyReturningWith qry params (Decoder fromRow) =
 | 
				
			||||||
  do
 | 
					  do
 | 
				
			||||||
    conn <- Transaction ask
 | 
					    conn <- Transaction ask
 | 
				
			||||||
    PG.returning conn qry params
 | 
					    PG.returningWith fromRow conn qry params
 | 
				
			||||||
      & handlePGException "executeManyReturning" qry (Right params)
 | 
					      & handlePGException "executeManyReturning" qry (Right params)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
pgFold ::
 | 
					pgFold ::
 | 
				
			||||||
| 
						 | 
					@ -324,6 +313,10 @@ data SingleRowError = SingleRowError
 | 
				
			||||||
instance Exception SingleRowError where
 | 
					instance Exception SingleRowError where
 | 
				
			||||||
  displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|]
 | 
					  displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					pgFormatQueryNoParams' :: (MonadIO m, MonadLogger m, MonadTools m) => Query -> Transaction m Text
 | 
				
			||||||
 | 
					pgFormatQueryNoParams' q =
 | 
				
			||||||
 | 
					  lift $ pgFormatQueryByteString q.fromQuery
 | 
				
			||||||
 | 
					
 | 
				
			||||||
pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> params -> Transaction m Text
 | 
					pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, MonadTools m) => Query -> params -> Transaction m Text
 | 
				
			||||||
pgFormatQuery' q p =
 | 
					pgFormatQuery' q p =
 | 
				
			||||||
  pgFormatQuery q p
 | 
					  pgFormatQuery q p
 | 
				
			||||||
| 
						 | 
					@ -375,3 +368,9 @@ pgFormatQueryByteString queryBytes = do
 | 
				
			||||||
          )
 | 
					          )
 | 
				
			||||||
        logDebug [fmt|pg_format stdout: stderr|]
 | 
					        logDebug [fmt|pg_format stdout: stderr|]
 | 
				
			||||||
        pure (queryBytes & bytesToTextUtf8Lenient)
 | 
					        pure (queryBytes & bytesToTextUtf8Lenient)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					instance (ToField t1, ToField t2) => ToRow (T2 l1 t1 l2 t2) where
 | 
				
			||||||
 | 
					  toRow t2 = toRow (getField @l1 t2, getField @l2 t2)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					instance (ToField t1, ToField t2, ToField t3) => ToRow (T3 l1 t1 l2 t2 l3 t3) where
 | 
				
			||||||
 | 
					  toRow t3 = toRow (getField @l1 t3, getField @l2 t3, getField @l3 t3)
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -4,6 +4,7 @@
 | 
				
			||||||
 | 
					
 | 
				
			||||||
module WhatcdResolver where
 | 
					module WhatcdResolver where
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					import Control.Concurrent (threadDelay)
 | 
				
			||||||
import Control.Monad.Logger qualified as Logger
 | 
					import Control.Monad.Logger qualified as Logger
 | 
				
			||||||
import Control.Monad.Logger.CallStack
 | 
					import Control.Monad.Logger.CallStack
 | 
				
			||||||
import Control.Monad.Reader
 | 
					import Control.Monad.Reader
 | 
				
			||||||
| 
						 | 
					@ -16,11 +17,14 @@ import Data.Map.Strict qualified as Map
 | 
				
			||||||
import Data.Pool (Pool)
 | 
					import Data.Pool (Pool)
 | 
				
			||||||
import Data.Pool qualified as Pool
 | 
					import Data.Pool qualified as Pool
 | 
				
			||||||
import Data.Text qualified as Text
 | 
					import Data.Text qualified as Text
 | 
				
			||||||
import Data.Text.IO qualified as Text
 | 
					import Database.PostgreSQL.Simple (Only (..))
 | 
				
			||||||
import Database.PostgreSQL.Simple qualified as Postgres
 | 
					import Database.PostgreSQL.Simple qualified as Postgres
 | 
				
			||||||
 | 
					import Database.PostgreSQL.Simple.SqlQQ (sql)
 | 
				
			||||||
 | 
					import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 | 
				
			||||||
import Database.PostgreSQL.Simple.Types qualified as Postgres
 | 
					import Database.PostgreSQL.Simple.Types qualified as Postgres
 | 
				
			||||||
import Database.Postgres.Temp qualified as TmpPg
 | 
					import Database.Postgres.Temp qualified as TmpPg
 | 
				
			||||||
import FieldParser qualified as Field
 | 
					import FieldParser qualified as Field
 | 
				
			||||||
 | 
					import GHC.Records (HasField (..))
 | 
				
			||||||
import Json qualified
 | 
					import Json qualified
 | 
				
			||||||
import Json.Enc (Enc)
 | 
					import Json.Enc (Enc)
 | 
				
			||||||
import Json.Enc qualified as Enc
 | 
					import Json.Enc qualified as Enc
 | 
				
			||||||
| 
						 | 
					@ -46,6 +50,7 @@ data TransmissionRequest = TransmissionRequest
 | 
				
			||||||
  }
 | 
					  }
 | 
				
			||||||
  deriving stock (Show)
 | 
					  deriving stock (Show)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					requestListAllTorrents :: TransmissionRequest
 | 
				
			||||||
requestListAllTorrents =
 | 
					requestListAllTorrents =
 | 
				
			||||||
  TransmissionRequest
 | 
					  TransmissionRequest
 | 
				
			||||||
    { method = "torrent-get",
 | 
					    { method = "torrent-get",
 | 
				
			||||||
| 
						 | 
					@ -132,23 +137,163 @@ doTransmissionRequest dat req = do
 | 
				
			||||||
          Left err -> appThrowTree err
 | 
					          Left err -> appThrowTree err
 | 
				
			||||||
    _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
 | 
					    _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
redactedSearch advanced = redactedApiRequest (T2 (label @"action" "browse") (label @"actionArgs" ((advanced <&> second Just))))
 | 
					redactedSearch ::
 | 
				
			||||||
 | 
					  (MonadLogger m, MonadIO m, MonadThrow m) =>
 | 
				
			||||||
 | 
					  [(ByteString, ByteString)] ->
 | 
				
			||||||
 | 
					  Json.Parse ErrorTree a ->
 | 
				
			||||||
 | 
					  m a
 | 
				
			||||||
 | 
					redactedSearch advanced =
 | 
				
			||||||
 | 
					  redactedApiRequest
 | 
				
			||||||
 | 
					    ( T2
 | 
				
			||||||
 | 
					        (label @"action" "browse")
 | 
				
			||||||
 | 
					        (label @"actionArgs" ((advanced <&> second Just)))
 | 
				
			||||||
 | 
					    )
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					test :: IO (Either TmpPg.StartError a)
 | 
				
			||||||
test =
 | 
					test =
 | 
				
			||||||
  runAppWith $
 | 
					  runAppWith $ do
 | 
				
			||||||
 | 
					    _ <- runTransaction migrate
 | 
				
			||||||
 | 
					    transaction <- bla
 | 
				
			||||||
 | 
					    runTransaction transaction
 | 
				
			||||||
 | 
					    fix
 | 
				
			||||||
 | 
					      ( \io -> do
 | 
				
			||||||
 | 
					          logInfo "delay"
 | 
				
			||||||
 | 
					          liftIO $ threadDelay 10_000_000
 | 
				
			||||||
 | 
					          io
 | 
				
			||||||
 | 
					      )
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					bla :: (MonadThrow m, MonadIO m, MonadLogger m, MonadPostgres m) => m (Transaction m [Label "numberOfRowsAffected" Natural])
 | 
				
			||||||
 | 
					bla =
 | 
				
			||||||
  redactedSearch
 | 
					  redactedSearch
 | 
				
			||||||
      [ ("artistname", "michael jackson"),
 | 
					    [ ("searchstr", "cherish"),
 | 
				
			||||||
        ("year", "1982"),
 | 
					      ("artistname", "kirinji"),
 | 
				
			||||||
        ("format", "MP3"),
 | 
					      -- ("year", "1982"),
 | 
				
			||||||
        ("releasetype", "album"),
 | 
					      -- ("format", "MP3"),
 | 
				
			||||||
 | 
					      -- ("releasetype", "album"),
 | 
				
			||||||
      ("order_by", "year")
 | 
					      ("order_by", "year")
 | 
				
			||||||
    ]
 | 
					    ]
 | 
				
			||||||
      <&> (fmap $ fromMaybe undefined)
 | 
					    ( do
 | 
				
			||||||
      <&> (Http.getResponseBody)
 | 
					        status <- Json.key "status" Json.asText
 | 
				
			||||||
      <&> showPrettyJson
 | 
					        when (status /= "success") $ do
 | 
				
			||||||
      >>= liftIO . Text.putStrLn
 | 
					          Json.throwCustomError [fmt|Status was not "success", but {status}|]
 | 
				
			||||||
 | 
					        Json.key "response" $ do
 | 
				
			||||||
 | 
					          Json.key "results" $
 | 
				
			||||||
 | 
					            sequence
 | 
				
			||||||
 | 
					              <$> ( Json.eachInArray $ do
 | 
				
			||||||
 | 
					                      groupId <- Json.key "groupId" (Json.asIntegral @_ @Int)
 | 
				
			||||||
 | 
					                      groupName <- Json.key "groupName" Json.asText
 | 
				
			||||||
 | 
					                      fullJsonResult <- Json.asValue
 | 
				
			||||||
 | 
					                      let insertTourGroup = do
 | 
				
			||||||
 | 
					                            _ <-
 | 
				
			||||||
 | 
					                              execute
 | 
				
			||||||
 | 
					                                [fmt|
 | 
				
			||||||
 | 
					                                  DELETE FROM redacted.torrent_groups
 | 
				
			||||||
 | 
					                                  WHERE group_id = ?::integer
 | 
				
			||||||
 | 
					                              |]
 | 
				
			||||||
 | 
					                                (Only groupId)
 | 
				
			||||||
 | 
					                            executeManyReturningWith
 | 
				
			||||||
 | 
					                              [fmt|
 | 
				
			||||||
 | 
					                                INSERT INTO redacted.torrent_groups (
 | 
				
			||||||
 | 
					                                  group_id, group_name, full_json_result
 | 
				
			||||||
 | 
					                                ) VALUES
 | 
				
			||||||
 | 
					                                ( ?, ? , ? )
 | 
				
			||||||
 | 
					                                RETURNING (id)
 | 
				
			||||||
 | 
					                              |]
 | 
				
			||||||
 | 
					                              [ ( groupId,
 | 
				
			||||||
 | 
					                                  groupName,
 | 
				
			||||||
 | 
					                                  fullJsonResult
 | 
				
			||||||
 | 
					                                )
 | 
				
			||||||
 | 
					                              ]
 | 
				
			||||||
 | 
					                              (label @"tourGroupIdPg" <$> Dec.fromField @Int)
 | 
				
			||||||
 | 
					                              >>= ensureSingleRow
 | 
				
			||||||
 | 
					                      insertTorrents <- Json.key "torrents" $ do
 | 
				
			||||||
 | 
					                        torrents <- Json.eachInArray $ do
 | 
				
			||||||
 | 
					                          torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int)
 | 
				
			||||||
 | 
					                          fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue
 | 
				
			||||||
 | 
					                          pure $ T2 torrentId fullJsonResultT
 | 
				
			||||||
 | 
					                        pure $ \dat -> do
 | 
				
			||||||
 | 
					                          _ <-
 | 
				
			||||||
 | 
					                            execute
 | 
				
			||||||
 | 
					                              [sql|
 | 
				
			||||||
 | 
					                                  DELETE FROM redacted.torrents
 | 
				
			||||||
 | 
					                                  WHERE torrent_id = ANY (?::integer[])
 | 
				
			||||||
 | 
					                            |]
 | 
				
			||||||
 | 
					                              (Only $ torrents & unzipT2 & (.torrentId) & PGArray)
 | 
				
			||||||
 | 
					                          execute
 | 
				
			||||||
 | 
					                            [sql|
 | 
				
			||||||
 | 
					                                  INSERT INTO redacted.torrents
 | 
				
			||||||
 | 
					                                        (torrent_id, torrent_group, full_json_result)
 | 
				
			||||||
 | 
					                                  SELECT inputs.torrent_id, static.torrent_group, inputs.full_json_result FROM
 | 
				
			||||||
 | 
					                                  (SELECT * FROM UNNEST(?::integer[], ?::jsonb[])) AS inputs(torrent_id, full_json_result)
 | 
				
			||||||
 | 
					                                  CROSS JOIN (VALUES(?::integer)) as static(torrent_group)
 | 
				
			||||||
 | 
					                            |]
 | 
				
			||||||
 | 
					                            ( torrents
 | 
				
			||||||
 | 
					                                & unzipT2
 | 
				
			||||||
 | 
					                                & \t ->
 | 
				
			||||||
 | 
					                                  ( t.torrentId & PGArray,
 | 
				
			||||||
 | 
					                                    t.fullJsonResult & PGArray,
 | 
				
			||||||
 | 
					                                    dat.tourGroupIdPg
 | 
				
			||||||
 | 
					                                  )
 | 
				
			||||||
 | 
					                            )
 | 
				
			||||||
 | 
					                      pure (insertTourGroup >>= insertTorrents)
 | 
				
			||||||
 | 
					                  )
 | 
				
			||||||
 | 
					    )
 | 
				
			||||||
 | 
					
 | 
				
			||||||
redactedApiRequest dat = do
 | 
					hush :: Either a1 a2 -> Maybe a2
 | 
				
			||||||
 | 
					hush (Left _) = Nothing
 | 
				
			||||||
 | 
					hush (Right a) = Just a
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					unzipT2 :: forall l1 t1 l2 t2. [T2 l1 t1 l2 t2] -> T2 l1 [t1] l2 [t2]
 | 
				
			||||||
 | 
					unzipT2 xs = xs <&> toTup & unzip & fromTup
 | 
				
			||||||
 | 
					  where
 | 
				
			||||||
 | 
					    toTup :: forall a b. T2 a t1 b t2 -> (t1, t2)
 | 
				
			||||||
 | 
					    toTup (T2 a b) = (getField @a a, getField @b b)
 | 
				
			||||||
 | 
					    fromTup :: (a, b) -> T2 l1 a l2 b
 | 
				
			||||||
 | 
					    fromTup (t1, t2) = T2 (label @l1 t1) (label @l2 t2)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					unzipT3 :: forall l1 t1 l2 t2 l3 t3. [T3 l1 t1 l2 t2 l3 t3] -> T3 l1 [t1] l2 [t2] l3 [t3]
 | 
				
			||||||
 | 
					unzipT3 xs = xs <&> toTup & unzip3 & fromTup
 | 
				
			||||||
 | 
					  where
 | 
				
			||||||
 | 
					    toTup :: forall a b c. T3 a t1 b t2 c t3 -> (t1, t2, t3)
 | 
				
			||||||
 | 
					    toTup (T3 a b c) = (getField @a a, getField @b b, getField @c c)
 | 
				
			||||||
 | 
					    fromTup :: (a, b, c) -> T3 l1 a l2 b l3 c
 | 
				
			||||||
 | 
					    fromTup (t1, t2, t3) = T3 (label @l1 t1) (label @l2 t2) (label @l3 t3)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					migrate :: MonadPostgres m => Transaction m (Label "numberOfRowsAffected" Natural)
 | 
				
			||||||
 | 
					migrate = 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 (
 | 
				
			||||||
 | 
					      id SERIAL PRIMARY KEY,
 | 
				
			||||||
 | 
					      torrent_id INTEGER,
 | 
				
			||||||
 | 
					      torrent_group SERIAL NOT NULL REFERENCES redacted.torrent_groups(id),
 | 
				
			||||||
 | 
					      full_json_result JSONB,
 | 
				
			||||||
 | 
					      UNIQUE(torrent_id)
 | 
				
			||||||
 | 
					    );
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  |]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					redactedApiRequest ::
 | 
				
			||||||
 | 
					  ( MonadThrow m,
 | 
				
			||||||
 | 
					    MonadIO m,
 | 
				
			||||||
 | 
					    MonadLogger m,
 | 
				
			||||||
 | 
					    HasField "action" p ByteString,
 | 
				
			||||||
 | 
					    HasField "actionArgs" p [(ByteString, Maybe ByteString)]
 | 
				
			||||||
 | 
					  ) =>
 | 
				
			||||||
 | 
					  p ->
 | 
				
			||||||
 | 
					  Json.Parse ErrorTree a ->
 | 
				
			||||||
 | 
					  m a
 | 
				
			||||||
 | 
					redactedApiRequest dat parse = do
 | 
				
			||||||
  authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
 | 
					  authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
 | 
				
			||||||
  let req =
 | 
					  let req =
 | 
				
			||||||
        [fmt|https://redacted.ch/ajax.php|]
 | 
					        [fmt|https://redacted.ch/ajax.php|]
 | 
				
			||||||
| 
						 | 
					@ -156,7 +301,20 @@ redactedApiRequest dat = do
 | 
				
			||||||
          & Http.setQueryString (("action", Just dat.action) : dat.actionArgs)
 | 
					          & Http.setQueryString (("action", Just dat.action) : dat.actionArgs)
 | 
				
			||||||
          & Http.setRequestHeader "Authorization" [authKey]
 | 
					          & Http.setRequestHeader "Authorization" [authKey]
 | 
				
			||||||
  Http.httpBS req
 | 
					  Http.httpBS req
 | 
				
			||||||
    <&> fmap (Json.decodeStrict' @Json.Value)
 | 
					    >>= assertM
 | 
				
			||||||
 | 
					      ( \resp -> case resp & Http.responseStatus & (.statusCode) of
 | 
				
			||||||
 | 
					          200 -> Right $ resp & Http.responseBody
 | 
				
			||||||
 | 
					          _ -> Left [fmt|Redacted returned an non-200 error code: {resp & showPretty}|]
 | 
				
			||||||
 | 
					      )
 | 
				
			||||||
 | 
					    >>= ( Json.parseStrict parse
 | 
				
			||||||
 | 
					            >>> first (Json.parseErrorTree "could not parse redacted response")
 | 
				
			||||||
 | 
					            >>> assertM id
 | 
				
			||||||
 | 
					        )
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					assertM :: MonadThrow f => (t -> Either ErrorTree a) -> t -> f a
 | 
				
			||||||
 | 
					assertM f v = case f v of
 | 
				
			||||||
 | 
					  Right a -> pure a
 | 
				
			||||||
 | 
					  Left err -> appThrowTree err
 | 
				
			||||||
 | 
					
 | 
				
			||||||
runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
 | 
					runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a)
 | 
				
			||||||
runAppWith appT = withDb $ \db -> do
 | 
					runAppWith appT = withDb $ \db -> do
 | 
				
			||||||
| 
						 | 
					@ -170,12 +328,18 @@ runAppWith appT = withDb $ \db -> do
 | 
				
			||||||
      {- unusedResourceOpenTime -} 10
 | 
					      {- unusedResourceOpenTime -} 10
 | 
				
			||||||
      {- max resources per stripe -} 10
 | 
					      {- max resources per stripe -} 10
 | 
				
			||||||
  transmissionSessionId <- newEmptyMVar
 | 
					  transmissionSessionId <- newEmptyMVar
 | 
				
			||||||
  runReaderT appT.unAppT Context {..}
 | 
					  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 {..}
 | 
				
			||||||
 | 
					
 | 
				
			||||||
withDb :: (TmpPg.DB -> IO a) -> IO (Either TmpPg.StartError a)
 | 
					withDb :: (TmpPg.DB -> IO a) -> IO (Either TmpPg.StartError a)
 | 
				
			||||||
withDb act = do
 | 
					withDb act = do
 | 
				
			||||||
  dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver"
 | 
					  dataDir <- Xdg.getXdgDirectory Xdg.XdgData "whatcd-resolver"
 | 
				
			||||||
  let databaseDir = dataDir </> "database"
 | 
					  let databaseDir = dataDir </> "database"
 | 
				
			||||||
 | 
					  let socketDir = dataDir </> "database-socket"
 | 
				
			||||||
 | 
					  Dir.createDirectoryIfMissing True socketDir
 | 
				
			||||||
  initDbConfig <-
 | 
					  initDbConfig <-
 | 
				
			||||||
    Dir.doesDirectoryExist databaseDir >>= \case
 | 
					    Dir.doesDirectoryExist databaseDir >>= \case
 | 
				
			||||||
      True -> pure TmpPg.Zlich
 | 
					      True -> pure TmpPg.Zlich
 | 
				
			||||||
| 
						 | 
					@ -186,6 +350,8 @@ withDb act = do
 | 
				
			||||||
  let cfg =
 | 
					  let cfg =
 | 
				
			||||||
        mempty
 | 
					        mempty
 | 
				
			||||||
          { TmpPg.dataDirectory = TmpPg.Permanent (databaseDir),
 | 
					          { TmpPg.dataDirectory = TmpPg.Permanent (databaseDir),
 | 
				
			||||||
 | 
					            TmpPg.socketDirectory = TmpPg.Permanent socketDir,
 | 
				
			||||||
 | 
					            TmpPg.port = pure $ Just 5432,
 | 
				
			||||||
            TmpPg.initDbConfig
 | 
					            TmpPg.initDbConfig
 | 
				
			||||||
          }
 | 
					          }
 | 
				
			||||||
  TmpPg.withConfig cfg $ \db -> do
 | 
					  TmpPg.withConfig cfg $ \db -> do
 | 
				
			||||||
| 
						 | 
					@ -203,6 +369,8 @@ data Context = Context
 | 
				
			||||||
newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
 | 
					newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
 | 
				
			||||||
  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
 | 
					  deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					type App a = AppT IO a
 | 
				
			||||||
 | 
					
 | 
				
			||||||
data AppException = AppException Text
 | 
					data AppException = AppException Text
 | 
				
			||||||
  deriving stock (Show)
 | 
					  deriving stock (Show)
 | 
				
			||||||
  deriving anyclass (Exception)
 | 
					  deriving anyclass (Exception)
 | 
				
			||||||
| 
						 | 
					@ -229,20 +397,24 @@ instance (MonadIO m) => MonadTransmission (AppT m) where
 | 
				
			||||||
instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
 | 
					instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
 | 
				
			||||||
  execute qry params = do
 | 
					  execute qry params = do
 | 
				
			||||||
    conf <- lift $ AppT (asks (.config))
 | 
					    conf <- lift $ AppT (asks (.config))
 | 
				
			||||||
    logQueryIfEnabled conf qry (Left params)
 | 
					    logQueryIfEnabled conf qry (HasSingleParam params)
 | 
				
			||||||
    pgExecute qry params
 | 
					    pgExecute qry params
 | 
				
			||||||
 | 
					  execute_ qry = do
 | 
				
			||||||
 | 
					    conf <- lift $ AppT (asks (.config))
 | 
				
			||||||
 | 
					    logQueryIfEnabled @(Only Text) conf qry HasNoParams
 | 
				
			||||||
 | 
					    pgExecute_ qry
 | 
				
			||||||
  executeMany qry params = do
 | 
					  executeMany qry params = do
 | 
				
			||||||
    conf <- lift $ AppT (asks (.config))
 | 
					    conf <- lift $ AppT (asks (.config))
 | 
				
			||||||
    logQueryIfEnabled conf qry (Right params)
 | 
					    logQueryIfEnabled conf qry (HasMultiParams params)
 | 
				
			||||||
    pgExecuteMany qry params
 | 
					    pgExecuteMany qry params
 | 
				
			||||||
  executeManyReturning qry params = do
 | 
					  executeManyReturningWith qry params dec = do
 | 
				
			||||||
    conf <- lift $ AppT (asks (.config))
 | 
					    conf <- lift $ AppT (asks (.config))
 | 
				
			||||||
    logQueryIfEnabled conf qry (Right params)
 | 
					    logQueryIfEnabled conf qry (HasMultiParams params)
 | 
				
			||||||
    pgExecuteManyReturning qry params
 | 
					    pgExecuteManyReturningWith qry params dec
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  queryWith qry params decoder = do
 | 
					  queryWith qry params decoder = do
 | 
				
			||||||
    conf <- lift $ AppT (asks (.config))
 | 
					    conf <- lift $ AppT (asks (.config))
 | 
				
			||||||
    logQueryIfEnabled conf qry (Left params)
 | 
					    logQueryIfEnabled conf qry (HasSingleParam params)
 | 
				
			||||||
    pgQueryWith qry params decoder
 | 
					    pgQueryWith qry params decoder
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  -- TODO: log these queries as well with `logQueryIfEnabled`, but test out whether it works with query_ and foldRows first.
 | 
					  -- TODO: log these queries as well with `logQueryIfEnabled`, but test out whether it works with query_ and foldRows first.
 | 
				
			||||||
| 
						 | 
					@ -271,8 +443,14 @@ withPGTransaction connPool f =
 | 
				
			||||||
    connPool
 | 
					    connPool
 | 
				
			||||||
    (\conn -> Postgres.withTransaction conn (f conn))
 | 
					    (\conn -> Postgres.withTransaction conn (f conn))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					data HasQueryParams param
 | 
				
			||||||
 | 
					  = HasNoParams
 | 
				
			||||||
 | 
					  | HasSingleParam param
 | 
				
			||||||
 | 
					  | HasMultiParams [param]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
-- | Log the postgres query depending on the setting of @config.debugInfo.logDatabaseQueries@.
 | 
					-- | Log the postgres query depending on the setting of @config.debugInfo.logDatabaseQueries@.
 | 
				
			||||||
logQueryIfEnabled ::
 | 
					logQueryIfEnabled ::
 | 
				
			||||||
 | 
					  forall params config m.
 | 
				
			||||||
  ( Postgres.ToRow params,
 | 
					  ( Postgres.ToRow params,
 | 
				
			||||||
    MonadUnliftIO m,
 | 
					    MonadUnliftIO m,
 | 
				
			||||||
    MonadLogger m,
 | 
					    MonadLogger m,
 | 
				
			||||||
| 
						 | 
					@ -281,13 +459,14 @@ logQueryIfEnabled ::
 | 
				
			||||||
  ) =>
 | 
					  ) =>
 | 
				
			||||||
  config ->
 | 
					  config ->
 | 
				
			||||||
  Postgres.Query ->
 | 
					  Postgres.Query ->
 | 
				
			||||||
  Either params [params] ->
 | 
					  HasQueryParams params ->
 | 
				
			||||||
  Transaction m ()
 | 
					  Transaction m ()
 | 
				
			||||||
logQueryIfEnabled config qry params = do
 | 
					logQueryIfEnabled config qry params = do
 | 
				
			||||||
  -- In case we have query logging enabled, we want to do that
 | 
					  -- In case we have query logging enabled, we want to do that
 | 
				
			||||||
  let formattedQuery = case params of
 | 
					  let formattedQuery = case params of
 | 
				
			||||||
        Left p -> pgFormatQuery' qry p
 | 
					        HasNoParams -> pgFormatQueryNoParams' qry
 | 
				
			||||||
        Right ps -> pgFormatQueryMany' qry ps
 | 
					        HasSingleParam p -> pgFormatQuery' qry p
 | 
				
			||||||
 | 
					        HasMultiParams ps -> pgFormatQueryMany' qry ps
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  let doLog errs =
 | 
					  let doLog errs =
 | 
				
			||||||
        errs
 | 
					        errs
 | 
				
			||||||
| 
						 | 
					@ -330,3 +509,4 @@ data DatabaseLogging
 | 
				
			||||||
  = DontLogDatabaseQueries
 | 
					  = DontLogDatabaseQueries
 | 
				
			||||||
  | LogDatabaseQueries
 | 
					  | LogDatabaseQueries
 | 
				
			||||||
  | LogDatabaseQueriesAndExplain
 | 
					  | LogDatabaseQueriesAndExplain
 | 
				
			||||||
 | 
					  deriving stock (Show)
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue