diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,11 +1,16 @@ # Change Log -## [Unreleased] +## [HEAD] +## [0.4.1] +### Changed +- Fixed missing files. + ## [0.4.0] ### Added - Changelog. - Explicit type casts options. + ### Changed - Flags `older-call-syntax` and `debug-queries` are options now. @@ -21,6 +26,7 @@ ## [0.2.0] - 2016-08-21 ### Added - Cabal flag `dev`. + ### Changed - Relicensed to `BSD3`. - Refactored tests (now using `hspec`). @@ -30,7 +36,8 @@ ### Added - Initial version of the package. -[Unreleased]: ../../compare/v0.4.0...HEAD +[HEAD]: ../../compare/v0.4.1...HEAD +[0.4.1]: ../../compare/v0.4.0...v0.4.1 [0.4.0]: ../../compare/v0.3.0...v0.4.0 [0.3.0]: ../../compare/v0.2.1...v0.3.0 [0.2.1]: ../../compare/v0.2.0...v0.2.1 diff --git a/examples/Common.hs b/examples/Common.hs new file mode 100644 --- /dev/null +++ b/examples/Common.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE LambdaCase #-} + +module Common ( + withDB + , withRollback + , include + , bindOptions + ) where + +import Data.Default (def) +import Control.Exception.Base (bracket) +import Control.Monad (void) +import Database.PostgreSQL.Simple (Connection, ConnectInfo, connect, begin, rollback, close, execute_) +import Database.PostgreSQL.Simple.Bind (PostgresBindOptions(..), PGFunction(..), ReturnType(..)) +import Database.PostgreSQL.Simple.Types (Query(..)) +import Text.CaseConversion (convertCase, WordCase(..)) +import qualified Data.ByteString.Char8 as BS + +mkFunctionName :: PGFunction -> String +mkFunctionName = convertCase Snake Camel . ("sql_" ++) . pgfName + +bindOptions :: PostgresBindOptions +bindOptions = (def :: PostgresBindOptions) { + pboFunctionName = mkFunctionName + , pboSetOfReturnType = \case + "t_user" -> AsRow + _ -> AsField + , pboIsNullable = isNullable + , pboDebugQueries = True + } where + isNullable :: String -> String -> Bool + isNullable "get_new_messages" "contents" = True + isNullable _ _ = False + + +withDB :: ConnectInfo -> (Connection -> IO a) -> IO a +withDB connectInfo = bracket (connect connectInfo) close + +withRollback :: (Connection -> IO ()) -> (Connection -> IO ()) +withRollback action = \conn -> mapM_ ($ conn) [begin, action, rollback] + +include :: Connection -> String -> IO () +include conn fn = void $ BS.readFile fn >>= (execute_ conn . Query) diff --git a/examples/ExMessages.hs b/examples/ExMessages.hs new file mode 100644 --- /dev/null +++ b/examples/ExMessages.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} + +-- Legend: +-- API for reading and sending messages. +-- We apply database patches that modify internal structure yet do not +-- break the API. +-- +-- This is a demonstration of the pattern where the database and the +-- application communicate via API. All three times we run the same test +-- against different editions of the database. + + +module ExMessages ( + specMessages + ) where + +import Common (bindOptions, include) +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Bind (bindFunction) +import Database.PostgreSQL.Simple.Bind.Types() +import Prelude hiding (getContents) +import Test.Hspec (Spec, describe, it, shouldBe) + +concat <$> mapM (bindFunction bindOptions) [ + "function send_message(p_receiver varchar, p_contents varchar default null) returns bigint" + , "function get_new_messages(p_receiver varchar) returns table (message_id bigint, sender varchar, contents varchar)" + , "function mark_as_read(p_receiver varchar, p_message_id bigint) returns void" + ] + + +specMessages :: Connection -> Spec +specMessages conn = describe "Messages example" $ it "works" $ mapM_ runTests [ + "./examples/sql/messages.sql" + , "./examples/sql/messages-patch-1.sql" + , "./examples/sql/messages-patch-2.sql" + ] where + + getId (x, _, _) = x + + runTests fn = do + include conn fn + + msg1 <- sqlSendMessage conn "mr_foo" (Just "hello!") + msg2 <- sqlSendMessage conn "mr_bar" (Just "hello!") + msg3 <- sqlSendMessage conn "mr_bar" (Just "hello again!") + + sqlGetNewMessages conn "mr_foo" >>= shouldBe [msg1] . map getId + sqlGetNewMessages conn "mr_bar" >>= shouldBe [msg2, msg3] . map getId + + sqlMarkAsRead conn "mr_bar" msg2 + + sqlGetNewMessages conn "mr_bar" >>= shouldBe [msg3] . map getId + + sqlMarkAsRead conn "mr_foo" msg1 + sqlMarkAsRead conn "mr_bar" msg3 + + msg4 <- sqlSendMessage conn "mr_baz" Nothing + sqlGetNewMessages conn "mr_baz" >>= shouldBe [(msg4, Nothing)] . map (\(a, _, b) -> (a, b)) + sqlMarkAsRead conn "mr_baz" msg4 diff --git a/examples/ExNumDumpster.hs b/examples/ExNumDumpster.hs new file mode 100644 --- /dev/null +++ b/examples/ExNumDumpster.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} + +-- Legend: +-- NumDumpster is a collection of numbers stored in a database. +-- API provides some basic functions to manipulate the collection. +-- +-- This is an example of using basic features of the library + + +module ExNumDumpster ( + specNumDumpster + ) where + +import Common (bindOptions, include) +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Bind (bindFunction) +import Database.PostgreSQL.Simple.Bind.Types() +import Test.Hspec (Spec, describe, it, shouldBe) + + +concat <$> mapM (bindFunction bindOptions) [ + "function add_num(p_x bigint) returns void" + , "function get_last_num() returns bigint" + , "function get_range(p_range_min bigint default null, p_range_max bigint default null) returns setof bigint" + , "function get_all_nums() returns setof bigint" + , "function clear() returns void" + ] + +addManyNums :: Connection -> [Int] -> IO () +addManyNums conn xs = mapM_ (sqlAddNum conn) xs + +getSum :: Connection -> IO Int +getSum conn = sum <$> (sqlGetAllNums conn) + +iterFib :: Connection -> IO Int +iterFib conn = do + x <- sqlGetLastNum conn + x' <- getSum conn + sqlClear conn + addManyNums conn [x, x'] + return x' + +specNumDumpster :: Connection -> Spec +specNumDumpster conn = describe "NumDumpster example" $ it "works" $ do + include conn "./examples/sql/numdumpster.sql" + + sqlAddNum conn 1 + sqlGetLastNum conn >>= shouldBe 1 + + sqlClear conn + addManyNums conn [1, 2, 3, 4] + sqlGetAllNums conn >>= shouldBe [1, 2, 3, 4] + + sqlGetRange conn Nothing Nothing >>= shouldBe [1, 2, 3, 4] + sqlGetRange conn (Just 2) (Just 3) >>= shouldBe [2, 3] + sqlGetRange conn Nothing (Just 3) >>= shouldBe [1, 2, 3] + sqlGetRange conn (Just 2) Nothing >>= shouldBe [2, 3, 4] + + sqlClear conn + addManyNums conn [0, 1] + ((head . reverse) <$> (sequence $ replicate 11 (iterFib conn))) >>= shouldBe 144 diff --git a/examples/ExUsers.hs b/examples/ExUsers.hs new file mode 100644 --- /dev/null +++ b/examples/ExUsers.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveGeneric #-} + +-- Legend: +-- A CRUD-like API for table of users. +-- Due to backward compatibility requirements some of legacy types must be +-- preserved. +-- +-- This is an example of using custom types. + + +module ExUsers ( + specUsers + ) where + +import Common (bindOptions, include) +import Data.Text (Text) +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.FromRow (FromRow) +import Database.PostgreSQL.Simple.Bind (bindFunction, PostgresType) +import Database.PostgreSQL.Simple.Bind.Types() +import GHC.Generics (Generic) +import Test.Hspec (Spec, describe, it, shouldBe) + +concat <$> mapM (bindFunction bindOptions) [ + "function get_users(p_filter varchar2 default '') returns setof t_user" + , "function add_user(p_name varchar2, p_age bigint) returns bigint" + , "function del_user(p_user_id bigint) returns void" + ] + +type instance PostgresType "varchar2" = Text + + +data User = User { + userId :: Int + , userName :: String + , userAge :: Int + } deriving (Eq, Show, Generic) + +instance FromRow User +type instance PostgresType "t_user" = User + + +specUsers :: Connection -> Spec +specUsers conn = describe "Users example" $ it "works" $ do + include conn "./examples/sql/users.sql" + + mrFooId <- sqlAddUser conn "Mr. Foo" 42 + mrBarId <- sqlAddUser conn "Mr. Bar" 53 + mrBazId <- sqlAddUser conn "Mr. Baz" 64 + + sqlGetUsers conn (Just "Mr. Foo") >>= \[u] -> (u { userId = 1 }) `shouldBe` (User { + userId = 1 + , userName = "Mr. Foo" + , userAge = 42 + }) + + sqlGetUsers conn Nothing >>= shouldBe [mrFooId, mrBarId, mrBazId] . map userId + sqlGetUsers conn (Just "Mr. Ba_") >>= shouldBe [mrBarId, mrBazId] . map userId + sqlDelUser conn mrBarId + + sqlGetUsers conn Nothing >>= shouldBe [mrFooId, mrBazId] . map userId + diff --git a/examples/sql/messages-patch-1.sql b/examples/sql/messages-patch-1.sql new file mode 100644 --- /dev/null +++ b/examples/sql/messages-patch-1.sql @@ -0,0 +1,17 @@ +alter table messages add column creation_time timestamp default current_timestamp; + +create or replace function get_new_messages(p_receiver varchar) returns table ( + message_id bigint +, sender varchar +, contents varchar +) as +$get_new_messages$ + select message_id, sender, contents + from messages + where receiver = p_receiver + and is_read = false + order by creation_time asc; +$get_new_messages$ +language sql +security definer; + diff --git a/examples/sql/messages-patch-2.sql b/examples/sql/messages-patch-2.sql new file mode 100644 --- /dev/null +++ b/examples/sql/messages-patch-2.sql @@ -0,0 +1,72 @@ +create table accounts ( + account_id bigint primary key +, name varchar not null +); + +insert into accounts(account_id, name) + select nextval('s_id') as account_id + , t.name + from ( + select distinct sender as name from messages + union + select distinct receiver as name from messages) t; + + +alter table messages + add column sender_id bigint +, add column receiver_id bigint; + +update messages set + sender_id = (select account_id from accounts a where name = sender) +, receiver_id = (select account_id from accounts a where name = receiver); + +alter table messages + add constraint msg_sender_id_fk foreign key (sender_id) references accounts(account_id) +, add constraint msg_receiver_id_fk foreign key (receiver_id) references accounts(account_id) +, drop column sender +, drop column receiver; + + +create or replace function send_message(p_receiver varchar, p_contents varchar default null) returns bigint as +$send_message$ + insert into messages(message_id, sender_id, receiver_id, contents) + values ( + nextval('s_id') + , (select account_id from accounts where name = user) + , (select account_id from accounts where name = p_receiver) + , p_contents) + returning message_id; +$send_message$ +language sql +security definer; + + +create or replace function get_new_messages(p_receiver varchar) returns table ( + message_id bigint +, sender varchar +, contents varchar +) as +$get_new_messages$ + select message_id, acc_sender.name, contents + from messages msg + , accounts acc_sender + , accounts acc_receiver + where msg.sender_id = acc_sender.account_id + and msg.receiver_id = acc_receiver.account_id + and acc_receiver.name = p_receiver + and msg.is_read = false + order by creation_time; +$get_new_messages$ +language sql +security definer; + + +create or replace function mark_as_read(p_receiver varchar, p_message_id bigint) returns void as +$mark_as_read$ + update messages set is_read = true + where receiver_id in (select account_id from accounts where name = p_receiver) + and message_id = p_message_id; +$mark_as_read$ +language sql +security definer; + diff --git a/examples/sql/messages.sql b/examples/sql/messages.sql new file mode 100644 --- /dev/null +++ b/examples/sql/messages.sql @@ -0,0 +1,46 @@ +create sequence s_id; + +create table messages ( + message_id bigint primary key +, sender varchar not null +, receiver varchar not null +, contents varchar +, is_read boolean default false +); + +create function send_message(p_receiver varchar, p_contents varchar default null) returns bigint as +$send_message$ + insert into messages(message_id, sender, receiver, contents) + values ( + nextval('s_id') + , current_user + , p_receiver + , p_contents) + returning message_id; +$send_message$ +language sql +security definer; + +create function get_new_messages(p_receiver varchar) returns table ( + message_id bigint +, sender varchar +, contents varchar +) as +$get_new_messages$ + select message_id, sender, contents + from messages + where receiver = p_receiver + and is_read = false; +$get_new_messages$ +language sql +security definer; + +create function mark_as_read(p_receiver varchar, p_message_id bigint) returns void as +$mark_as_read$ + update messages set is_read = true + where receiver = p_receiver + and message_id = p_message_id; +$mark_as_read$ +language sql +security definer; + diff --git a/examples/sql/numdumpster.sql b/examples/sql/numdumpster.sql new file mode 100644 --- /dev/null +++ b/examples/sql/numdumpster.sql @@ -0,0 +1,64 @@ +create table numdumpster ( + id bigint primary key +, x bigint +); + +create function get_last_num() returns bigint as +$get_last_num$ + select x + from numdumpster nd + order by nd.id desc + limit 1; +$get_last_num$ +language sql +security definer; + + +create function get_all_nums() returns setof bigint as +$get_all_nums$ + select x + from numdumpster nd + order by nd.id asc; +$get_all_nums$ +language sql +security definer; + + +create function get_range( + p_range_min bigint default null + , p_range_max bigint default null +) returns setof bigint as +$get_all_nums$ + select x + from numdumpster nd + where x >= coalesce(p_range_min, x) + and x <= coalesce(p_range_max, x) + order by nd.id asc; +$get_all_nums$ +language sql +security definer; + + +create function add_num(p_x bigint) returns void as +$add_num$ + insert into numdumpster(id, x) + select coalesce(max(nd.id), 0) + 1, p_x from numdumpster nd; +$add_num$ +language sql +security definer; + + +create function clear() returns void as +$clear$ + delete from numdumpster; +$clear$ +language sql +security definer; + +create function get_val(p_number bigint default '14') returns bigint as +$$ + select p_number; +$$ +language sql; + + diff --git a/examples/sql/users.sql b/examples/sql/users.sql new file mode 100644 --- /dev/null +++ b/examples/sql/users.sql @@ -0,0 +1,60 @@ +create domain varchar2 as varchar + default '' + not null + check (length(value) <= 4000); + + +create function nvl(p varchar2, alt varchar2) returns varchar2 as +$nvl$ + select (case p when '' then alt else p end); +$nvl$ +language sql; + + +create table users ( + user_id bigint primary key +, name varchar2 not null +, age bigint not null +, is_active boolean not null default true); + + +create type t_user as ( + user_id bigint +, name varchar2 +, age bigint); + + +create function get_users(p_filter varchar2 default '') returns setof t_user as +$get_users_1$ + select user_id, name, age + from users + where is_active = true + and name like nvl(p_filter, name) + order by user_id; +$get_users_1$ +language sql +security definer; + + +create function add_user(p_name varchar2, p_age bigint) returns bigint as +$add_user$ + insert into users(user_id, name, age) + values ( + (select coalesce(max(user_id), 0) + 1 from users) + , p_name + , p_age) + returning user_id; +$add_user$ +language sql +security definer; + + +create function del_user(p_user_id bigint) returns void as +$del_user$ + update users + set is_active = false + where user_id = p_user_id; +$del_user$ +language sql +security definer; + diff --git a/postgresql-simple-bind.cabal b/postgresql-simple-bind.cabal --- a/postgresql-simple-bind.cabal +++ b/postgresql-simple-bind.cabal @@ -1,5 +1,5 @@ name: postgresql-simple-bind -version: 0.4.0 +version: 0.4.1 synopsis: FFI-like bindings for PostgreSQL stored functions description: For tutorial see here: https:\/\/github.com\/zohl\/postgresql-simple-bind\/blob\/master\/README.md license: BSD3 @@ -13,6 +13,7 @@ extra-source-files: CHANGELOG.md + examples/sql/*.sql flag dev description: Turn on development settings. @@ -86,6 +87,12 @@ hs-source-dirs: examples main-is: Main.hs + other-modules: + Common + ExMessages + ExNumDumpster + ExUsers + default-language: Haskell2010 ghc-options: -Wall -Wno-redundant-constraints