squeal-postgresql 0.9.1.3 → 0.9.2.0
raw patch · 9 files changed
+248/−23 lines, 9 filesdep +iproute
Dependencies added: iproute
Files
- README.md +1/−1
- exe/Example.hs +125/−11
- squeal-postgresql.cabal +2/−1
- src/Squeal/PostgreSQL/Expression/Array.hs +49/−0
- src/Squeal/PostgreSQL/Session.hs +3/−4
- src/Squeal/PostgreSQL/Session/Decode.hs +47/−3
- src/Squeal/PostgreSQL/Session/Encode.hs +10/−1
- src/Squeal/PostgreSQL/Session/Oid.hs +1/−1
- src/Squeal/PostgreSQL/Type/PG.hs +10/−1
README.md view
@@ -2,7 +2,7 @@  -[](https://circleci.com/gh/morphismtech/squeal)+[](https://github.com/morphismtech/squeal/actions/workflows/ci.yml) [Github](https://github.com/morphismtech/squeal)
exe/Example.hs view
@@ -9,8 +9,15 @@ , TypeOperators #-} +{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ module Main (main, main2, upsertUser) where +import Control.Monad.Except (MonadError (throwError)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Int (Int16, Int32) import Data.Text (Text)@@ -46,6 +53,7 @@ '[ "pk_organizations" ::: 'PrimaryKey '["id"] ] :=> '[ "id" ::: 'Def :=> 'NotNull 'PGint4 , "name" ::: 'NoDef :=> 'NotNull 'PGtext+ , "type" ::: 'NoDef :=> 'NotNull 'PGtext ]) , "members" ::: 'Table ( '[ "fk_member" ::: 'ForeignKey '["member"] "user" "users" '["id"]@@ -54,7 +62,7 @@ , "organization" ::: 'NoDef :=> 'NotNull 'PGint4 ]) ] -type Schemas +type Schemas = '[ "public" ::: PublicSchema, "user" ::: UserSchema, "org" ::: OrgSchema ] setup :: Definition (Public '[]) Schemas@@ -83,7 +91,8 @@ >>> createTable (#org ! #organizations) ( serial `as` #id :*- (text & notNullable) `as` #name )+ (text & notNullable) `as` #name :*+ (text & notNullable) `as` #type ) ( primaryKey #id `as` #pk_organizations ) >>> createTable (#org ! #members)@@ -93,7 +102,7 @@ (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_member :* foreignKey #organization (#org ! #organizations) #id (OnDelete Cascade) (OnUpdate Cascade) `as` #fk_organization )- + teardown :: Definition Schemas (Public '[]) teardown = dropType #positive >>> dropSchemaCascade #user >>> dropSchemaCascade #org @@ -106,6 +115,11 @@ insertEmail = insertInto_ (#user ! #emails) (Values_ (Default `as` #id :* Set (param @1) `as` #user_id :* Set (param @2) `as` #email)) +insertOrganization :: Manipulation_ Schemas (Text, OrganizationType) (Only Int32)+insertOrganization = insertInto (#org ! #organizations)+ (Values_ (Default `as` #id :* Set (param @1) `as` #name :* Set (param @2) `as` #type))+ (OnConflict (OnConstraint #pk_organizations) DoNothing) (Returning_ (#id `as` #fromOnly))+ getUsers :: Query_ Schemas () User getUsers = select_ (#u ! #name `as` #userName :* #e ! #email `as` #userEmail :* #u ! #vec `as` #userVec)@@ -113,6 +127,36 @@ & innerJoin (table ((#user ! #emails) `as` #e)) (#u ! #id .== #e ! #user_id)) ) +getOrganizations :: Query_ Schemas () Organization+getOrganizations = select_+ ( #o ! #id `as` #orgId :*+ #o ! #name `as` #orgName :*+ #o ! #type `as` #orgType+ )+ (from (table (#org ! #organizations `as` #o)))++getOrganizationsBy ::+ forall hsty.+ (ToPG Schemas hsty) =>+ Condition+ 'Ungrouped+ '[]+ '[]+ Schemas+ '[NullPG hsty]+ '["o" ::: ["id" ::: NotNull PGint4, "name" ::: NotNull PGtext, "type" ::: NotNull PGtext]] ->+ Query_ Schemas (Only hsty) Organization+getOrganizationsBy condition =+ select_+ ( #o ! #id `as` #orgId :*+ #o ! #name `as` #orgName :*+ #o ! #type `as` #orgType+ )+ (+ from (table (#org ! #organizations `as` #o))+ & where_ condition+ )+ upsertUser :: Manipulation_ Schemas (Int32, String, VarArray [Maybe Int16]) () upsertUser = insertInto (#user ! #users `as` #u) (Values_ (Set (param @1) `as` #id :* setUser))@@ -137,28 +181,98 @@ , User "Carole" (Just "carole@hotmail.com") (VarArray [Just 3,Nothing, Just 4]) ] +data Organization+ = Organization+ { orgId :: Int32+ , orgName :: Text+ , orgType :: OrganizationType+ } deriving (Show, GHC.Generic)+instance SOP.Generic Organization+instance SOP.HasDatatypeInfo Organization++data OrganizationType+ = ForProfit+ | NonProfit+ deriving (Show, GHC.Generic)+instance SOP.Generic OrganizationType+instance SOP.HasDatatypeInfo OrganizationType++instance IsPG OrganizationType where+ type PG OrganizationType = 'PGtext+instance ToPG db OrganizationType where+ toPG = toPG . toText+ where+ toText ForProfit = "for-profit" :: Text+ toText NonProfit = "non-profit" :: Text++instance FromPG OrganizationType where+ fromPG = do+ value <- fromPG @Text+ fromText value+ where+ fromText "for-profit" = pure ForProfit+ fromText "non-profit" = pure NonProfit+ fromText value = throwError $ "Invalid organization type: \"" <> value <> "\""++organizations :: [Organization]+organizations =+ [ Organization { orgId = 1, orgName = "ACME", orgType = ForProfit }+ , Organization { orgId = 2, orgName = "Haskell Foundation", orgType = NonProfit }+ ]+ session :: (MonadIO pq, MonadPQ Schemas pq) => pq () session = do- liftIO $ Char8.putStrLn "manipulating"- idResults <- traversePrepared insertUser ([(userName user, userVec user) | user <- users])- ids <- traverse (fmap fromOnly . getRow 0) (idResults :: [Result (Only Int32)])- traversePrepared_ insertEmail (zip (ids :: [Int32]) (userEmail <$> users))- liftIO $ Char8.putStrLn "querying"+ liftIO $ Char8.putStrLn "===> manipulating"+ userIdResults <- traversePrepared insertUser [(userName user, userVec user) | user <- users]+ userIds <- traverse (fmap fromOnly . getRow 0) (userIdResults :: [Result (Only Int32)])+ traversePrepared_ insertEmail (zip (userIds :: [Int32]) (userEmail <$> users))++ orgIdResults <- traversePrepared+ insertOrganization+ [(orgName organization, orgType organization) | organization <- organizations]+ _ <- traverse (fmap fromOnly . getRow 0) (orgIdResults :: [Result (Only Int32)])++ liftIO $ Char8.putStrLn "===> querying: users" usersResult <- runQuery getUsers usersRows <- getRows usersResult liftIO $ print (usersRows :: [User]) + liftIO $ Char8.putStrLn "===> querying: organizations: all"+ organizationsResult1 <- runQuery getOrganizations+ organizationRows1 <- getRows organizationsResult1+ liftIO $ print (organizationRows1 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by ID (2)"+ organizationsResult2 <- runQueryParams+ (getOrganizationsBy @Int32 ((#o ! #id) .== param @1)) (Only (2 :: Int32))+ organizationRows2 <- getRows organizationsResult2+ liftIO $ print (organizationRows2 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by name (ACME)"+ organizationsResult3 <- runQueryParams+ (getOrganizationsBy @Text ((#o ! #name) .== param @1)) (Only ("ACME" :: Text))+ organizationRows3 <- getRows organizationsResult3+ liftIO $ print (organizationRows3 :: [Organization])++ liftIO $ Char8.putStrLn "===> querying: organizations: by type (non-profit)"+ organizationsResult4 <- runQueryParams+ (getOrganizationsBy @Text ((#o ! #type) .== param @1)) (Only NonProfit)+ organizationRows4 <- getRows organizationsResult4+ liftIO $ print (organizationRows4 :: [Organization])+ main :: IO () main = do- Char8.putStrLn "squeal"+ Char8.putStrLn "===> squeal" connectionString <- pure "host=localhost port=5432 dbname=exampledb user=postgres password=postgres" Char8.putStrLn $ "connecting to " <> connectionString connection0 <- connectdb connectionString- Char8.putStrLn "setting up schema"++ Char8.putStrLn "===> setting up schema" connection1 <- execPQ (define setup) connection0 connection2 <- execPQ session connection1- Char8.putStrLn "tearing down schema"++ Char8.putStrLn "===> tearing down schema" connection3 <- execPQ (define teardown) connection2 finish connection3
squeal-postgresql.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: squeal-postgresql-version: 0.9.1.3+version: 0.9.2.0 synopsis: Squeal PostgreSQL Library description: Squeal is a type-safe embedding of PostgreSQL in Haskell homepage: https://github.com/morphismtech/squeal@@ -99,6 +99,7 @@ , free-categories >= 0.2.0.0 , generics-sop >= 0.5.1.0 , hashable >= 1.3.0.0+ , iproute >= 1.7.0 , mmorph >= 1.1.3 , monad-control >= 1.0.2.3 , mtl >= 2.2.2
src/Squeal/PostgreSQL/Expression/Array.hs view
@@ -37,6 +37,15 @@ , unnest , arrAny , arrAll+ , arrayAppend+ , arrayPrepend+ , arrayCat+ , arrayPosition+ , arrayPositionBegins+ , arrayPositions+ , arrayRemoveNull+ , arrayReplace+ , trimArray ) where import Data.String@@ -47,6 +56,7 @@ import Squeal.PostgreSQL.Expression import Squeal.PostgreSQL.Expression.Logic+import Squeal.PostgreSQL.Expression.Null import Squeal.PostgreSQL.Expression.Type import Squeal.PostgreSQL.Query.From.Set import Squeal.PostgreSQL.Render@@ -240,3 +250,42 @@ -> Expression grp lat with db params from (null ('PGvararray ty2)) -- ^ array -> Condition grp lat with db params from arrAny x (?) xs = x ? (UnsafeExpression $ "ANY" <+> parenthesized (renderSQL xs))++arrayAppend :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty)+arrayAppend = unsafeFunctionN "array_append"++arrayPrepend :: '[ty, null ('PGvararray ty)] ---> null ('PGvararray ty)+arrayPrepend = unsafeFunctionN "array_prepend"++arrayCat+ :: '[null ('PGvararray ty), null ('PGvararray ty)]+ ---> null ('PGvararray ty)+arrayCat = unsafeFunctionN "array_cat"++arrayPosition :: '[null ('PGvararray ty), ty] ---> 'Null 'PGint8+arrayPosition = unsafeFunctionN "array_position"++arrayPositionBegins+ :: '[null ('PGvararray ty), ty, null 'PGint8] ---> 'Null 'PGint8+arrayPositionBegins = unsafeFunctionN "array_position"++arrayPositions+ :: '[null ('PGvararray ty), ty]+ ---> null ('PGvararray ('NotNull 'PGint8))+arrayPositions = unsafeFunctionN "array_positions"++arrayRemove :: '[null ('PGvararray ty), ty] ---> null ('PGvararray ty)+arrayRemove = unsafeFunctionN "array_remove"++arrayRemoveNull :: null ('PGvararray ('Null ty)) --> null ('PGvararray ('NotNull ty))+arrayRemoveNull arr = UnsafeExpression (renderSQL (arrayRemove (arr *: null_)))++arrayReplace+ :: '[null ('PGvararray ty), ty, ty]+ ---> null ('PGvararray ty)+arrayReplace = unsafeFunctionN "array_replace"++trimArray+ :: '[null ('PGvararray ty), 'NotNull 'PGint8]+ ---> null ('PGvararray ty)+trimArray = unsafeFunctionN "trim_array"
src/Squeal/PostgreSQL/Session.hs view
@@ -44,9 +44,8 @@ import Control.Monad.Base (MonadBase(..)) import Control.Monad.Fix (MonadFix(..)) import Control.Monad.Catch-import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Morph-import Control.Monad.Reader (ReaderT(..))+import Control.Monad.Reader import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..)) import UnliftIO (MonadUnliftIO(..)) import Data.ByteString (ByteString)@@ -214,9 +213,9 @@ return = pure (>>=) = flip pqBind -instance (Monad m, db0 ~ db1)+instance (MonadFail m, db0 ~ db1) => Fail.MonadFail (PQ db0 db1 m) where- fail = Fail.fail+ fail = lift . Fail.fail instance db0 ~ db1 => MFunctor (PQ db0 db1) where hoist f (PQ pq) = PQ (f . pq)
src/Squeal/PostgreSQL/Session/Decode.hs view
@@ -43,6 +43,7 @@ , genericProductRow , appendRows , consRow+ , ArrayField (..) -- * Decoding Classes , FromValue (..) , FromField (..)@@ -68,6 +69,11 @@ import Data.Coerce (coerce) import Data.Functor.Constant (Constant(Constant)) import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif import Data.Kind import Data.Scientific (Scientific) import Data.String (fromString)@@ -78,7 +84,6 @@ import Database.PostgreSQL.LibPQ (Oid(Oid)) import GHC.OverloadedLabels import GHC.TypeLits-import Network.IP.Addr (NetAddr, IP) import PostgreSQL.Binary.Decoding hiding (Composite) import Unsafe.Coerce @@ -200,8 +205,11 @@ fromPG = devalue $ Money <$> int instance FromPG UUID where fromPG = devalue uuid-instance FromPG (NetAddr IP) where- fromPG = devalue inet+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance FromPG IPRange where fromPG = devalue inet+#else+instance FromPG (NetAddr IP) where fromPG = devalue inet+#endif instance FromPG Char where fromPG = devalue char instance FromPG Strict.Text where@@ -532,6 +540,42 @@ => IsLabel fld (MaybeT (DecodeRow (field ': row)) y) where fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) -> runDecodeRow (runMaybeT (fromLabel @fld)) bs++{- | Utility for decoding array fields in a `DecodeRow`,+accessed via overloaded labels.+-}+newtype ArrayField row y = ArrayField+ { runArrayField+ :: StateT Strict.ByteString (Except Strict.Text) y+ -> DecodeRow row [y]+ }+instance {-# OVERLAPPING #-}+ ( KnownSymbol fld+ , PG y ~ ty+ , arr ~ 'NotNull ('PGvararray ('NotNull ty))+ ) => IsLabel fld (ArrayField (fld ::: arr ': row) y) where+ fromLabel = ArrayField $ \yval ->+ decodeRow $ \(SOP.K bytesMaybe SOP.:* _) -> do+ let+ flderr = mconcat+ [ "field name: "+ , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "+ ]+ yarr+ = devalue+ . array+ . dimensionArray replicateM+ . valueArray+ . revalue+ $ yval+ case bytesMaybe of+ Nothing -> Left (flderr <> "encountered unexpected NULL")+ Just bytes -> runExcept (evalStateT yarr bytes)+instance {-# OVERLAPPABLE #-} IsLabel fld (ArrayField row y)+ => IsLabel fld (ArrayField (field ': row) y) where+ fromLabel = ArrayField $ \yval ->+ decodeRow $ \(_ SOP.:* bytess) ->+ runDecodeRow (runArrayField (fromLabel @fld) yval) bytess -- | A `GenericRow` constraint to ensure that a Haskell type -- is a record type,
src/Squeal/PostgreSQL/Session/Encode.hs view
@@ -11,6 +11,7 @@ {-# LANGUAGE AllowAmbiguousTypes , ConstraintKinds+ , CPP , DataKinds , DefaultSignatures , FlexibleContexts@@ -59,6 +60,11 @@ import Data.Functor.Constant (Constant(Constant)) import Data.Functor.Contravariant import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif import Data.Kind import Data.Scientific (Scientific) import Data.Text as Strict (Text)@@ -69,7 +75,6 @@ import Data.Word (Word32) import Foreign.C.Types (CUInt(CUInt)) import GHC.TypeLits-import Network.IP.Addr (NetAddr, IP) import PostgreSQL.Binary.Encoding hiding (Composite, field) import qualified Data.Aeson as Aeson@@ -121,7 +126,11 @@ instance ToPG db Scientific where toPG = pure . numeric instance ToPG db Money where toPG = pure . int8_int64 . cents instance ToPG db UUID where toPG = pure . uuid+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance ToPG db IPRange where toPG = pure . inet+#else instance ToPG db (NetAddr IP) where toPG = pure . inet+#endif instance ToPG db Char where toPG = pure . char_utf8 instance ToPG db Strict.Text where toPG = pure . text_strict instance ToPG db Lazy.Text where toPG = pure . text_lazy
src/Squeal/PostgreSQL/Session/Oid.hs view
@@ -36,7 +36,7 @@ import Control.Monad (when) import Control.Monad.Catch (throwM)-import Control.Monad.Reader (ReaderT(ReaderT))+import Control.Monad.Reader import Data.String import GHC.TypeLits import PostgreSQL.Binary.Decoding (valueParser, int)
src/Squeal/PostgreSQL/Type/PG.hs view
@@ -10,6 +10,7 @@ -} {-# LANGUAGE AllowAmbiguousTypes+ , CPP , DeriveAnyClass , DeriveFoldable , DeriveFunctor@@ -57,12 +58,16 @@ import Data.Functor.Constant (Constant) import Data.Kind (Type) import Data.Int (Int16, Int32, Int64)+#if MIN_VERSION_postgresql_binary(0, 14, 0)+import Data.IP (IPRange)+#else+import Network.IP.Addr (NetAddr, IP)+#endif import Data.Scientific (Scientific) import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime) import Data.Vector (Vector) import Data.UUID.Types (UUID) import GHC.TypeLits-import Network.IP.Addr (NetAddr, IP) import qualified Data.ByteString.Lazy as Lazy (ByteString) import qualified Data.ByteString as Strict (ByteString)@@ -166,7 +171,11 @@ -- | `PGuuid` instance IsPG UUID where type PG UUID = 'PGuuid -- | `PGinet`+#if MIN_VERSION_postgresql_binary(0, 14, 0)+instance IsPG IPRange where type PG IPRange = 'PGinet+#else instance IsPG (NetAddr IP) where type PG (NetAddr IP) = 'PGinet+#endif -- | `PGjson` instance IsPG Value where type PG Value = 'PGjson -- | `PGvarchar`