generated from tpl/purs
fix: copy from scraper
This commit is contained in:
parent
32c6cdc4a2
commit
69a3a80411
GPG Key ID:
6D4165AE4C928719
181
spago.yaml
181
spago.yaml
@ -1,21 +1,194 @@
|
||||
package:
|
||||
dependencies:
|
||||
- prelude
|
||||
- aff
|
||||
- console
|
||||
- effect
|
||||
- either
|
||||
- maybe
|
||||
- foldable-traversable
|
||||
- console
|
||||
- foreign
|
||||
- fork
|
||||
- maybe
|
||||
- mmorph
|
||||
- newtype
|
||||
- postgresql-client
|
||||
- prelude
|
||||
- strings
|
||||
- stringutils
|
||||
- transformers
|
||||
- tuples
|
||||
- typelevel-prelude
|
||||
- unlift
|
||||
name: project
|
||||
workspace:
|
||||
extra_packages: {}
|
||||
extra_packages:
|
||||
postgresql-client:
|
||||
dependencies:
|
||||
- aff
|
||||
- argonaut
|
||||
- arrays
|
||||
- assert
|
||||
- bifunctors
|
||||
- bytestrings
|
||||
- datetime
|
||||
- debug
|
||||
- decimals
|
||||
- dotenv
|
||||
- effect
|
||||
- either
|
||||
- enums
|
||||
- exceptions
|
||||
- foldable-traversable
|
||||
- foreign
|
||||
- foreign-generic
|
||||
- foreign-object
|
||||
- identity
|
||||
- integers
|
||||
- js-date
|
||||
- js-unsafe-stringify
|
||||
- lists
|
||||
- maybe
|
||||
- newtype
|
||||
- node-process
|
||||
- nullable
|
||||
- numbers
|
||||
- ordered-collections
|
||||
- partial
|
||||
- polyform
|
||||
- polyform-batteries-core
|
||||
- polyform-batteries-env
|
||||
- prelude
|
||||
- profunctor
|
||||
- psci-support
|
||||
- record
|
||||
- string-parsers
|
||||
- strings
|
||||
- test-unit
|
||||
- transformers
|
||||
- tuples
|
||||
- typelevel-prelude
|
||||
- unsafe-coerce
|
||||
- validation
|
||||
git: https://github.com/rightfold/purescript-postgresql-client.git
|
||||
ref: main
|
||||
quotient:
|
||||
dependencies: [ "prelude", "quickcheck" ]
|
||||
git: "https://github.com/rightfold/purescript-quotient.git"
|
||||
ref: "v3.0.0"
|
||||
bytestrings:
|
||||
dependencies:
|
||||
[
|
||||
"arrays",
|
||||
"console",
|
||||
"effect",
|
||||
"exceptions",
|
||||
"foldable-traversable",
|
||||
"integers",
|
||||
"leibniz",
|
||||
"maybe",
|
||||
"newtype",
|
||||
"node-buffer",
|
||||
"partial",
|
||||
"prelude",
|
||||
"quickcheck",
|
||||
"quickcheck-laws",
|
||||
"quotient",
|
||||
"unsafe-coerce"
|
||||
]
|
||||
git: "https://github.com/martyall/purescript-bytestrings.git"
|
||||
ref: "e51cf868a4137c1c48c98d32115bb2014c9f7624"
|
||||
foreign-generic:
|
||||
dependencies:
|
||||
[
|
||||
"arrays",
|
||||
"assert",
|
||||
"bifunctors",
|
||||
"console",
|
||||
"control",
|
||||
"effect",
|
||||
"either",
|
||||
"exceptions",
|
||||
"foldable-traversable",
|
||||
"foreign",
|
||||
"foreign-object",
|
||||
"identity",
|
||||
"lists",
|
||||
"maybe",
|
||||
"newtype",
|
||||
"partial",
|
||||
"prelude",
|
||||
"record",
|
||||
"strings",
|
||||
"transformers",
|
||||
"tuples",
|
||||
"unsafe-coerce"
|
||||
]
|
||||
git: "https://github.com/paluh/purescript-foreign-generic.git"
|
||||
ref: "a5c23d29e72619624978446293ac9bb45ccd2fde"
|
||||
js-unsafe-stringify:
|
||||
dependencies: []
|
||||
git: "https://github.com/paluh/purescript-js-unsafe-stringify.git"
|
||||
ref: "master"
|
||||
polyform:
|
||||
dependencies:
|
||||
[
|
||||
"heterogeneous",
|
||||
"js-unsafe-stringify",
|
||||
"newtype",
|
||||
"ordered-collections",
|
||||
"variant",
|
||||
"profunctor",
|
||||
"invariant",
|
||||
"foreign-object",
|
||||
"run",
|
||||
"transformers",
|
||||
"validation",
|
||||
"foreign"
|
||||
]
|
||||
git: "https://github.com/purescript-polyform/polyform.git"
|
||||
ref: "v0.9.2"
|
||||
polyform-batteries-core:
|
||||
dependencies:
|
||||
[
|
||||
"debug",
|
||||
"decimals",
|
||||
"filterable",
|
||||
"numbers",
|
||||
"polyform",
|
||||
"prelude",
|
||||
"record-extra",
|
||||
"test-unit"
|
||||
]
|
||||
git: "https://github.com/purescript-polyform/batteries-core.git"
|
||||
ref: "v0.3.0"
|
||||
polyform-batteries-urlencoded:
|
||||
dependencies:
|
||||
[
|
||||
"argonaut",
|
||||
"console",
|
||||
"debug",
|
||||
"effect",
|
||||
"form-urlencoded",
|
||||
"polyform-batteries-core",
|
||||
"psci-support",
|
||||
"spec"
|
||||
]
|
||||
git: "https://github.com/purescript-polyform/batteries-urlencoded.git"
|
||||
ref: "v0.4.1"
|
||||
polyform-batteries-env:
|
||||
dependencies:
|
||||
[
|
||||
"arrays",
|
||||
"identity",
|
||||
"maybe",
|
||||
"ordered-collections",
|
||||
"polyform",
|
||||
"polyform-batteries-core",
|
||||
"prelude",
|
||||
"psci-support",
|
||||
"typelevel-prelude"
|
||||
]
|
||||
git: "https://github.com/purescript-polyform/batteries-env.git"
|
||||
ref: "v0.2.0"
|
||||
package_set:
|
||||
url: https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.10-20230930/packages.json
|
||||
hash: sha256-nTsd44o7/hrTdk0c6dh0wyBqhFFDJJIeKdQU6L1zv/A=
|
||||
|
||||
206
src/Control.Monad.Postgres.purs
Normal file
206
src/Control.Monad.Postgres.purs
Normal file
@ -0,0 +1,206 @@
|
||||
module Control.Monad.Postgres where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Alternative (class Alt, class Alternative, class Plus)
|
||||
import Control.Monad.Cont (class MonadCont)
|
||||
import Control.Monad.Error.Class (class MonadError, class MonadThrow, liftEither, throwError)
|
||||
import Control.Monad.Fork.Class
|
||||
( class MonadBracket
|
||||
, class MonadFork
|
||||
, class MonadKill
|
||||
, bracket
|
||||
, kill
|
||||
, never
|
||||
, uninterruptible
|
||||
)
|
||||
import Control.Monad.Morph (class MFunctor, class MMonad, embed, hoist)
|
||||
import Control.Monad.Reader (class MonadAsk, class MonadReader, ReaderT, ask)
|
||||
import Control.Monad.Rec.Class (class MonadRec)
|
||||
import Control.Monad.Trans.Class (class MonadTrans, lift)
|
||||
import Control.Monad.Writer (class MonadTell, class MonadWriter)
|
||||
import Control.MonadPlus (class MonadPlus)
|
||||
import Control.Parallel (class Parallel, parallel, sequential)
|
||||
import Data.Bifunctor (lmap)
|
||||
import Data.Either (Either(..))
|
||||
import Data.Maybe (maybe)
|
||||
import Data.Newtype (class Newtype, unwrap, wrap)
|
||||
import Database.PostgreSQL as Pg
|
||||
import Database.PostgreSQL.Aff as Pg.Aff
|
||||
import Effect.Aff.Class (class MonadAff, liftAff)
|
||||
import Effect.Aff.Unlift (class MonadUnliftAff, UnliftAff(..), withUnliftAff)
|
||||
import Effect.Class (class MonadEffect)
|
||||
import Effect.Exception (Error, error)
|
||||
import Foreign (Foreign)
|
||||
|
||||
newtype HasPostgresT :: (Type -> Type) -> Type -> Type
|
||||
newtype HasPostgresT m a = HasPostgresT (ReaderT Pg.Connection m a)
|
||||
|
||||
derive instance Newtype (HasPostgresT m a) _
|
||||
derive newtype instance Functor m => Functor (HasPostgresT m)
|
||||
derive newtype instance (Plus m) => Plus (HasPostgresT m)
|
||||
derive newtype instance (Plus m, Alternative m) => Alternative (HasPostgresT m)
|
||||
derive newtype instance Alt m => Alt (HasPostgresT m)
|
||||
derive newtype instance Apply m => Apply (HasPostgresT m)
|
||||
derive newtype instance Applicative m => Applicative (HasPostgresT m)
|
||||
derive newtype instance Bind m => Bind (HasPostgresT m)
|
||||
derive newtype instance Monad m => Monad (HasPostgresT m)
|
||||
derive newtype instance MonadError e m => MonadError e (HasPostgresT m)
|
||||
derive newtype instance MonadThrow e m => MonadThrow e (HasPostgresT m)
|
||||
derive newtype instance (Apply m, Semigroup a) => Semigroup (HasPostgresT m a)
|
||||
derive newtype instance (Applicative m, Monoid a) => Monoid (HasPostgresT m a)
|
||||
derive newtype instance (MonadPlus m) => MonadPlus (HasPostgresT m)
|
||||
derive newtype instance (MonadEffect m) => MonadEffect (HasPostgresT m)
|
||||
derive newtype instance (MonadAff m) => MonadAff (HasPostgresT m)
|
||||
derive newtype instance Monad m => MonadReader Pg.Connection (HasPostgresT m)
|
||||
derive newtype instance Monad m => MonadAsk Pg.Connection (HasPostgresT m)
|
||||
derive newtype instance MonadCont m => MonadCont (HasPostgresT m)
|
||||
derive newtype instance MonadTell w m => MonadTell w (HasPostgresT m)
|
||||
derive newtype instance MonadWriter w m => MonadWriter w (HasPostgresT m)
|
||||
derive newtype instance MonadRec m => MonadRec (HasPostgresT m)
|
||||
derive newtype instance MonadFork f m => MonadFork f (HasPostgresT m)
|
||||
derive newtype instance MonadUnliftAff m => MonadUnliftAff (HasPostgresT m)
|
||||
instance (Parallel f m) => Parallel (HasPostgresT f) (HasPostgresT m) where
|
||||
parallel = wrap <<< parallel <<< unwrap
|
||||
sequential = wrap <<< sequential <<< unwrap
|
||||
|
||||
instance MonadTrans HasPostgresT where
|
||||
lift = wrap <<< lift
|
||||
|
||||
instance MFunctor HasPostgresT where
|
||||
hoist f = wrap <<< hoist f <<< unwrap
|
||||
|
||||
instance MMonad HasPostgresT where
|
||||
embed f = wrap <<< embed (unwrap <<< f) <<< unwrap
|
||||
|
||||
instance MonadKill e f m => MonadKill e f (HasPostgresT m) where
|
||||
kill e f = wrap $ kill e f
|
||||
|
||||
instance (MonadKill e f (HasPostgresT m), MonadError e (HasPostgresT m), MonadKill e f m, MonadError e m, MonadBracket e f m) => MonadBracket e f (HasPostgresT m) where
|
||||
bracket acq rel m = wrap $ bracket (unwrap acq) (\b r -> unwrap $ rel b r) (unwrap <<< m)
|
||||
uninterruptible = wrap <<< uninterruptible <<< unwrap
|
||||
never = wrap $ never
|
||||
|
||||
newtype PostgresT :: (Type -> Type) -> Type -> Type
|
||||
newtype PostgresT m a = PostgresT (ReaderT Pg.Connection m a)
|
||||
|
||||
derive instance Newtype (PostgresT m a) _
|
||||
derive newtype instance Functor m => Functor (PostgresT m)
|
||||
derive newtype instance (Plus m) => Plus (PostgresT m)
|
||||
derive newtype instance (Plus m, Alternative m) => Alternative (PostgresT m)
|
||||
derive newtype instance Alt m => Alt (PostgresT m)
|
||||
derive newtype instance Apply m => Apply (PostgresT m)
|
||||
derive newtype instance Applicative m => Applicative (PostgresT m)
|
||||
derive newtype instance Bind m => Bind (PostgresT m)
|
||||
derive newtype instance Monad m => Monad (PostgresT m)
|
||||
derive newtype instance MonadError e m => MonadError e (PostgresT m)
|
||||
derive newtype instance MonadThrow e m => MonadThrow e (PostgresT m)
|
||||
derive newtype instance (Apply m, Semigroup a) => Semigroup (PostgresT m a)
|
||||
derive newtype instance (Applicative m, Monoid a) => Monoid (PostgresT m a)
|
||||
derive newtype instance (MonadPlus m) => MonadPlus (PostgresT m)
|
||||
derive newtype instance (MonadEffect m) => MonadEffect (PostgresT m)
|
||||
derive newtype instance (MonadAff m) => MonadAff (PostgresT m)
|
||||
derive newtype instance Monad m => MonadReader Pg.Connection (PostgresT m)
|
||||
derive newtype instance Monad m => MonadAsk Pg.Connection (PostgresT m)
|
||||
derive newtype instance MonadCont m => MonadCont (PostgresT m)
|
||||
derive newtype instance MonadTell w m => MonadTell w (PostgresT m)
|
||||
derive newtype instance MonadWriter w m => MonadWriter w (PostgresT m)
|
||||
derive newtype instance MonadRec m => MonadRec (PostgresT m)
|
||||
derive newtype instance MonadFork f m => MonadFork f (PostgresT m)
|
||||
derive newtype instance MonadUnliftAff m => MonadUnliftAff (PostgresT m)
|
||||
instance (Parallel f m) => Parallel (PostgresT f) (PostgresT m) where
|
||||
parallel = wrap <<< parallel <<< unwrap
|
||||
sequential = wrap <<< sequential <<< unwrap
|
||||
|
||||
instance MonadTrans PostgresT where
|
||||
lift = wrap <<< lift
|
||||
|
||||
instance MFunctor PostgresT where
|
||||
hoist f = wrap <<< hoist f <<< unwrap
|
||||
|
||||
instance MMonad PostgresT where
|
||||
embed f = wrap <<< embed (unwrap <<< f) <<< unwrap
|
||||
|
||||
instance MonadKill e f m => MonadKill e f (PostgresT m) where
|
||||
kill e f = wrap $ kill e f
|
||||
|
||||
instance (MonadKill e f (PostgresT m), MonadError e (PostgresT m), MonadKill e f m, MonadError e m, MonadBracket e f m) => MonadBracket e f (PostgresT m) where
|
||||
bracket acq rel m = wrap $ bracket (unwrap acq) (\b r -> unwrap $ rel b r) (unwrap <<< m)
|
||||
uninterruptible = wrap <<< uninterruptible <<< unwrap
|
||||
never = wrap $ never
|
||||
|
||||
class MonadHasPostgres :: (Type -> Type) -> (Type -> Type) -> Constraint
|
||||
class (MonadPostgres p, MonadAff t) <= MonadHasPostgres p t | t -> p where
|
||||
liftPostgres :: forall a. p a -> t a
|
||||
|
||||
instance (MonadUnliftAff m, Monad m, MonadPostgres (PostgresT m)) => MonadHasPostgres (PostgresT m) (HasPostgresT m) where
|
||||
liftPostgres pg = do
|
||||
conn <- ask
|
||||
lift $ runPostgres conn pg
|
||||
else instance (MonadUnliftAff m, Monad m, MonadPostgres (PostgresT m)) => MonadHasPostgres (PostgresT m) (PostgresT m) where
|
||||
liftPostgres pg = do
|
||||
conn <- ask
|
||||
lift $ runPostgres conn pg
|
||||
else instance
|
||||
( MMonad t
|
||||
, MonadPostgres (t p)
|
||||
, MonadAff (t h)
|
||||
, MonadHasPostgres p h
|
||||
) =>
|
||||
MonadHasPostgres (t p) (t h) where
|
||||
liftPostgres = hoist liftPostgres
|
||||
|
||||
-- | A monad which can perform logs
|
||||
class (Monad m, MonadThrow Error m) <= MonadPostgres m where
|
||||
query :: forall @a. Pg.FromSQLRow a => String -> m (Array a)
|
||||
queryP :: forall @a. Pg.FromSQLRow a => Array Foreign -> String -> m (Array a)
|
||||
exec :: String -> m Unit
|
||||
execP :: Array Foreign -> String -> m Unit
|
||||
transaction :: forall a. m a -> m a
|
||||
|
||||
instance (MonadUnliftAff m, MonadThrow Error m) => MonadPostgres (PostgresT m) where
|
||||
query q = do
|
||||
conn <- ask
|
||||
res <- liftAff $ Pg.Aff.query conn (Pg.Query q) Pg.Row0
|
||||
liftEither $ lmap (error <<< show) $ res
|
||||
queryP ps q = do
|
||||
conn <- ask
|
||||
res <- liftAff $ Pg.Aff.query conn (Pg.Query q) ps
|
||||
liftEither $ lmap (error <<< show) $ res
|
||||
exec q = do
|
||||
conn <- ask
|
||||
res <- liftAff $ Pg.Aff.execute conn (Pg.Query q) Pg.Row0
|
||||
liftEither $ lmap (error <<< show) $ maybe (Right unit) Left $ res
|
||||
execP ps q = do
|
||||
conn <- ask
|
||||
res <- liftAff $ Pg.Aff.execute conn (Pg.Query q) ps
|
||||
liftEither $ lmap (error <<< show) $ maybe (Right unit) Left $ res
|
||||
transaction pg = do
|
||||
conn :: Pg.Connection <- ask
|
||||
let pgToM c = runPostgres c pg
|
||||
case unwrap conn of
|
||||
Right _ -> throwError $ error $ "Transactions can only be run with access to the pool!"
|
||||
Left pool -> lift $ withUnliftAff \(UnliftAff mToAff) -> do
|
||||
res <- liftAff $ Pg.Aff.withTransaction pool $ mToAff <<< pgToM
|
||||
liftEither $ lmap (error <<< show) $ res
|
||||
else instance (MonadUnliftAff m, Monad (t m), MonadThrow Error (t m), MMonad t, MonadPostgres m) => MonadPostgres (t m) where
|
||||
query q = lift $ query q
|
||||
queryP ps q = lift $ queryP ps q
|
||||
exec q = lift $ exec q
|
||||
execP ps q = lift $ execP ps q
|
||||
transaction = hoist transaction
|
||||
|
||||
runPostgres :: forall m a. Pg.Connection -> PostgresT m a -> m a
|
||||
runPostgres conn t = (unwrap $ unwrap t) conn
|
||||
|
||||
runHasPostgres :: forall m a. Pg.Connection -> HasPostgresT m a -> m a
|
||||
runHasPostgres conn t = (unwrap $ unwrap t) conn
|
||||
|
||||
newtype RawRow = RawRow (Array Foreign)
|
||||
|
||||
derive instance Newtype RawRow _
|
||||
instance Pg.FromSQLRow RawRow where
|
||||
fromSQLRow = pure <<< wrap
|
||||
|
||||
instance Pg.ToSQLRow RawRow where
|
||||
toSQLRow = unwrap
|
||||
@ -1,7 +0,0 @@
|
||||
module Main where
|
||||
|
||||
import Prelude
|
||||
import Effect (Effect)
|
||||
|
||||
main :: Effect Unit
|
||||
main = pure unit
|
||||
Loading…
Reference in New Issue
Block a user