mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

feat(users/Profpatsch/my-prelude): update libraries

Browse source 
The latest and greatest!

Change-Id: I34c0e9f41b3b3cc727d9ea89c7ce6a43271b3170
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11169
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
Profpatsch 2024-03-16 23:26:49 +01:00 committed by clbot
parent 8335076173
commit 11a2098e0b
7 changed files with 513 additions and 145 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
users/Profpatsch/.hlint.yaml
View file

@ -129,7 +129,7 @@
message: "`Data.Foldable.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`."
- name: Prelude.length
within: []
within: [MyPrelude]
message: "`Prelude.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`."
# Using an explicit lambda with its argument “underscored”

1
users/Profpatsch/my-prelude/default.nix
View file

@ -28,6 +28,7 @@ pkgs.haskellPackages.mkDerivation {
pkgs.haskellPackages.pa-pretty
pkgs.haskellPackages.pa-field-parser
pkgs.haskellPackages.aeson-better-errors
pkgs.haskellPackages.foldl
pkgs.haskellPackages.resource-pool
pkgs.haskellPackages.error
pkgs.haskellPackages.hs-opentelemetry-api

5
users/Profpatsch/my-prelude/my-prelude.cabal
View file

@ -48,6 +48,8 @@ common common-options
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
ExplicitNamespaces
-- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax
PatternSynonyms
default-language: GHC2021
@ -83,6 +85,7 @@ library
, aeson-better-errors
, bytestring
, containers
, foldl
, unordered-containers
, resource-pool
, resourcet
@ -101,9 +104,11 @@ library
, PyF
, semigroupoids
, selective
, template-haskell
, text
, these
, unix
, unliftio
, validation-selective
, vector
, ghc-boot

288
users/Profpatsch/my-prelude/src/MyPrelude.hs
View file

@ -1,11 +1,7 @@
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
{-# LANGUAGE ViewPatterns #-}
module MyPrelude
( -- * Text conversions
@ -15,6 +11,7 @@ module MyPrelude
fmt,
textToString,
stringToText,
stringToBytesUtf8,
showToText,
textToBytesUtf8,
textToBytesUtf8Lazy,
@ -42,6 +39,7 @@ module MyPrelude
HasField,
-- * Control flow
doAs,
(&),
(<&>),
(<|>),
@ -91,6 +89,9 @@ module MyPrelude
failure,
successes,
failures,
traverseValidate,
traverseValidateM,
traverseValidateM_,
eitherToValidation,
eitherToListValidation,
validationToEither,
@ -100,15 +101,28 @@ module MyPrelude
validationToThese,
thenThese,
thenValidate,
thenValidateM,
NonEmpty ((:|)),
pattern IsEmpty,
pattern IsNonEmpty,
singleton,
nonEmpty,
nonEmptyDef,
overNonEmpty,
zipNonEmpty,
zipWithNonEmpty,
zip3NonEmpty,
zipWith3NonEmpty,
zip4NonEmpty,
toList,
toNonEmptyDefault,
lengthNatural,
maximum1,
minimum1,
maximumBy1,
minimumBy1,
Vector,
Generic,
Lift,
Semigroup,
sconcat,
Monoid,
@ -120,6 +134,7 @@ module MyPrelude
Identity (Identity, runIdentity),
Natural,
intToNatural,
Scientific,
Contravariant,
contramap,
(>$<),
@ -132,10 +147,16 @@ module MyPrelude
Category,
(>>>),
(&>>),
Any,
-- * Enum definition
inverseFunction,
inverseMap,
enumerateAll,
-- * Map helpers
mapFromListOn,
mapFromListOnMerge,
-- * Error handling
HasCallStack,
@ -145,6 +166,7 @@ where
import Control.Applicative ((<|>))
import Control.Category (Category, (>>>))
import Control.Foldl.NonEmpty qualified as Foldl1
import Control.Monad (guard, join, unless, when)
import Control.Monad.Catch (MonadThrow (throwM))
import Control.Monad.Except
@ -164,13 +186,15 @@ import Data.Char qualified
import Data.Coerce (Coercible, coerce)
import Data.Data (Proxy (Proxy))
import Data.Error
import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_)
import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, sequenceA_, traverse_)
import Data.Foldable qualified as Foldable
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Functor.Contravariant (Contravariant (contramap), (>$<))
import Data.Functor.Identity (Identity (runIdentity))
import Data.List (zip4)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict
( Map,
)
@ -178,7 +202,8 @@ import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Maybe qualified as Maybe
import Data.Profunctor (Profunctor, dimap, lmap, rmap)
import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat)
import Data.Scientific (Scientific)
import Data.Semigroup (sconcat)
import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1)
import Data.Semigroup.Traversable (Traversable1)
import Data.Semigroupoid (Semigroupoid (o))
@ -192,14 +217,17 @@ import Data.Text.Lazy qualified
import Data.Text.Lazy.Encoding qualified
import Data.These (These (That, These, This))
import Data.Traversable (for)
import Data.Vector (Vector)
import Data.Void (Void, absurd)
import Data.Word (Word8)
import GHC.Exception (errorCallWithCallStackException)
import GHC.Exts (RuntimeRep, TYPE, raise#)
import GHC.Exts (Any, RuntimeRep, TYPE, raise#)
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import GHC.Records (HasField)
import GHC.Stack (HasCallStack)
import GHC.Utils.Encoding qualified as GHC
import Language.Haskell.TH.Syntax (Lift)
import PyF (fmt)
import System.Exit qualified
import System.IO qualified
@ -212,6 +240,21 @@ import Validation
validationToEither,
)
-- | Mark a `do`-block with the type of the Monad/Applicativ it uses.
-- Only intended for reading ease and making code easier to understand,
-- especially do-blocks that use unconventional monads (like Maybe or List).
--
-- Example:
--
-- @
-- doAs @Maybe $ do
-- a <- Just 'a'
-- b <- Just 'b'
-- pure (a, b)
-- @
doAs :: forall m a. m a -> m a
doAs = id
-- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'.
(>&<) :: (Contravariant f) => f b -> (a -> b) -> f a
(>&<) = flip contramap
@ -222,10 +265,10 @@ infixl 5 >&<
--
-- Specialized examples:
--
-- @@
-- @
-- for functions : (a -> b) -> (b -> c) -> (a -> c)
-- for Folds: Fold a b -> Fold b c -> Fold a c
-- @@
-- @
(&>>) :: (Semigroupoid s) => s a b -> s b c -> s a c
(&>>) = flip Data.Semigroupoid.o
@ -266,26 +309,51 @@ bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.
bytesToTextUtf8LenientLazy =
Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
-- | Make a lazy text strict
-- | Make a lazy 'Text' strict.
toStrict :: Data.Text.Lazy.Text -> Text
toStrict = Data.Text.Lazy.toStrict
-- | Make a strict text lazy
-- | Make a strict 'Text' lazy.
toLazy :: Text -> Data.Text.Lazy.Text
toLazy = Data.Text.Lazy.fromStrict
-- | Make a lazy 'ByteString' strict.
toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString
toStrictBytes = Data.ByteString.Lazy.toStrict
-- | Make a strict 'ByteString' lazy.
toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString
toLazyBytes = Data.ByteString.Lazy.fromStrict
-- | Convert a (performant) 'Text' into an (imperformant) list-of-char 'String'.
--
-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We only want to convert to string at the edges, otherwise use 'Text'.
--
-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
textToString :: Text -> String
textToString = Data.Text.unpack
-- | Convert an (imperformant) list-of-char 'String' into a (performant) 'Text' .
--
-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We want to convert 'String' to 'Text' as soon as possible and only use 'Text' in our code.
--
-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
stringToText :: String -> Text
stringToText = Data.Text.pack
-- | Encode a String to an UTF-8 encoded Bytestring
--
-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
stringToBytesUtf8 :: String -> ByteString
stringToBytesUtf8 = GHC.utf8EncodeString
-- | Like `show`, but generate a 'Text'
--
-- ATTN: This goes via `String` and thus is fairly inefficient.
-- We should add a good display library at one point.
--
-- ATTN: unlike `show`, this forces the whole @'a
-- so only use if you want to display the whole thing.
showToText :: (Show a) => a -> Text
showToText = stringToText . show
@ -299,8 +367,20 @@ showToText = stringToText . show
-- >>> charToWordUnsafe ','
-- 44
charToWordUnsafe :: Char -> Word8
charToWordUnsafe = fromIntegral . Data.Char.ord
{-# INLINE charToWordUnsafe #-}
charToWordUnsafe = fromIntegral . Data.Char.ord
pattern IsEmpty :: [a]
pattern IsEmpty <- (null -> True)
where
IsEmpty = []
pattern IsNonEmpty :: NonEmpty a -> [a]
pattern IsNonEmpty n <- (nonEmpty -> Just n)
where
IsNonEmpty n = toList n
{-# COMPLETE IsEmpty, IsNonEmpty #-}
-- | Single element in a (non-empty) list.
singleton :: a -> NonEmpty a
@ -313,19 +393,69 @@ nonEmptyDef def xs =
Nothing -> def :| []
Just ne -> ne
-- | Construct a non-empty list, given a default value if the ist list was empty.
toNonEmptyDefault :: a -> [a] -> NonEmpty a
toNonEmptyDefault def xs = case xs of
[] -> def :| []
(x : xs') -> x :| xs'
-- | If the list is not empty, run the given function with a NonEmpty list, otherwise just return []
overNonEmpty :: (Applicative f) => (NonEmpty a -> f [b]) -> [a] -> f [b]
overNonEmpty f xs = case xs of
IsEmpty -> pure []
IsNonEmpty xs' -> f xs'
-- | @O(n)@. Get the maximum element from a non-empty structure.
-- | Zip two non-empty lists.
zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
{-# INLINE zipNonEmpty #-}
zipNonEmpty ~(a :| as) ~(b :| bs) = (a, b) :| zip as bs
-- | Zip two non-empty lists, combining them with the given function
zipWithNonEmpty :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
{-# INLINE zipWithNonEmpty #-}
zipWithNonEmpty = NonEmpty.zipWith
-- | Zip three non-empty lists.
zip3NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
{-# INLINE zip3NonEmpty #-}
zip3NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) = (a, b, c) :| zip3 as bs cs
-- | Zip three non-empty lists, combining them with the given function
zipWith3NonEmpty :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
{-# INLINE zipWith3NonEmpty #-}
zipWith3NonEmpty f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs
-- | Zip four non-empty lists
zip4NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
{-# INLINE zip4NonEmpty #-}
zip4NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) ~(d :| ds) = (a, b, c, d) :| zip4 as bs cs ds
-- | We don’t want to use Foldable’s `length`, because it is too polymorphic and can lead to bugs.
-- Only list-y things should have a length.
class (Foldable f) => Lengthy f
instance Lengthy []
instance Lengthy NonEmpty
instance Lengthy Vector
lengthNatural :: (Lengthy f) => f a -> Natural
lengthNatural xs =
xs
& Foldable.length
-- length can never be negative or something went really, really wrong
& fromIntegral @Int @Natural
-- | @O(n)@. Get the maximum element from a non-empty structure (strict).
maximum1 :: (Foldable1 f, Ord a) => f a -> a
maximum1 xs = xs & foldMap1 Max & getMax
maximum1 = Foldl1.fold1 Foldl1.maximum
-- | @O(n)@. Get the minimum element from a non-empty structure.
-- | @O(n)@. Get the maximum element from a non-empty structure, using the given comparator (strict).
maximumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a
maximumBy1 f = Foldl1.fold1 (Foldl1.maximumBy f)
-- | @O(n)@. Get the minimum element from a non-empty structure (strict).
minimum1 :: (Foldable1 f, Ord a) => f a -> a
minimum1 xs = xs & foldMap1 Min & getMin
minimum1 = Foldl1.fold1 Foldl1.minimum
-- | @O(n)@. Get the minimum element from a non-empty structure, using the given comparator (strict).
minimumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a
minimumBy1 f = Foldl1.fold1 (Foldl1.minimumBy f)
-- | Annotate a 'Maybe' with an error message and turn it into an 'Either'.
annotate :: err -> Maybe a -> Either err a
@ -355,8 +485,48 @@ findMaybe mPred list =
Just a -> mPred a
Nothing -> Nothing
-- | 'traverse' with a function returning 'Either' and collect all errors that happen, if they happen.
--
-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
--
-- This is a useful error handling function in many circumstances,
-- because it won’t only return the first error that happens, but rather all of them.
traverseValidate :: forall t a err b. (Traversable t) => (a -> Either err b) -> t a -> Either (NonEmpty err) (t b)
traverseValidate f as =
as
& traverse @t @(Validation _) (eitherToListValidation . f)
& validationToEither
-- | 'traverse' with a function returning 'm Either' and collect all errors that happen, if they happen.
--
-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
--
-- This is a useful error handling function in many circumstances,
-- because it won’t only return the first error that happens, but rather all of them.
traverseValidateM :: forall t m a err b. (Traversable t, Applicative m) => (a -> m (Either err b)) -> t a -> m (Either (NonEmpty err) (t b))
traverseValidateM f as =
as
& traverse @t @m (\a -> a & f <&> eitherToListValidation)
<&> sequenceA @t @(Validation _)
<&> validationToEither
-- | 'traverse_' with a function returning 'm Either' and collect all errors that happen, if they happen.
--
-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
--
-- This is a useful error handling function in many circumstances,
-- because it won’t only return the first error that happens, but rather all of them.
traverseValidateM_ :: forall t m a err. (Traversable t, Applicative m) => (a -> m (Either err ())) -> t a -> m (Either (NonEmpty err) ())
traverseValidateM_ f as =
as
& traverse @t @m (\a -> a & f <&> eitherToListValidation)
<&> sequenceA_ @t @(Validation _)
<&> validationToEither
-- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list
-- to make it combine with other validations.
--
-- See also 'validateEithers', if you have a list of Either and want to collect all errors.
eitherToListValidation :: Either a c -> Validation (NonEmpty a) c
eitherToListValidation = first singleton . eitherToValidation
@ -388,15 +558,26 @@ thenThese f x = do
th <- x
join <$> traverse f th
-- | Nested validating bind-like combinator inside some other @m@.
-- | Nested validating bind-like combinator.
--
-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'.
thenValidate ::
(a -> Validation err b) ->
Validation err a ->
Validation err b
thenValidate f = \case
Success a -> f a
Failure err -> Failure err
-- | Nested validating bind-like combinator inside some other @m@.
--
-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'.
thenValidateM ::
(Monad m) =>
(a -> m (Validation err b)) ->
m (Validation err a) ->
m (Validation err b)
thenValidate f x =
thenValidateM f x =
eitherToValidation <$> do
x' <- validationToEither <$> x
case x' of
@ -429,23 +610,23 @@ exitWithMessage msg = do
--
-- … since @(Semigroup err => Validation err a)@ is a @Semigroup@/@Monoid@ itself.
traverseFold :: (Applicative ap, Traversable t, Monoid m) => (a -> ap m) -> t a -> ap m
{-# INLINE traverseFold #-}
traverseFold f xs =
-- note: could be weakened to (Foldable t) via `getAp . foldMap (Ap . f)`
fold <$> traverse f xs
{-# INLINE traverseFold #-}
-- | Like 'traverseFold', but fold over a semigroup instead of a Monoid, by providing a starting element.
traverseFoldDefault :: (Applicative ap, Traversable t, Semigroup m) => m -> (a -> ap m) -> t a -> ap m
{-# INLINE traverseFoldDefault #-}
traverseFoldDefault def f xs = foldDef def <$> traverse f xs
where
foldDef = foldr (<>)
{-# INLINE traverseFoldDefault #-}
-- | Same as 'traverseFold', but with a 'Semigroup' and 'Traversable1' restriction.
traverseFold1 :: (Applicative ap, Traversable1 t, Semigroup s) => (a -> ap s) -> t a -> ap s
{-# INLINE traverseFold1 #-}
-- note: cannot be weakened to (Foldable1 t) because there is no `Ap` for Semigroup (No `Apply` typeclass)
traverseFold1 f xs = fold1 <$> traverse f xs
{-# INLINE traverseFold1 #-}
-- | Use this in places where the code is still to be implemented.
--
@ -527,18 +708,31 @@ inverseFunction f k = Map.lookup k $ inverseMap f
-- it returns a mapping from all possible outputs to their possible inputs.
--
-- This has the same restrictions of 'inverseFunction'.
inverseMap ::
forall a k.
(Bounded a, Enum a, Ord k) =>
(a -> k) ->
Map k a
inverseMap f =
universe
<&> (\a -> (f a, a))
& Map.fromList
where
universe :: [a]
universe = [minBound .. maxBound]
inverseMap :: forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
inverseMap f = enumerateAll <&> (\a -> (f a, a)) & Map.fromList
-- | All possible values in this enum.
enumerateAll :: (Enum a, Bounded a) => [a]
enumerateAll = [minBound .. maxBound]
-- | Create a 'Map' from a list of values, extracting the map key from each value. Like 'Map.fromList'.
--
-- Attention: if the key is not unique, the earliest value with the key will be in the map.
mapFromListOn :: (Ord key) => (a -> key) -> [a] -> Map key a
mapFromListOn f xs = xs <&> (\x -> (f x, x)) & Map.fromList
-- | Create a 'Map' from a list of values, merging multiple values at the same key with '<>' (left-to-right)
--
-- `f` has to extract the key and value. Value must be mergable.
--
-- Attention: if the key is not unique, the earliest value with the key will be in the map.
mapFromListOnMerge :: (Ord key, Semigroup s) => (a -> (key, s)) -> [a] -> Map key s
mapFromListOnMerge f xs =
xs
<&> (\x -> f x)
& Map.fromListWith
-- we have to flip (`<>`) because `Map.fromListWith` merges its values “the other way around”
(flip (<>))
-- | If the predicate is true, return the @m@, else 'mempty'.
--
@ -570,12 +764,18 @@ ifTrue pred' m = if pred' then m else mempty
-- >>> import Data.Monoid (Sum(..))
--
-- >>> :{ mconcat [
-- unknown command '{'
-- ifExists (Just [1]),
-- [2, 3, 4],
-- ifExists Nothing,
-- ]
-- :}
-- [1,2,3,4]
--
-- Or any other Monoid:
--
-- >>> mconcat [ Sum 1, ifExists Sum (Just 2), Sum 3 ]
-- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ]
-- Sum {getSum = 6}
ifExists :: (Monoid m) => (a -> m) -> Maybe a -> m
ifExists = foldMap
ifExists :: (Monoid m) => Maybe m -> m
ifExists = fold

311
users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
View file

@ -1,14 +1,15 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Postgres.MonadPostgres where
import AtLeast (AtLeast)
import Control.Exception
import Control.Foldl qualified as Fold
import Control.Monad.Except
import Control.Monad.Logger (MonadLogger, logDebug, logWarn)
import Control.Monad.Logger.CallStack (MonadLogger, logDebug, logWarn)
import Control.Monad.Reader (MonadReader (ask), ReaderT (..))
import Control.Monad.Trans.Resource
import Data.Aeson (FromJSON)
@ -28,7 +29,7 @@ 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 (Query (..))
import GHC.Records (HasField (..))
import GHC.Records (getField)
import Label
import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
import OpenTelemetry.Trace.Monad qualified as Otel
@ -42,7 +43,7 @@ import Tool
import UnliftIO (MonadUnliftIO (withRunInIO))
import UnliftIO.Process qualified as Process
import UnliftIO.Resource qualified as Resource
import Prelude hiding (span)
import Prelude hiding (init, span)
-- | Postgres queries/commands that can be executed within a running transaction.
--
@ -52,28 +53,46 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
-- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results.
-- Returns the number of rows affected.
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 take parameters.
-- Returns the number of rows affected.
execute_ :: Query -> Transaction m (Label "numberOfRowsAffected" Natural)
execute ::
(ToRow params, Typeable params) =>
Query ->
params ->
Transaction m (Label "numberOfRowsAffected" Natural)
-- | 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.
executeMany :: (ToRow params, Typeable params) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural)
-- 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.
executeMany ::
(ToRow params, Typeable params) =>
Query ->
NonEmpty params ->
Transaction m (Label "numberOfRowsAffected" Natural)
-- | 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.
executeManyReturningWith :: (ToRow q) => Query -> [q] -> Decoder r -> Transaction m [r]
executeManyReturningWith :: (ToRow q) => Query -> NonEmpty q -> Decoder r -> Transaction m [r]
-- | 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]
-- | Run a query without any parameters and result row parser.
queryWith_ :: (Typeable r) => PG.Query -> Decoder r -> Transaction m [r]
queryWith_ ::
(Typeable r) =>
PG.Query ->
Decoder r ->
Transaction m [r]
-- | Run a query, passing parameters, and fold over the resulting rows.
--
@ -82,13 +101,15 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
--
-- When dealing with small results, it may be simpler (and perhaps faster) to use query instead.
--
-- This fold is _not_ strict. The stream consumer is responsible for forcing the evaluation of its result to avoid space leaks.
-- This fold is _not_ strict. The stream consumer is responsible
-- for forcing the evaluation of its result to avoid space leaks.
--
-- If you can, prefer aggregating in the database itself.
foldRows ::
(FromRow row, ToRow params, Typeable row, Typeable params) =>
foldRowsWithAcc ::
(ToRow params, Typeable row, Typeable params) =>
Query ->
params ->
Decoder row ->
a ->
(a -> row -> Transaction m a) ->
Transaction m a
@ -109,12 +130,23 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
-- Only handlers should run transactions.
runTransaction :: Transaction m a -> m a
-- | Run a query, passing parameters.
query :: forall m params r. (PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) => PG.Query -> params -> Transaction m [r]
-- | Run a query, passing parameters. Prefer 'queryWith' if possible.
query ::
forall m params r.
(PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) =>
PG.Query ->
params ->
Transaction m [r]
query qry params = queryWith qry params (Decoder PG.fromRow)
-- | Run a query without any parameters.
query_ :: forall m r. (Typeable r, PG.FromRow r, MonadPostgres m) => PG.Query -> Transaction m [r]
-- | Run a query without any parameters. Prefer 'queryWith' if possible.
--
-- TODO: I think(?) this can always be replaced by passing @()@ to 'query', remove?
query_ ::
forall m r.
(Typeable r, PG.FromRow r, MonadPostgres m) =>
PG.Query ->
Transaction m [r]
query_ qry = queryWith_ qry (Decoder PG.fromRow)
-- TODO: implement via fold, so that the result doesn’t have to be realized in memory
@ -153,7 +185,10 @@ querySingleRowMaybe qry params = do
-- that a database function can error out, should probably handled by the instances.
more -> throwM $ SingleRowError {numberOfRowsReturned = (List.length more)}
ensureSingleRow :: (MonadThrow m) => [a] -> m a
ensureSingleRow ::
(MonadThrow m) =>
[a] ->
m a
ensureSingleRow = \case
-- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres
-- that a database function can error out, should probably handled by the instances.
@ -167,6 +202,52 @@ ensureSingleRow = \case
List.length more
}
ensureNoneOrSingleRow ::
(MonadThrow m) =>
[a] ->
m (Maybe a)
ensureNoneOrSingleRow = \case
-- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres
-- that a database function can error out, should probably handled by the instances.
[] -> pure Nothing
[one] -> pure $ Just one
more ->
throwM $
SingleRowError
{ numberOfRowsReturned =
-- TODO: this is VERY bad, because it requires to parse the full database output, even if there’s 10000000000 elements
List.length more
}
-- | Run a query, passing parameters, and fold over the resulting rows.
--
-- This doesn’t have to realize the full list of results in memory,
-- rather results are streamed incrementally from the database.
--
-- When dealing with small results, it may be simpler (and perhaps faster) to use query instead.
--
-- The results are folded strictly by the 'Fold.Fold' that is passed.
--
-- If you can, prefer aggregating in the database itself.
foldRowsWith ::
forall row params m b.
( MonadPostgres m,
PG.ToRow params,
Typeable row,
Typeable params
) =>
PG.Query ->
params ->
Decoder row ->
Fold.Fold row b ->
Transaction m b
foldRowsWith qry params decoder = Fold.purely f
where
f :: forall x. (x -> row -> x) -> x -> (x -> b) -> Transaction m b
f acc init extract = do
x <- foldRowsWithAcc qry params decoder init (\a r -> pure $ acc a r)
pure $ extract x
newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)}
deriving newtype
( Functor,
@ -180,9 +261,6 @@ newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)
Otel.MonadTracer
)
runTransaction' :: Connection -> Transaction m a -> m a
runTransaction' conn transaction = runReaderT transaction.unTransaction conn
-- | [Resource Pool](http://hackage.haskell.org/package/resource-pool-0.2.3.2/docs/Data-Pool.html) configuration.
data PoolingInfo = PoolingInfo
{ -- | Minimal amount of resources that are
@ -237,17 +315,41 @@ initMonadPostgres logInfoFn connectInfo poolingInfo = do
IO ()
destroyPGConnPool p = Pool.destroyAllResources p
-- | Improve a possible error message, by adding some context to it.
--
-- The given Exception type is caught, 'show'n and pretty-printed.
--
-- In case we get an `IOError`, we display it in a reasonable fashion.
addErrorInformation ::
forall exc a.
(Exception exc) =>
Text.Text ->
IO a ->
IO a
addErrorInformation msg io =
io
& try @exc
<&> first (showPretty >>> newError >>> errorContext msg)
& try @IOError
<&> first (showToError >>> errorContext "IOError" >>> errorContext msg)
<&> join @(Either Error)
>>= unwrapIOError
-- | Catch any Postgres exception that gets thrown,
-- print the query that was run and the query parameters,
-- then rethrow inside an 'Error'.
handlePGException ::
forall a params tools m.
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
( ToRow params,
MonadUnliftIO m,
MonadLogger m,
HasField "pgFormat" tools Tool
) =>
tools ->
Text ->
Query ->
-- | Depending on whether we used `format` or `formatMany`.
Either params [params] ->
Either params (NonEmpty params) ->
IO a ->
Transaction m a
handlePGException tools queryType query' params io = do
@ -289,7 +391,11 @@ withPGTransaction connPool f =
connPool
(\conn -> Postgres.withTransaction conn (f conn))
runPGTransactionImpl :: (MonadUnliftIO m) => m (Pool Postgres.Connection) -> Transaction m a -> m a
runPGTransactionImpl ::
(MonadUnliftIO m) =>
m (Pool Postgres.Connection) ->
Transaction m a ->
m a
{-# INLINE runPGTransactionImpl #-}
runPGTransactionImpl zoom (Transaction transaction) = do
pool <- zoom
@ -337,7 +443,7 @@ executeManyImpl ::
m tools ->
m DebugLogDatabaseQueries ->
Query ->
[params] ->
NonEmpty params ->
Transaction m (Label "numberOfRowsAffected" Natural)
executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
@ -345,7 +451,7 @@ executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
conn <- Transaction ask
PG.executeMany conn qry params
PG.executeMany conn qry (params & toList)
& handlePGException tools "executeMany" qry (Right params)
>>= toNumberOfRowsAffected "executeManyImpl"
@ -364,7 +470,7 @@ executeManyReturningWithImpl ::
m tools ->
m DebugLogDatabaseQueries ->
Query ->
[params] ->
NonEmpty params ->
Decoder r ->
Transaction m [r]
{-# INLINE executeManyReturningWithImpl #-}
@ -374,33 +480,45 @@ executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (D
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
conn <- Transaction ask
PG.returningWith fromRow conn qry params
PG.returningWith fromRow conn qry (params & toList)
& handlePGException tools "executeManyReturning" qry (Right params)
foldRowsImpl ::
(FromRow row, ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
foldRowsWithAccImpl ::
( ToRow params,
MonadUnliftIO m,
MonadLogger m,
HasField "pgFormat" tools Tool,
Otel.MonadTracer m
) =>
m tools ->
m DebugLogDatabaseQueries ->
Query ->
params ->
Decoder row ->
a ->
(a -> row -> Transaction m a) ->
Transaction m a
{-# INLINE foldRowsImpl #-}
foldRowsImpl zoomTools qry params accumulator f = do
conn <- Transaction ask
tools <- lift @Transaction zoomTools
withRunInIO
( \runInIO ->
do
PG.fold
conn
qry
params
accumulator
(\acc row -> runInIO $ f acc row)
& handlePGException tools "fold" qry (Left params)
& runInIO
)
{-# INLINE foldRowsWithAccImpl #-}
foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder rowParser) accumulator f = do
Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do
tools <- lift @Transaction zoomTools
logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
conn <- Transaction ask
withRunInIO
( \runInIO ->
do
PG.foldWithOptionsAndParser
PG.defaultFoldOptions
rowParser
conn
qry
params
accumulator
(\acc row -> runInIO $ f acc row)
& handlePGException tools "fold" qry (Left params)
& runInIO
)
pgFormatQueryNoParams' ::
(MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
@ -410,18 +528,38 @@ pgFormatQueryNoParams' ::
pgFormatQueryNoParams' tools q =
lift $ pgFormatQueryByteString tools q.fromQuery
pgFormatQuery :: (ToRow params, MonadIO m) => Query -> params -> Transaction m ByteString
pgFormatQuery ::
(ToRow params, MonadIO m) =>
Query ->
params ->
Transaction m ByteString
pgFormatQuery qry params = Transaction $ do
conn <- ask
liftIO $ PG.formatQuery conn qry params
pgFormatQueryMany :: (MonadIO m, ToRow params) => Query -> [params] -> Transaction m ByteString
pgFormatQueryMany ::
(MonadIO m, ToRow params) =>
Query ->
NonEmpty params ->
Transaction m ByteString
pgFormatQueryMany qry params = Transaction $ do
conn <- ask
liftIO $ PG.formatMany conn qry params
liftIO $
PG.formatMany
conn
qry
( params
-- upstream is partial on empty list, see https://github.com/haskellari/postgresql-simple/issues/129
& toList
)
queryWithImpl ::
(ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) =>
( ToRow params,
MonadUnliftIO m,
MonadLogger m,
HasField "pgFormat" tools Tool,
Otel.MonadTracer m
) =>
m tools ->
m DebugLogDatabaseQueries ->
Query ->
@ -438,7 +576,15 @@ queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow)
PG.queryWith fromRow conn qry params
& handlePGException tools "query" qry (Left params)
queryWithImpl_ :: (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => m tools -> Query -> Decoder r -> Transaction m [r]
queryWithImpl_ ::
( MonadUnliftIO m,
MonadLogger m,
HasField "pgFormat" tools Tool
) =>
m tools ->
Query ->
Decoder r ->
Transaction m [r]
{-# INLINE queryWithImpl_ #-}
queryWithImpl_ zoomTools qry (Decoder fromRow) = do
tools <- lift @Transaction zoomTools
@ -446,18 +592,6 @@ queryWithImpl_ zoomTools qry (Decoder fromRow) = do
liftIO (PG.queryWith_ fromRow conn qry)
& handlePGException tools "query" qry (Left ())
pgQuery :: (ToRow params, FromRow r, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> params -> Transaction m [r]
pgQuery tools qry params = do
conn <- Transaction ask
PG.query conn qry params
& handlePGException tools "query" qry (Left params)
pgQuery_ :: (FromRow r, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> Transaction m [r]
pgQuery_ tools qry = do
conn <- Transaction ask
PG.query_ conn qry
& handlePGException tools "query_" qry (Left ())
data SingleRowError = SingleRowError
{ -- | How many columns were actually returned by the query
numberOfRowsReturned :: Int
@ -467,12 +601,30 @@ data SingleRowError = SingleRowError
instance Exception SingleRowError where
displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|]
pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> params -> Transaction m Text
pgFormatQuery' ::
( MonadIO m,
ToRow params,
MonadLogger m,
HasField "pgFormat" tools Tool
) =>
tools ->
Query ->
params ->
Transaction m Text
pgFormatQuery' tools q p =
pgFormatQuery q p
>>= lift . pgFormatQueryByteString tools
pgFormatQueryMany' :: (MonadIO m, ToRow params, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> [params] -> Transaction m Text
pgFormatQueryMany' ::
( MonadIO m,
ToRow params,
MonadLogger m,
HasField "pgFormat" tools Tool
) =>
tools ->
Query ->
NonEmpty params ->
Transaction m Text
pgFormatQueryMany' tools q p =
pgFormatQueryMany q p
>>= lift . pgFormatQueryByteString tools
@ -481,7 +633,14 @@ pgFormatQueryMany' tools q p =
postgresToolsParser :: ToolParserT IO (Label "pgFormat" Tool)
postgresToolsParser = label @"pgFormat" <$> readTool "pg_format"
pgFormatQueryByteString :: (MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> ByteString -> m Text
pgFormatQueryByteString ::
( MonadIO m,
MonadLogger m,
HasField "pgFormat" tools Tool
) =>
tools ->
ByteString ->
m Text
pgFormatQueryByteString tools queryBytes = do
do
(exitCode, stdout, stderr) <-
@ -492,8 +651,8 @@ pgFormatQueryByteString tools queryBytes = do
case exitCode of
ExitSuccess -> pure (stdout & stringToText)
ExitFailure status -> do
$logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
$logDebug
logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
logDebug
( prettyErrorTree
( nestedMultiError
"pg_format output"
@ -502,7 +661,7 @@ pgFormatQueryByteString tools queryBytes = do
)
)
)
$logDebug [fmt|pg_format stdout: stderr|]
logDebug [fmt|pg_format stdout: stderr|]
pure (queryBytes & bytesToTextUtf8Lenient)
data DebugLogDatabaseQueries
@ -517,7 +676,7 @@ data DebugLogDatabaseQueries
data HasQueryParams param
= HasNoParams
| HasSingleParam param
| HasMultiParams [param]
| HasMultiParams (NonEmpty param)
-- | Log the postgres query depending on the given setting
traceQueryIfEnabled ::

4
users/Profpatsch/whatcd-resolver/src/AppT.hs
View file

@ -119,12 +119,12 @@ recordException span dat = liftIO $ do
instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
execute_ = executeImpl_ (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
queryWith_ = queryWithImpl_ (AppT ask)
foldRows = foldRowsImpl (AppT ask)
foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
runTransaction = runPGTransaction
runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a

47
users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
View file

@ -35,6 +35,7 @@ import Json.Enc (Enc)
import Json.Enc qualified as Enc
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
@ -50,7 +51,6 @@ import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
import OpenTelemetry.Trace.Monad qualified as Otel
import Parse (Parse)
import Parse qualified
import PossehlAnalyticsPrelude
import Postgres.Decoder qualified as Dec
import Postgres.MonadPostgres
import Pretty
@ -848,7 +848,9 @@ redactedSearchAndInsert extraArguments = do
pure $
(firstPage : otherPages)
& concatMap (.tourGroups)
& insertTourGroupsAndTorrents
& \case
IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents
IsEmpty -> pure ()
where
go mpage =
redactedSearch
@ -893,12 +895,13 @@ redactedSearchAndInsert extraArguments = do
)
)
insertTourGroupsAndTorrents ::
[ T2
"tourGroup"
(T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value)
"torrents"
[T2 "torrentId" Int "fullJsonResult" Json.Value]
] ->
NonEmpty
( T2
"tourGroup"
(T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value)
"torrents"
[T2 "torrentId" Int "fullJsonResult" Json.Value]
) ->
Transaction m ()
insertTourGroupsAndTorrents dat = do
let tourGroups = dat <&> (.tourGroup)
@ -909,23 +912,22 @@ redactedSearchAndInsert extraArguments = do
zipT2 $
T2
(label @"torrentGroupIdPg" $ res <&> (.tourGroupIdPg))
(label @"torrents" torrents)
(label @"torrents" (torrents & toList))
)
insertTourGroups ::
[ T3
"groupId"
Int
"groupName"
Text
"fullJsonResult"
Json.Value
] ->
NonEmpty
( T3
"groupId"
Int
"groupName"
Text
"fullJsonResult"
Json.Value
) ->
Transaction m [Label "tourGroupIdPg" Int]
insertTourGroups dats = do
let groupNames =
[ [fmt|{dat.groupId}: {dat.groupName}|]
| dat <- dats
]
dats <&> \dat -> [fmt|{dat.groupId}: {dat.groupName}|]
logInfo [fmt|Inserting tour groups for {showPretty groupNames}|]
_ <-
execute
@ -933,7 +935,7 @@ redactedSearchAndInsert extraArguments = do
DELETE FROM redacted.torrent_groups
WHERE group_id = ANY (?::integer[])
|]
(Only $ (dats <&> (.groupId) & PGArray :: PGArray Int))
(Only $ (dats <&> (.groupId) & toList & PGArray :: PGArray Int))
executeManyReturningWith
[fmt|
INSERT INTO redacted.torrent_groups (
@ -1082,7 +1084,7 @@ migrate ::
) =>
Transaction m (Label "numberOfRowsAffected" Natural)
migrate = inSpan "Database Migration" $ do
execute_
execute
[sql|
CREATE SCHEMA IF NOT EXISTS redacted;
@ -1134,6 +1136,7 @@ migrate = inSpan "Database Migration" $ do
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));
|]
()
data TorrentData transmissionInfo = TorrentData
{ groupId :: Int,