33fa42a1a3
Improvements from “upstream”, fresh served. Change-Id: I60e02835730f6a65739eaa729f3e3eed1a0693e6 Reviewed-on: https://cl.tvl.fyi/c/depot/+/9025 Autosubmit: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
94 lines
3.7 KiB
Haskell
94 lines
3.7 KiB
Haskell
module Postgres.Decoder where
|
|
|
|
import Control.Applicative (Alternative)
|
|
import Data.Aeson qualified as Json
|
|
import Data.Aeson.BetterErrors qualified as Json
|
|
import Data.Error.Tree
|
|
import Data.Typeable (Typeable)
|
|
import Database.PostgreSQL.Simple (Binary (fromBinary))
|
|
import Database.PostgreSQL.Simple.FromField qualified as PG
|
|
import Database.PostgreSQL.Simple.FromRow qualified as PG
|
|
import Json qualified
|
|
import Label
|
|
import PossehlAnalyticsPrelude
|
|
|
|
-- | A Decoder of postgres values. Allows embedding more complex parsers (like a 'Json.ParseT').
|
|
newtype Decoder a = Decoder (PG.RowParser a)
|
|
deriving newtype (Functor, Applicative, Alternative, Monad)
|
|
|
|
-- | Parse a `bytea` field, equivalent to @Binary ByteString@ but avoids the pitfall of having to use 'Binary'.
|
|
bytea :: Decoder ByteString
|
|
bytea = fromField @(Binary ByteString) <&> (.fromBinary)
|
|
|
|
-- | Parse a nullable `bytea` field, equivalent to @Binary ByteString@ but avoids the pitfall of having to use 'Binary'.
|
|
byteaMay :: Decoder (Maybe ByteString)
|
|
byteaMay = fromField @(Maybe (Binary ByteString)) <&> fmap (.fromBinary)
|
|
|
|
-- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions:
|
|
--
|
|
-- @
|
|
-- fromField @Text :: Decoder Text
|
|
-- @
|
|
fromField :: PG.FromField a => Decoder a
|
|
fromField = Decoder $ PG.fieldWith PG.fromField
|
|
|
|
-- | Turn any type that implements 'PG.fromField' into a 'Decoder' and wrap the result into the given 'Label'. Use type applications to prevent accidental conversions:
|
|
--
|
|
-- @
|
|
-- fromField @"myField" @Text :: Decoder (Label "myField" Text)
|
|
-- @
|
|
fromFieldLabel :: forall lbl a. PG.FromField a => Decoder (Label lbl a)
|
|
fromFieldLabel = label @lbl <$> fromField
|
|
|
|
-- | Parse fields out of a json value returned from the database.
|
|
--
|
|
-- ATTN: The whole json record has to be transferred before it is parsed,
|
|
-- so if you only need a tiny bit of it, use `->` and `->>` in your SQL statement
|
|
-- and return only the fields you need from the query.
|
|
--
|
|
-- In that case pay attention to NULL though:
|
|
--
|
|
-- @
|
|
-- SELECT '{"foo": {}}'::jsonb->>'foo' IS NULL
|
|
-- → TRUE
|
|
-- @
|
|
--
|
|
-- Also note: `->>` will coerce the json value to @text@, regardless of the content.
|
|
-- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@.
|
|
json :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder a
|
|
json parser = Decoder $ PG.fieldWith $ \field bytes -> do
|
|
val <- PG.fromField @Json.Value field bytes
|
|
case Json.parseValue parser val of
|
|
Left err ->
|
|
PG.returnError
|
|
PG.ConversionFailed
|
|
field
|
|
(err & Json.parseErrorTree "Cannot decode jsonb column" & prettyErrorTree & textToString)
|
|
Right a -> pure a
|
|
|
|
-- | Parse fields out of a nullable json value returned from the database.
|
|
--
|
|
-- ATTN: The whole json record has to be transferred before it is parsed,
|
|
-- so if you only need a tiny bit of it, use `->` and `->>` in your SQL statement
|
|
-- and return only the fields you need from the query.
|
|
--
|
|
-- In that case pay attention to NULL though:
|
|
--
|
|
-- @
|
|
-- SELECT '{"foo": {}}'::jsonb->>'foo' IS NULL
|
|
-- → TRUE
|
|
-- @
|
|
--
|
|
-- Also note: `->>` will coerce the json value to @text@, regardless of the content.
|
|
-- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@.
|
|
jsonMay :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a)
|
|
jsonMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
|
|
val <- PG.fromField @(Maybe Json.Value) field bytes
|
|
case Json.parseValue parser <$> val of
|
|
Nothing -> pure Nothing
|
|
Just (Left err) ->
|
|
PG.returnError
|
|
PG.ConversionFailed
|
|
field
|
|
(err & Json.parseErrorTree "Cannot decode jsonb column" & prettyErrorTree & textToString)
|
|
Just (Right a) -> pure (Just a)
|