Merge pull request #40 from FintanH/examples

Examples

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

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.

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=***"

examples/README.md

@@ -0,0 +1,3 @@
+# Esqueleto Examples
+
+These examples can be build via `stack build`.

examples/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

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