Added comments and cleaned up some code

This commit is contained in:
Fintan Halpenny 2017-07-22 18:09:13 +01:00
parent cbb69420f0
commit 9fc64131b0
2 changed files with 47 additions and 18 deletions

View File

@ -8,7 +8,7 @@
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
module Main module Main
( main ( main
@ -22,14 +22,12 @@ import Control.Monad.Logger (MonadLogger)
import Control.Monad.Reader (MonadReader (..), runReaderT) import Control.Monad.Reader (MonadReader (..), runReaderT)
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text)
import Database.Esqueleto import Database.Esqueleto
import Database.Persist.Postgresql (ConnectionString, import Database.Persist.Postgresql (ConnectionString,
withPostgresqlConn) withPostgresqlConn)
import Database.Persist.TH (mkDeleteCascade, mkMigrate, import Database.Persist.TH (mkDeleteCascade, mkMigrate,
mkPersist, persistLowerCase, mkPersist, persistLowerCase,
share, sqlSettings) share, sqlSettings)
import Lens.Micro ((&), (.~))
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -53,9 +51,13 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
putPersons :: (MonadIO m, MonadLogger m) putPersons :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
putPersons = do putPersons = do
-- | Select all values from the `person` table
people <- select $ people <- select $
from $ \person -> do from $ \person -> do
return person 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 liftIO $ mapM_ (putStrLn . ("Name: " ++) . personName . entityVal) people
@ -63,26 +65,18 @@ putPersons = do
getJohns :: (MonadIO m, MonadLogger m) getJohns :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getJohns = getJohns =
-- | Select all persons where their name is equal to "John"
select $ select $
from $ \p -> do from $ \p -> do
where_ (p ^. PersonName ==. val "John") where_ (p ^. PersonName ==. val "John")
return p 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) getAdults :: (MonadIO m, MonadLogger m)
=> SqlReadT m [Entity Person] => SqlReadT m [Entity Person]
getAdults = getAdults =
-- | Select any Person where their age is >= 18 and NOT NULL
select $ select $
from $ \p -> do from $ \p -> do
where_ (p ^. PersonAge >=. just (val 18)) where_ (p ^. PersonAge >=. just (val 18))
@ -93,6 +87,7 @@ getAdults =
getBlogPostsByAuthors :: (MonadIO m, MonadLogger m) getBlogPostsByAuthors :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity BlogPost, Entity Person)] => SqlReadT m [(Entity BlogPost, Entity Person)]
getBlogPostsByAuthors = getBlogPostsByAuthors =
-- | Select all persons and their blogposts, ordering by title
select $ select $
from $ \(b, p) -> do from $ \(b, p) -> do
where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) where_ (b ^. BlogPostAuthorId ==. p ^. PersonId)
@ -104,6 +99,9 @@ getBlogPostsByAuthors =
getAuthorMaybePosts :: (MonadIO m, MonadLogger m) getAuthorMaybePosts :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity Person, Maybe (Entity BlogPost))] => SqlReadT m [(Entity Person, Maybe (Entity BlogPost))]
getAuthorMaybePosts = 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 $ select $
from $ \(p `LeftOuterJoin` mb) -> do from $ \(p `LeftOuterJoin` mb) -> do
on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId) on (just (p ^. PersonId) ==. mb ?. BlogPostAuthorId)
@ -115,6 +113,10 @@ getAuthorMaybePosts =
followers :: (MonadIO m, MonadLogger m) followers :: (MonadIO m, MonadLogger m)
=> SqlReadT m [(Entity Person, Entity Follow, Entity Person)] => SqlReadT m [(Entity Person, Entity Follow, Entity Person)]
followers = 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 $ select $
from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do from $ \(p1 `InnerJoin` f `InnerJoin` p2) -> do
on (p2 ^. PersonId ==. f ^. FollowFollowed) on (p2 ^. PersonId ==. f ^. FollowFollowed)
@ -126,6 +128,7 @@ followers =
updateJoao :: (MonadIO m, MonadLogger m) updateJoao :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
updateJoao = updateJoao =
-- Update the name of any Joao in our person table to João
update $ \p -> do update $ \p -> do
set p [ PersonName =. val "João" ] set p [ PersonName =. val "João" ]
where_ (p ^. PersonName ==. val "Joao") where_ (p ^. PersonName ==. val "Joao")
@ -135,6 +138,7 @@ updateJoao =
deleteYoungsters :: (MonadIO m, MonadLogger m) deleteYoungsters :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
deleteYoungsters = do deleteYoungsters = do
-- | Delete any persons under the age of 14
delete $ delete $
from $ \p -> do from $ \p -> do
where_ (p ^. PersonAge <. just (val 14)) where_ (p ^. PersonAge <. just (val 14))
@ -144,6 +148,7 @@ deleteYoungsters = do
insertBlogPosts :: (MonadIO m, MonadLogger m) insertBlogPosts :: (MonadIO m, MonadLogger m)
=> SqlWriteT m () => SqlWriteT m ()
insertBlogPosts = insertBlogPosts =
-- | Insert a new blogpost for every person
insertSelect $ from $ \p -> insertSelect $ from $ \p ->
return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId) return $ BlogPost <# (val "Group Blog Post") <&> (p ^. PersonId)
@ -155,6 +160,7 @@ runDB :: (MonadReader ConnectionString m,
MonadLogger m) MonadLogger m)
=> SqlPersistT m a -> m a => SqlPersistT m a -> m a
runDB query = do runDB query = do
-- | Helper for running a query
conn <- ask conn <- ask
withPostgresqlConn conn $ \backend -> runReaderT query backend withPostgresqlConn conn $ \backend -> runReaderT query backend
@ -163,6 +169,7 @@ runDB query = do
setupDb :: (MonadIO m, MonadLogger m) setupDb :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
setupDb = do setupDb = do
-- | Run migrations and create the test database entries
runMigration migrateAll runMigration migrateAll
createDb createDb
where where
@ -184,6 +191,7 @@ setupDb = do
cleanDb :: (MonadIO m, MonadLogger m) cleanDb :: (MonadIO m, MonadLogger m)
=> SqlPersistT m () => SqlPersistT m ()
cleanDb = do cleanDb = do
-- | Drop the tables so we can re-run the script again if needed
dropTable "follow" dropTable "follow"
dropTable "blog_post" dropTable "blog_post"
dropTable "person" dropTable "person"
@ -193,9 +201,32 @@ cleanDb = do
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
main :: IO () main :: IO ()
main = main = do
let connection = "host=localhost port=5433 user=postgres dbname=esqueleto_blog_example password=***" -- Connection string for the postrgesql database
in runBlogT connection . runDB $ do runBlogT connection . runDB $ do
setupDb setupDb
putPersons 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 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"

View File

@ -14,8 +14,6 @@ dependencies:
- persistent - persistent
- persistent-template - persistent-template
- persistent-postgresql - persistent-postgresql
- text
- microlens
- mtl - mtl
- monad-logger - monad-logger
- monad-control - monad-control