diff --git a/examples/Blog.hs b/examples/Blog.hs new file mode 100644 index 0000000..38ecc05 --- /dev/null +++ b/examples/Blog.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Blog + ( runBlogT + ) where + +------------------------------------------------------------------------------- +import Control.Monad.Base (MonadBase (..)) +import Control.Monad.Logger (MonadLogger, NoLoggingT (..)) +import Control.Monad.Reader +import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), + MonadTransControl (..), + defaultLiftBaseWith, + defaultRestoreM) +import Database.Persist.Postgresql (ConnectionString) +------------------------------------------------------------------------------- + + +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 -> + 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 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/Main.hs b/examples/Main.hs new file mode 100644 index 0000000..e9d63f6 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Main + ( main + ) where + +------------------------------------------------------------------------------- +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) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Monoid ((<>)) +import Database.Esqueleto +import Database.Persist.Postgresql (ConnectionString, + withPostgresqlConn) +import Database.Persist.TH (mkDeleteCascade, mkMigrate, + mkPersist, persistLowerCase, + share, sqlSettings) +------------------------------------------------------------------------------- + + +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 + -- | 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 + + +------------------------------------------------------------------------------- +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 + + +------------------------------------------------------------------------------- +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)) + return p + + +------------------------------------------------------------------------------- +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) + orderBy [asc (b ^. BlogPostTitle)] + return (b, p) + + +------------------------------------------------------------------------------- +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) + 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 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) + on (p1 ^. PersonId ==. f ^. FollowFollower) + return (p1, f, p2) + + +------------------------------------------------------------------------------- +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") + + +------------------------------------------------------------------------------- +deleteYoungsters :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +deleteYoungsters = do + -- | Delete any persons under the age of 14 + + -- | 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) + + +------------------------------------------------------------------------------- +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) + + +------------------------------------------------------------------------------- +runDB :: (MonadReader ConnectionString m, + MonadIO m, + MonadBaseControl IO m, + MonadLogger m) + => SqlPersistT m a -> m a +runDB query = do + -- | Helper for running a query + conn <- ask + withPostgresqlConn conn $ \backend -> runReaderT query backend + + +------------------------------------------------------------------------------- +setupDb :: (MonadIO m, MonadLogger m) + => SqlPersistT m () +setupDb = do + -- | Run migrations and create the test database entries + 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 + -- | Drop the tables so we can re-run the script again if needed + dropTable "follow" + dropTable "blog_post" + dropTable "person" + where + dropTable tableName = rawExecute ("DROP TABLE " <> tableName) [] + +------------------------------------------------------------------------------- +main :: IO () +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=***" 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..b6b1c96 --- /dev/null +++ b/examples/package.yaml @@ -0,0 +1,38 @@ +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-postgresql +- mtl +- monad-logger +- monad-control +- transformers-base +ghc-options: +- -Wall +- -threaded +- -rtsopts +- -with-rtsopts=-N +when: +- condition: flag(werror) + ghc-options: -Werror + +executables: + blog-example: + main: Main.hs + +flags: + werror: + description: "Treat warnings as errors" + manual: true + default: false