Added comments and cleaned up some code
This commit is contained in:
parent
cbb69420f0
commit
9fc64131b0
@ -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"
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user