From 743ab2a92ba94c53943f70bdcb1030124b90c182 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Mon, 17 Jul 2017 09:20:22 +0100 Subject: [PATCH 1/6] First commit. Have a draft of separating the README examples into functions and running them on a test sqlite DB --- examples/Blog.hs | 189 ++++++++++++++++++++++++++++++++++++++++++ examples/LICENSE | 30 +++++++ examples/README.md | 3 + examples/Setup.hs | 2 + examples/package.yaml | 35 ++++++++ 5 files changed, 259 insertions(+) create mode 100644 examples/Blog.hs create mode 100644 examples/LICENSE create mode 100644 examples/README.md create mode 100644 examples/Setup.hs create mode 100644 examples/package.yaml diff --git a/examples/Blog.hs b/examples/Blog.hs new file mode 100644 index 0000000..68ba026 --- /dev/null +++ b/examples/Blog.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + + +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import Database.Esqueleto +import Database.Persist.Sqlite (runMigration, runSqlite) +import Database.Persist.TH (mkMigrate, mkPersist, + persistLowerCase, share, sqlSettings) + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + Person + name String + age Int Maybe + deriving Eq Show + BlogPost + title String + authorId PersonId + deriving Eq Show + Follow + follower PersonId + followed PersonId + deriving Eq Show +|] + +putPersons :: (MonadIO m) + => SqlPersistT m () +putPersons = do + people <- select $ + from $ \person -> do + return person + liftIO $ mapM_ (putStrLn . personName . entityVal) people + +getJohns :: (MonadIO m) + => SqlReadT m [Entity Person] +getJohns = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "John") + return p + +getJaoas :: (MonadIO m) + => SqlReadT m [Entity Person] +getJaoas = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") + return p + +getAdults :: (MonadIO m) + => SqlReadT m [Entity Person] +getAdults = + select $ + from $ \p -> do + where_ (p ^. PersonAge >=. just (val 18)) + return p + +getBlogPostsByAuthors :: (MonadIO m) + => SqlReadT m [(Entity BlogPost, Entity Person)] +getBlogPostsByAuthors = + select $ + from $ \(b, p) -> do + where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (b ^. BlogPostTitle)] + return (b, p) + +getAuthorMaybePosts :: (MonadIO m) + => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] +getAuthorMaybePosts = + select $ + from $ \(p `LeftOuterJoin` mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] + return (p, mb) + +followers :: (MonadIO m) + => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] +followers = + select $ + from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do + on (p2 ^. PersonId ==. f ^. FollowFollowed) + on (p1 ^. PersonId ==. f ^. FollowFollower) + return (p1, f, p2) + +updateJoao :: (MonadIO m) + => SqlWriteT m () +updateJoao = + update $ \p -> do + set p [ PersonName =. val "João" ] + where_ (p ^. PersonName ==. val "Joao") + +deleteYoungsters :: (MonadIO m) + => SqlWriteT m () +deleteYoungsters = + delete $ + from $ \p -> do + where_ (p ^. PersonAge <. just (val 14)) + +insertBlogPosts :: (MonadIO m) + => SqlWriteT m () +insertBlogPosts = + insertSelect $ from $ \p -> + return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) + +testDb :: (MonadIO m) + => SqlWriteT m () +testDb = do + john <- insert $ Person "John" (Just 24) + sean <- insert $ Person "Seán" (Just 70) + joao <- insert $ Person "Joao" (Just 13) + void $ insertMany [ BlogPost "How to play a bodhrán" sean + , BlogPost "Haskell for the working class hero" john + ] + void $ insert $ Follow john sean + void $ insert $ Follow sean john + void $ insert $ Follow joao sean + +arith :: Num b => (a -> b) -> Integer -> a -> b +arith f i a = (f a) + fromInteger i + +main :: IO () +main = runSqlite ":memory:" $ do + runMigration migrateAll + testDb + + printMessage "Listing all names of the people in the database" + printMessage "===============================================" + putPersons + printMessage "===============================================" + + printMessage "Listing all the people with the name John:" + printMessage "===============================================" + getJohns >>= printVals + printMessage "===============================================" + + printMessage "Listing all people of the age 18 or over" + printMessage "===============================================" + getAdults >>= printVals + printMessage "===============================================" + + printMessage "Listing all Blog Posts and their Authors" + printMessage "===============================================" + getBlogPostsByAuthors >>= printVals2 + printMessage "===============================================" + + printMessage "Listing all Authors and their possible Blog Posts" + printMessage "===============================================" + getAuthorMaybePosts >>= mapM_ print' + printMessage "===============================================" + + printMessage "Listing all mutual Followers" + printMessage "===============================================" + followers >>= mapM_ print' + printMessage "===============================================" + + printMessage "Updating Jaoa and checking the update" + printMessage "===============================================" + updateJoao + getJaoas >>= printVals + printMessage "===============================================" + + printMessage "Deleting poor Jaoa because he is too young" + printMessage "===============================================" + deleteYoungsters + getJaoas >>= printVals + printMessage "===============================================" + where + -- | Helper for print Text and getting rid of pesky warnings to default + -- | literals to [Char] + printMessage :: (MonadIO m) => Text -> m () + printMessage = liftIO . print + + -- | Helper function for printing in our DB environment + print' :: (MonadIO m, Show a) => a -> m () + print' = liftIO . print + + -- | Helper to extract the entity values and print each one + printVals = liftIO . mapM_ (print . entityVal) + + -- | TODO: Scrap this for something better + printVals2 = liftIO . mapM_ (print . both entityVal entityVal) + both f g (a, b) = (f a, g b) diff --git a/examples/LICENSE b/examples/LICENSE new file mode 100644 index 0000000..0cac1c1 --- /dev/null +++ b/examples/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Felipe Lessa + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/examples/README.md b/examples/README.md new file mode 100644 index 0000000..8a05c6d --- /dev/null +++ b/examples/README.md @@ -0,0 +1,3 @@ +# Esqueleto Examples + +These examples can be build via `stack build`. diff --git a/examples/Setup.hs b/examples/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/examples/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/package.yaml b/examples/package.yaml new file mode 100644 index 0000000..c48f515 --- /dev/null +++ b/examples/package.yaml @@ -0,0 +1,35 @@ +name: esqueleto-examples +version: '0.0.0.0' +category: Database +author: Fintan Halpenny +maintainer: fintan.halpenny@gmail.com +copyright: 2017, Chris Allen +license: BSD3 +github: FintanH/esqueleto +extra-source-files: +- README.md +dependencies: +- base +- esqueleto +- persistent +- persistent-template +- persistent-sqlite +- text +ghc-options: +- -Wall +- -threaded +- -rtsopts +- -with-rtsopts=-N +when: +- condition: flag(werror) + ghc-options: -Werror + +executables: + blog-example: + main: Blog.hs + +flags: + werror: + description: "Treat warnings as errors" + manual: true + default: false From 93e861cd1bbda0afdcaf05b824bd2fcc065a8c79 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Mon, 17 Jul 2017 21:37:15 +0100 Subject: [PATCH 2/6] Trying to figure out why deleteYoungsters is throwing an ErrorConstraint. Been trying Cascade Deletes but it doesn't seem to help --- examples/Blog.hs | 55 ++++++++++++++++++++++++++++++++++--------- examples/package.yaml | 1 + 2 files changed, 45 insertions(+), 11 deletions(-) diff --git a/examples/Blog.hs b/examples/Blog.hs index 68ba026..71b595d 100644 --- a/examples/Blog.hs +++ b/examples/Blog.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,16 +7,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +module Main + ( main + ) where +------------------------------------------------------------------------------- import Control.Monad (void) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Text (Text) import Database.Esqueleto -import Database.Persist.Sqlite (runMigration, runSqlite) -import Database.Persist.TH (mkMigrate, mkPersist, +import Database.Persist.Sqlite (fkEnabled, mkSqliteConnectionInfo, + runMigration, runSqliteInfo) +import Database.Persist.TH (mkDeleteCascade, mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) +import Lens.Micro ((&), (.~)) +------------------------------------------------------------------------------- -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + +share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Person name String age Int Maybe @@ -30,14 +39,18 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| deriving Eq Show |] + +------------------------------------------------------------------------------- putPersons :: (MonadIO m) => SqlPersistT m () putPersons = do people <- select $ from $ \person -> do return person - liftIO $ mapM_ (putStrLn . personName . entityVal) people + liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people + +------------------------------------------------------------------------------- getJohns :: (MonadIO m) => SqlReadT m [Entity Person] getJohns = @@ -46,6 +59,8 @@ getJohns = where_ (p ^. PersonName ==. val "John") return p + +------------------------------------------------------------------------------- getJaoas :: (MonadIO m) => SqlReadT m [Entity Person] getJaoas = @@ -54,6 +69,8 @@ getJaoas = where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") return p + +------------------------------------------------------------------------------- getAdults :: (MonadIO m) => SqlReadT m [Entity Person] getAdults = @@ -62,6 +79,8 @@ getAdults = where_ (p ^. PersonAge >=. just (val 18)) return p + +------------------------------------------------------------------------------- getBlogPostsByAuthors :: (MonadIO m) => SqlReadT m [(Entity BlogPost, Entity Person)] getBlogPostsByAuthors = @@ -71,6 +90,8 @@ getBlogPostsByAuthors = orderBy [asc (b ^. BlogPostTitle)] return (b, p) + +------------------------------------------------------------------------------- getAuthorMaybePosts :: (MonadIO m) => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] getAuthorMaybePosts = @@ -80,6 +101,8 @@ getAuthorMaybePosts = orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] return (p, mb) + +------------------------------------------------------------------------------- followers :: (MonadIO m) => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] followers = @@ -89,6 +112,8 @@ followers = on (p1 ^. PersonId ==. f ^. FollowFollower) return (p1, f, p2) + +------------------------------------------------------------------------------- updateJoao :: (MonadIO m) => SqlWriteT m () updateJoao = @@ -96,19 +121,25 @@ updateJoao = set p [ PersonName =. val "João" ] where_ (p ^. PersonName ==. val "Joao") + +------------------------------------------------------------------------------- deleteYoungsters :: (MonadIO m) => SqlWriteT m () -deleteYoungsters = +deleteYoungsters = do delete $ from $ \p -> do where_ (p ^. PersonAge <. just (val 14)) + +------------------------------------------------------------------------------- insertBlogPosts :: (MonadIO m) => SqlWriteT m () insertBlogPosts = insertSelect $ from $ \p -> return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) + +------------------------------------------------------------------------------- testDb :: (MonadIO m) => SqlWriteT m () testDb = do @@ -122,18 +153,20 @@ testDb = do void $ insert $ Follow sean john void $ insert $ Follow joao sean -arith :: Num b => (a -> b) -> Integer -> a -> b -arith f i a = (f a) + fromInteger i +------------------------------------------------------------------------------- main :: IO () -main = runSqlite ":memory:" $ do +main = + let conn = (mkSqliteConnectionInfo ":memory:") & fkEnabled .~ True + in runSqliteInfo conn $ do + -- Run migrations to synchronise the databse runMigration migrateAll + + -- Initialise our test database testDb - printMessage "Listing all names of the people in the database" - printMessage "===============================================" + -- Print the names of our Persons putPersons - printMessage "===============================================" printMessage "Listing all the people with the name John:" printMessage "===============================================" diff --git a/examples/package.yaml b/examples/package.yaml index c48f515..2b45ac5 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -15,6 +15,7 @@ dependencies: - persistent-template - persistent-sqlite - text +- microlens ghc-options: - -Wall - -threaded From 5b047567f70ef2f84c38120fd7e7c0c4abb3fba3 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sat, 22 Jul 2017 16:50:27 +0100 Subject: [PATCH 3/6] Moved to using postgresql with working example of put persons --- examples/Blog.hs | 163 +++++++++++++++++++++--------------------- examples/package.yaml | 6 +- 2 files changed, 86 insertions(+), 83 deletions(-) diff --git a/examples/Blog.hs b/examples/Blog.hs index 71b595d..1dd0fbc 100644 --- a/examples/Blog.hs +++ b/examples/Blog.hs @@ -1,26 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Main ( main ) where ------------------------------------------------------------------------------- -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Text (Text) +import Control.Monad (void) +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Logger (MonadLogger, NoLoggingT (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Data.Text (Text) import Database.Esqueleto -import Database.Persist.Sqlite (fkEnabled, mkSqliteConnectionInfo, - runMigration, runSqliteInfo) -import Database.Persist.TH (mkDeleteCascade, mkMigrate, mkPersist, - persistLowerCase, share, sqlSettings) -import Lens.Micro ((&), (.~)) +import Database.Persist.Postgresql (ConnectionString, + withPostgresqlConn) +import Database.Persist.TH (mkDeleteCascade, mkMigrate, + mkPersist, persistLowerCase, + share, sqlSettings) +import Lens.Micro ((&), (.~)) ------------------------------------------------------------------------------- @@ -41,7 +52,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll ------------------------------------------------------------------------------- -putPersons :: (MonadIO m) +putPersons :: (MonadIO m, MonadLogger m) => SqlPersistT m () putPersons = do people <- select $ @@ -51,7 +62,7 @@ putPersons = do ------------------------------------------------------------------------------- -getJohns :: (MonadIO m) +getJohns :: (MonadIO m, MonadLogger m) => SqlReadT m [Entity Person] getJohns = select $ @@ -61,7 +72,7 @@ getJohns = ------------------------------------------------------------------------------- -getJaoas :: (MonadIO m) +getJaoas :: (MonadIO m, MonadLogger m) => SqlReadT m [Entity Person] getJaoas = select $ @@ -71,7 +82,7 @@ getJaoas = ------------------------------------------------------------------------------- -getAdults :: (MonadIO m) +getAdults :: (MonadIO m, MonadLogger m) => SqlReadT m [Entity Person] getAdults = select $ @@ -81,7 +92,7 @@ getAdults = ------------------------------------------------------------------------------- -getBlogPostsByAuthors :: (MonadIO m) +getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity BlogPost, Entity Person)] getBlogPostsByAuthors = select $ @@ -92,7 +103,7 @@ getBlogPostsByAuthors = ------------------------------------------------------------------------------- -getAuthorMaybePosts :: (MonadIO m) +getAuthorMaybePosts :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] getAuthorMaybePosts = select $ @@ -103,7 +114,7 @@ getAuthorMaybePosts = ------------------------------------------------------------------------------- -followers :: (MonadIO m) +followers :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] followers = select $ @@ -114,7 +125,7 @@ followers = ------------------------------------------------------------------------------- -updateJoao :: (MonadIO m) +updateJoao :: (MonadIO m, MonadLogger m) => SqlWriteT m () updateJoao = update $ \p -> do @@ -123,7 +134,7 @@ updateJoao = ------------------------------------------------------------------------------- -deleteYoungsters :: (MonadIO m) +deleteYoungsters :: (MonadIO m, MonadLogger m) => SqlWriteT m () deleteYoungsters = do delete $ @@ -132,7 +143,7 @@ deleteYoungsters = do ------------------------------------------------------------------------------- -insertBlogPosts :: (MonadIO m) +insertBlogPosts :: (MonadIO m, MonadLogger m) => SqlWriteT m () insertBlogPosts = insertSelect $ from $ \p -> @@ -140,8 +151,15 @@ insertBlogPosts = ------------------------------------------------------------------------------- -testDb :: (MonadIO m) - => SqlWriteT m () +cleanDB :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +cleanDB = do + rawExecute "DROP TABLE follow" [] + rawExecute "DROP TABLE blog_post" [] + rawExecute "DROP TABLE person" [] + +testDb :: (MonadIO m, MonadLogger m) + => SqlPersistT m () testDb = do john <- insert $ Person "John" (Just 24) sean <- insert $ Person "Seán" (Just 70) @@ -155,68 +173,49 @@ testDb = do ------------------------------------------------------------------------------- -main :: IO () -main = - let conn = (mkSqliteConnectionInfo ":memory:") & fkEnabled .~ True - in runSqliteInfo conn $ do - -- Run migrations to synchronise the databse - runMigration migrateAll +newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a } + deriving (Functor, Applicative, Monad, MonadLogger, MonadReader ConnectionString, MonadIO) - -- Initialise our test database +instance MonadTrans BlogT where + lift = BlogT . lift . lift + +deriving instance (MonadBase b m) => MonadBase b (BlogT m) + +instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where + type StM (BlogT m) a = ComposeSt BlogT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + +instance MonadTransControl BlogT where + type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a) + liftWith f = BlogT $ liftWith $ \run -> + liftWith $ \run' -> + f (run' . run . unBlogT) + restoreT = BlogT . restoreT . restoreT + + +runBlogT :: ConnectionString -> BlogT m a -> m a +runBlogT backend (BlogT m) = + runReaderT (runNoLoggingT m) backend + +type Blog a = BlogT IO a + +runDB :: (MonadReader ConnectionString m, MonadIO m, MonadBaseControl IO m, Monad m, MonadLogger m) + => SqlPersistT m a -> m a +runDB query = do + conn <- ask + withPostgresqlConn conn $ \backend -> runReaderT query backend + +setupBlog :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +setupBlog = do + runMigration migrateAll testDb - -- Print the names of our Persons - putPersons - - printMessage "Listing all the people with the name John:" - printMessage "===============================================" - getJohns >>= printVals - printMessage "===============================================" - - printMessage "Listing all people of the age 18 or over" - printMessage "===============================================" - getAdults >>= printVals - printMessage "===============================================" - - printMessage "Listing all Blog Posts and their Authors" - printMessage "===============================================" - getBlogPostsByAuthors >>= printVals2 - printMessage "===============================================" - - printMessage "Listing all Authors and their possible Blog Posts" - printMessage "===============================================" - getAuthorMaybePosts >>= mapM_ print' - printMessage "===============================================" - - printMessage "Listing all mutual Followers" - printMessage "===============================================" - followers >>= mapM_ print' - printMessage "===============================================" - - printMessage "Updating Jaoa and checking the update" - printMessage "===============================================" - updateJoao - getJaoas >>= printVals - printMessage "===============================================" - - printMessage "Deleting poor Jaoa because he is too young" - printMessage "===============================================" - deleteYoungsters - getJaoas >>= printVals - printMessage "===============================================" - where - -- | Helper for print Text and getting rid of pesky warnings to default - -- | literals to [Char] - printMessage :: (MonadIO m) => Text -> m () - printMessage = liftIO . print - - -- | Helper function for printing in our DB environment - print' :: (MonadIO m, Show a) => a -> m () - print' = liftIO . print - - -- | Helper to extract the entity values and print each one - printVals = liftIO . mapM_ (print . entityVal) - - -- | TODO: Scrap this for something better - printVals2 = liftIO . mapM_ (print . both entityVal entityVal) - both f g (a, b) = (f a, g b) +main :: IO () +main = + let connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***" + in runBlogT connection . runDB $ do + setupBlog + putPersons + cleanDB diff --git a/examples/package.yaml b/examples/package.yaml index 2b45ac5..605a195 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -13,9 +13,13 @@ dependencies: - esqueleto - persistent - persistent-template -- persistent-sqlite +- persistent-postgresql - text - microlens +- mtl +- monad-logger +- monad-control +- transformers-base ghc-options: - -Wall - -threaded From cbb69420f0298569aeb4445791eabfe5b1a80a0a Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sat, 22 Jul 2017 17:16:11 +0100 Subject: [PATCH 4/6] Separated BlogT Monad into its own file and renaming the main to Main.hs --- examples/Blog.hs | 189 +++------------------------------------ examples/Main.hs | 201 ++++++++++++++++++++++++++++++++++++++++++ examples/package.yaml | 2 +- 3 files changed, 214 insertions(+), 178 deletions(-) create mode 100644 examples/Main.hs diff --git a/examples/Blog.hs b/examples/Blog.hs index 1dd0fbc..38ecc05 100644 --- a/examples/Blog.hs +++ b/examples/Blog.hs @@ -1,191 +1,47 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Main - ( main +module Blog + ( runBlogT ) where ------------------------------------------------------------------------------- -import Control.Monad (void) import Control.Monad.Base (MonadBase (..)) -import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger, NoLoggingT (..)) import Control.Monad.Reader import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), defaultLiftBaseWith, defaultRestoreM) -import Data.Text (Text) -import Database.Esqueleto -import Database.Persist.Postgresql (ConnectionString, - withPostgresqlConn) -import Database.Persist.TH (mkDeleteCascade, mkMigrate, - mkPersist, persistLowerCase, - share, sqlSettings) -import Lens.Micro ((&), (.~)) +import Database.Persist.Postgresql (ConnectionString) ------------------------------------------------------------------------------- -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| - Person - name String - age Int Maybe - deriving Eq Show - BlogPost - title String - authorId PersonId - deriving Eq Show - Follow - follower PersonId - followed PersonId - deriving Eq Show -|] - - -------------------------------------------------------------------------------- -putPersons :: (MonadIO m, MonadLogger m) - => SqlPersistT m () -putPersons = do - people <- select $ - from $ \person -> do - return person - liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people - - -------------------------------------------------------------------------------- -getJohns :: (MonadIO m, MonadLogger m) - => SqlReadT m [Entity Person] -getJohns = - select $ - from $ \p -> do - where_ (p ^. PersonName ==. val "John") - return p - - -------------------------------------------------------------------------------- -getJaoas :: (MonadIO m, MonadLogger m) - => SqlReadT m [Entity Person] -getJaoas = - select $ - from $ \p -> do - where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") - return p - - -------------------------------------------------------------------------------- -getAdults :: (MonadIO m, MonadLogger m) - => SqlReadT m [Entity Person] -getAdults = - select $ - from $ \p -> do - where_ (p ^. PersonAge >=. just (val 18)) - return p - - -------------------------------------------------------------------------------- -getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) - => SqlReadT m [(Entity BlogPost, Entity Person)] -getBlogPostsByAuthors = - select $ - from $ \(b, p) -> do - where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) - orderBy [asc (b ^. BlogPostTitle)] - return (b, p) - - -------------------------------------------------------------------------------- -getAuthorMaybePosts :: (MonadIO m, MonadLogger m) - => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] -getAuthorMaybePosts = - select $ - from $ \(p `LeftOuterJoin` mb) -> do - on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) - orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] - return (p, mb) - - -------------------------------------------------------------------------------- -followers :: (MonadIO m, MonadLogger m) - => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] -followers = - select $ - from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do - on (p2 ^. PersonId ==. f ^. FollowFollowed) - on (p1 ^. PersonId ==. f ^. FollowFollower) - return (p1, f, p2) - - -------------------------------------------------------------------------------- -updateJoao :: (MonadIO m, MonadLogger m) - => SqlWriteT m () -updateJoao = - update $ \p -> do - set p [ PersonName =. val "João" ] - where_ (p ^. PersonName ==. val "Joao") - - -------------------------------------------------------------------------------- -deleteYoungsters :: (MonadIO m, MonadLogger m) - => SqlWriteT m () -deleteYoungsters = do - delete $ - from $ \p -> do - where_ (p ^. PersonAge <. just (val 14)) - - -------------------------------------------------------------------------------- -insertBlogPosts :: (MonadIO m, MonadLogger m) - => SqlWriteT m () -insertBlogPosts = - insertSelect $ from $ \p -> - return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) - - -------------------------------------------------------------------------------- -cleanDB :: (MonadIO m, MonadLogger m) - => SqlPersistT m () -cleanDB = do - rawExecute "DROP TABLE follow" [] - rawExecute "DROP TABLE blog_post" [] - rawExecute "DROP TABLE person" [] - -testDb :: (MonadIO m, MonadLogger m) - => SqlPersistT m () -testDb = do - john <- insert $ Person "John" (Just 24) - sean <- insert $ Person "Seán" (Just 70) - joao <- insert $ Person "Joao" (Just 13) - void $ insertMany [ BlogPost "How to play a bodhrán" sean - , BlogPost "Haskell for the working class hero" john - ] - void $ insert $ Follow john sean - void $ insert $ Follow sean john - void $ insert $ Follow joao sean - - -------------------------------------------------------------------------------- newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a } deriving (Functor, Applicative, Monad, MonadLogger, MonadReader ConnectionString, MonadIO) + +------------------------------------------------------------------------------- instance MonadTrans BlogT where lift = BlogT . lift . lift + +------------------------------------------------------------------------------- deriving instance (MonadBase b m) => MonadBase b (BlogT m) + +------------------------------------------------------------------------------- instance MonadBaseControl b m => MonadBaseControl b (BlogT m) where type StM (BlogT m) a = ComposeSt BlogT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM + +------------------------------------------------------------------------------- instance MonadTransControl BlogT where type StT BlogT a = StT NoLoggingT (StT (ReaderT ConnectionString) a) liftWith f = BlogT $ liftWith $ \run -> @@ -194,28 +50,7 @@ instance MonadTransControl BlogT where restoreT = BlogT . restoreT . restoreT +------------------------------------------------------------------------------- runBlogT :: ConnectionString -> BlogT m a -> m a runBlogT backend (BlogT m) = runReaderT (runNoLoggingT m) backend - -type Blog a = BlogT IO a - -runDB :: (MonadReader ConnectionString m, MonadIO m, MonadBaseControl IO m, Monad m, MonadLogger m) - => SqlPersistT m a -> m a -runDB query = do - conn <- ask - withPostgresqlConn conn $ \backend -> runReaderT query backend - -setupBlog :: (MonadIO m, MonadLogger m) - => SqlPersistT m () -setupBlog = do - runMigration migrateAll - testDb - -main :: IO () -main = - let connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***" - in runBlogT connection . runDB $ do - setupBlog - putPersons - cleanDB diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 index 0000000..8bc0ee0 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main + ( main + ) where + +------------------------------------------------------------------------------- +import Blog +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Logger (MonadLogger) +import Control.Monad.Reader (MonadReader (..), runReaderT) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Database.Esqueleto +import Database.Persist.Postgresql (ConnectionString, + withPostgresqlConn) +import Database.Persist.TH (mkDeleteCascade, mkMigrate, + mkPersist, persistLowerCase, + share, sqlSettings) +import Lens.Micro ((&), (.~)) +------------------------------------------------------------------------------- + + +share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + Person + name String + age Int Maybe + deriving Eq Show + BlogPost + title String + authorId PersonId + deriving Eq Show + Follow + follower PersonId + followed PersonId + deriving Eq Show +|] + + +------------------------------------------------------------------------------- +putPersons :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +putPersons = do + people <- select $ + from $ \person -> do + return person + liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people + + +------------------------------------------------------------------------------- +getJohns :: (MonadIO m, MonadLogger m) + => SqlReadT m [Entity Person] +getJohns = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "John") + return p + + +------------------------------------------------------------------------------- +getJaoas :: (MonadIO m, MonadLogger m) + => SqlReadT m [Entity Person] +getJaoas = + select $ + from $ \p -> do + where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") + return p + + +------------------------------------------------------------------------------- +getAdults :: (MonadIO m, MonadLogger m) + => SqlReadT m [Entity Person] +getAdults = + select $ + from $ \p -> do + where_ (p ^. PersonAge >=. just (val 18)) + return p + + +------------------------------------------------------------------------------- +getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) + => SqlReadT m [(Entity BlogPost, Entity Person)] +getBlogPostsByAuthors = + select $ + from $ \(b, p) -> do + where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) + orderBy [asc (b ^. BlogPostTitle)] + return (b, p) + + +------------------------------------------------------------------------------- +getAuthorMaybePosts :: (MonadIO m, MonadLogger m) + => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] +getAuthorMaybePosts = + select $ + from $ \(p `LeftOuterJoin` mb) -> do + on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) + orderBy [asc (p ^. PersonName), asc (mb ?. BlogPostTitle)] + return (p, mb) + + +------------------------------------------------------------------------------- +followers :: (MonadIO m, MonadLogger m) + => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] +followers = + select $ + from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do + on (p2 ^. PersonId ==. f ^. FollowFollowed) + on (p1 ^. PersonId ==. f ^. FollowFollower) + return (p1, f, p2) + + +------------------------------------------------------------------------------- +updateJoao :: (MonadIO m, MonadLogger m) + => SqlWriteT m () +updateJoao = + update $ \p -> do + set p [ PersonName =. val "João" ] + where_ (p ^. PersonName ==. val "Joao") + + +------------------------------------------------------------------------------- +deleteYoungsters :: (MonadIO m, MonadLogger m) + => SqlWriteT m () +deleteYoungsters = do + delete $ + from $ \p -> do + where_ (p ^. PersonAge <. just (val 14)) + + +------------------------------------------------------------------------------- +insertBlogPosts :: (MonadIO m, MonadLogger m) + => SqlWriteT m () +insertBlogPosts = + insertSelect $ from $ \p -> + return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) + + +------------------------------------------------------------------------------- +runDB :: (MonadReader ConnectionString m, + MonadIO m, + MonadBaseControl IO m, + MonadLogger m) + => SqlPersistT m a -> m a +runDB query = do + conn <- ask + withPostgresqlConn conn $ \backend -> runReaderT query backend + + +------------------------------------------------------------------------------- +setupDb :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +setupDb = do + runMigration migrateAll + createDb + where + createDb :: (MonadIO m, MonadLogger m) + => SqlPersistT m () + createDb = do + john <- insert $ Person "John" (Just 24) + sean <- insert $ Person "Seán" (Just 70) + joao <- insert $ Person "Joao" (Just 13) + void $ insertMany [ BlogPost "How to play a bodhrán" sean + , BlogPost "Haskell for the working class hero" john + ] + void $ insert $ Follow john sean + void $ insert $ Follow sean john + void $ insert $ Follow joao sean + + +------------------------------------------------------------------------------- +cleanDb :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +cleanDb = do + dropTable "follow" + dropTable "blog_post" + dropTable "person" + where + dropTable tableName = rawExecute ("DROP TABLE " <> tableName) [] + + +------------------------------------------------------------------------------- +main :: IO () +main = + let connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***" + in runBlogT connection . runDB $ do + setupDb + putPersons + cleanDb diff --git a/examples/package.yaml b/examples/package.yaml index 605a195..153be64 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -31,7 +31,7 @@ when: executables: blog-example: - main: Blog.hs + main: Main.hs flags: werror: From 9fc64131b02f5f294393db9da902edd32cfc9b1b Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sat, 22 Jul 2017 18:09:13 +0100 Subject: [PATCH 5/6] Added comments and cleaned up some code --- examples/Main.hs | 63 ++++++++++++++++++++++++++++++++----------- examples/package.yaml | 2 -- 2 files changed, 47 insertions(+), 18 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 8bc0ee0..5c85cf3 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -8,7 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} module Main ( main @@ -22,14 +22,12 @@ import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader (..), runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Monoid ((<>)) -import Data.Text (Text) import Database.Esqueleto import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn) import Database.Persist.TH (mkDeleteCascade, mkMigrate, mkPersist, persistLowerCase, share, sqlSettings) -import Lens.Micro ((&), (.~)) ------------------------------------------------------------------------------- @@ -53,9 +51,13 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll putPersons :: (MonadIO m, MonadLogger m) => SqlPersistT m () putPersons = do + -- | Select all values from the `person` table people <- select $ from $ \person -> do return person + + -- | entityVal extracts the Person value, which we then extract + -- | the person name from the record and print it liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people @@ -63,26 +65,18 @@ putPersons = do getJohns :: (MonadIO m, MonadLogger m) => SqlReadT m [Entity Person] getJohns = + -- | Select all persons where their name is equal to "John" select $ from $ \p -> do where_ (p ^. PersonName ==. val "John") return p -------------------------------------------------------------------------------- -getJaoas :: (MonadIO m, MonadLogger m) - => SqlReadT m [Entity Person] -getJaoas = - select $ - from $ \p -> do - where_ (p ^. PersonName ==. val "João" ||. p ^. PersonName ==. val "Joao") - return p - - ------------------------------------------------------------------------------- getAdults :: (MonadIO m, MonadLogger m) => SqlReadT m [Entity Person] getAdults = + -- | Select any Person where their age is >= 18 and NOT NULL select $ from $ \p -> do where_ (p ^. PersonAge >=. just (val 18)) @@ -93,6 +87,7 @@ getAdults = getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity BlogPost, Entity Person)] getBlogPostsByAuthors = + -- | Select all persons and their blogposts, ordering by title select $ from $ \(b, p) -> do where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) @@ -104,6 +99,9 @@ getBlogPostsByAuthors = getAuthorMaybePosts :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] getAuthorMaybePosts = + -- | Select all persons doing a left outer join on blogposts + -- | Since a person may not have any blogposts the BlogPost Entity is wrapped + -- | in a Maybe select $ from $ \(p `LeftOuterJoin` mb) -> do on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) @@ -115,6 +113,10 @@ getAuthorMaybePosts = followers :: (MonadIO m, MonadLogger m) => SqlReadT m [(Entity Person, Entity Follow, Entity Person)] followers = + -- | Select mutual follow relationships + -- | Note carefully that the order of the ON clauses is reversed! + -- | You're required to write your ons in reverse order because that helps composability + -- | (see the documentation of on for more details). select $ from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do on (p2 ^. PersonId ==. f ^. FollowFollowed) @@ -126,6 +128,7 @@ followers = updateJoao :: (MonadIO m, MonadLogger m) => SqlWriteT m () updateJoao = + -- Update the name of any Joao in our person table to João update $ \p -> do set p [ PersonName =. val "João" ] where_ (p ^. PersonName ==. val "Joao") @@ -135,6 +138,7 @@ updateJoao = deleteYoungsters :: (MonadIO m, MonadLogger m) => SqlWriteT m () deleteYoungsters = do + -- | Delete any persons under the age of 14 delete $ from $ \p -> do where_ (p ^. PersonAge <. just (val 14)) @@ -144,6 +148,7 @@ deleteYoungsters = do insertBlogPosts :: (MonadIO m, MonadLogger m) => SqlWriteT m () insertBlogPosts = + -- | Insert a new blogpost for every person insertSelect $ from $ \p -> return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) @@ -155,6 +160,7 @@ runDB :: (MonadReader ConnectionString m, MonadLogger m) => SqlPersistT m a -> m a runDB query = do + -- | Helper for running a query conn <- ask withPostgresqlConn conn $ \backend -> runReaderT query backend @@ -163,6 +169,7 @@ runDB query = do setupDb :: (MonadIO m, MonadLogger m) => SqlPersistT m () setupDb = do + -- | Run migrations and create the test database entries runMigration migrateAll createDb where @@ -184,6 +191,7 @@ setupDb = do cleanDb :: (MonadIO m, MonadLogger m) => SqlPersistT m () cleanDb = do + -- | Drop the tables so we can re-run the script again if needed dropTable "follow" dropTable "blog_post" dropTable "person" @@ -193,9 +201,32 @@ cleanDb = do ------------------------------------------------------------------------------- main :: IO () -main = - let connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***" - in runBlogT connection . runDB $ do +main = do + -- Connection string for the postrgesql database + runBlogT connection . runDB $ do setupDb putPersons + + johns <- getJohns + mapM_ say johns + + adults <- getAdults + mapM_ say adults + + authorBlogPosts <- getBlogPostsByAuthors + mapM_ say authorBlogPosts + + authoMaybePosts <- getAuthorMaybePosts + mapM_ say authoMaybePosts + + mutualFollowers <- followers + mapM_ say mutualFollowers + + updateJoao + deleteYoungsters + insertBlogPosts cleanDb + where + say :: (MonadIO m, Show a) => a -> m () + say = liftIO . print + connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=Leon93" diff --git a/examples/package.yaml b/examples/package.yaml index 153be64..b6b1c96 100644 --- a/examples/package.yaml +++ b/examples/package.yaml @@ -14,8 +14,6 @@ dependencies: - persistent - persistent-template - persistent-postgresql -- text -- microlens - mtl - monad-logger - monad-control From de2d9f8a0bd0aeb0b19eafb16c64be8fd2071e64 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Sun, 23 Jul 2017 23:49:34 +0100 Subject: [PATCH 6/6] Got a working example of cascading delete but it requires a select followed by a delete --- examples/Main.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/examples/Main.hs b/examples/Main.hs index 5c85cf3..e9d63f6 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -17,6 +18,7 @@ module Main ------------------------------------------------------------------------------- import Blog import Control.Monad (void) +import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (MonadLogger) import Control.Monad.Reader (MonadReader (..), runReaderT) @@ -31,7 +33,9 @@ import Database.Persist.TH (mkDeleteCascade, mkMigrate, ------------------------------------------------------------------------------- -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +share [ mkPersist sqlSettings + , mkDeleteCascade sqlSettings + , mkMigrate "migrateAll"] [persistLowerCase| Person name String age Int Maybe @@ -136,12 +140,18 @@ updateJoao = ------------------------------------------------------------------------------- deleteYoungsters :: (MonadIO m, MonadLogger m) - => SqlWriteT m () + => SqlPersistT m () deleteYoungsters = do -- | Delete any persons under the age of 14 - delete $ + + -- | In this case where `ON DELETE CASCADE` is not generated by migration + -- | we select all the entities we want to delete and then for each one + -- | one we extract the key and use Persistent's `deleteCascade` + youngsters <- select $ from $ \p -> do where_ (p ^. PersonAge <. just (val 14)) + pure p + forM_ youngsters (deleteCascade . entityKey) ------------------------------------------------------------------------------- @@ -198,7 +208,6 @@ cleanDb = do where dropTable tableName = rawExecute ("DROP TABLE " <> tableName) [] - ------------------------------------------------------------------------------- main :: IO () main = do @@ -229,4 +238,4 @@ main = do where say :: (MonadIO m, Show a) => a -> m () say = liftIO . print - connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=Leon93" + connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***"