Chris Stryczynski

Software Developer / Consultant

email: chris@soundshare.co.uk

Haskell Persistent tutorial via GitChapter

Posted on: 14/12/2019

Introduction

This tutorial is written with GitChapter. This allows you to clone down the tutorial from https://github.com/chrissound/HaskellPersistentTutorial, and hack along from any chapter. You can checkout a specific chapter from any of the chapter commit references that are shown as:

Chapter offset

Start Commit: 
SHA: c22ab94b09f020344d44a4a6f7336e7f992f0a9f
Tag(s): gch-begin-1
-------
End commit: 
SHA: 1cfedcb7383853e5d2f5315078e3d7a61b420405
Tag(s): gch-end-1

I decided to learn the Haskell persistent library, and what better way to learn something, than write a tutorial in the midst! So here you go! Bit of an experiment from my part.

Lets begin! I’ve based off this tutorial from https://www.yesodweb.com/book/persistent which is released under https://creativecommons.org/licenses/by/4.0/ - which I’m very thankful for!

So we start off with a very simple example involving an in-memory sqlite database:

package.yaml

name: HaskellNixCabalStarter
version: '0.1.0.0'
author: HaskellNixCabalStarter
maintainer: HaskellNixCabalStarter
license: OtherLicense
dependencies:
- base >=4.12 && <4.13
- persistent
- persistent-sqlite
- persistent-template
executables:
  app:
    source-dirs: src
    main: Main.hs

Main.hs

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
import           Control.Monad.IO.Class  (liftIO)
import           Database.Persist
import           Database.Persist.Sqlite
import           Database.Persist.TH

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Person
    name String
    age Int Maybe
    deriving Show
BlogPost
    title String
    authorId PersonId
    deriving Show
|]

main :: IO ()
main = runSqlite ":memory:" $ do
    runMigration migrateAll

    johnId <- insert $ Person "John Doe" $ Just 35
    janeId <- insert $ Person "Jane Doe" Nothing

    insert $ BlogPost "My fr1st p0st" johnId
    insert $ BlogPost "One more for good measure" johnId

    oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1]
    liftIO $ print (oneJohnPost :: [Entity BlogPost])

    john <- get johnId
    liftIO $ print (john :: Maybe Person)

    delete janeId
    deleteWhere [BlogPostAuthorId ==. johnId]

Great so with the above setup we can run cabal run which outputs:

Resolving dependencies...
Build profile: -w ghc-8.6.5 -O1
In order, the following will be built (use -v for more details):
 - HaskellNixCabalStarter-0.1.0.0 (exe:app) (configuration changed)
Configuring executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Preprocessing executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Building executable 'app' for HaskellNixCabalStarter-0.1.0.0..
[1 of 2] Compiling Paths_HaskellNixCabalStarter ( /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/Paths_HaskellNixCabalStarter.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Paths_HaskellNixCabalStarter.o ) [/home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/cabal_macros.h changed]
[2 of 2] Compiling Main             ( src/Main.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Main.o )
Linking /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app ...
[Entity {entityKey = BlogPostKey {unBlogPostKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = BlogPost {blogPostTitle = "My fr1st p0st", blogPostAuthorId = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}}}]
Just (Person {personName = "John Doe", personAge = Just 35})

Switching to PostgreSQL

Chapter offset

Start Commit: 
SHA: 1cfedcb7383853e5d2f5315078e3d7a61b420405
Tag(s): gch-end-1
-------
End commit: 
SHA: 20c03034e9579196d5af677887d4738d55d0671d
Tag(s): gch-begin-2,gch-end-2

We can setup a simple postgres database with the following docker-compose config:

version: '3'
services:
  adminer:
    image: "adminer"
    ports:
      - 8080:8080
  database:
    image: "postgres:alpine"
    ports:
     - "5432:5432"
    environment:
      - POSTGRES_PASSWORD=mysecretpassword
    volumes:
      - ./_data2/:/var/lib/postgresql/data
diff --git a/package.yaml b/package.yaml
index 0f0679e..874fc0e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -7,7 +7,9 @@ dependencies:
 - base >=4.12 && <4.13
 - persistent
 - persistent-sqlite
+- persistent-postgresql
 - persistent-template
+- monad-logger
 executables:
   app:
     source-dirs: src

diff --git a/src/Main.hs b/src/Main.hs
index 7feb34b..0343c48 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -9,8 +9,10 @@
 {-# LANGUAGE TypeFamilies               #-}
 import           Control.Monad.IO.Class  (liftIO)
 import           Database.Persist
-import           Database.Persist.Sqlite
 import           Database.Persist.TH
+import           Database.Persist.Postgresql
+import           Control.Monad.IO.Class  (liftIO)
+import           Control.Monad.Logger    (runStderrLoggingT)
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 Person
@@ -23,21 +25,25 @@ BlogPost
     deriving Show
 |]
 
+dbConStr :: ConnectionString
+dbConStr = "host=127.0.0.1 port=5432 user=postgres dbname=postgres password=mysecretpassword"
+
 main :: IO ()
-main = runSqlite ":memory:" $ do
-    runMigration migrateAll
+main = runStderrLoggingT $ withPostgresqlPool dbConStr 10 $ \pool -> liftIO $ do
+    flip runSqlPersistMPool pool $ do
+      runMigration migrateAll
 
-    johnId <- insert $ Person "John Doe" $ Just 35
-    janeId <- insert $ Person "Jane Doe" Nothing
+      johnId <- insert $ Person "John Doe" $ Just 35
+      janeId <- insert $ Person "Jane Doe" Nothing
 
-    insert $ BlogPost "My fr1st p0st" johnId
-    insert $ BlogPost "One more for good measure" johnId
+      insert $ BlogPost "My fr1st p0st" johnId
+      insert $ BlogPost "One more for good measure" johnId
 
-    oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1]
-    liftIO $ print (oneJohnPost :: [Entity BlogPost])
+      oneJohnPost <- selectList [BlogPostAuthorId ==. johnId] [LimitTo 1]
+      liftIO $ print (oneJohnPost :: [Entity BlogPost])
 
-    john <- get johnId
-    liftIO $ print (john :: Maybe Person)
+      john <- get johnId
+      liftIO $ print (john :: Maybe Person)
 
-    delete janeId
-    deleteWhere [BlogPostAuthorId ==. johnId]
+      delete janeId
+      deleteWhere [BlogPostAuthorId ==. johnId]

Great so with the above setup we can run cabal run which outputs:

Resolving dependencies...
Build profile: -w ghc-8.6.5 -O1
In order, the following will be built (use -v for more details):
 - HaskellNixCabalStarter-0.1.0.0 (exe:app) (configuration changed)
Configuring executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Preprocessing executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Building executable 'app' for HaskellNixCabalStarter-0.1.0.0..
[1 of 2] Compiling Paths_HaskellNixCabalStarter ( /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/Paths_HaskellNixCabalStarter.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Paths_HaskellNixCabalStarter.o ) [/home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/cabal_macros.h changed]
[2 of 2] Compiling Main             ( src/Main.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Main.o )
Linking /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app ...
[Entity {entityKey = BlogPostKey {unBlogPostKey = SqlBackendKey {unSqlBackendKey = 13}}, entityVal = BlogPost {blogPostTitle = "My fr1st p0st", blogPostAuthorId = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 13}}}}]
Just (Person {personName = "John Doe", personAge = Just 35})

Real world example - updating a database record

Chapter offset

Start Commit: 
SHA: 20c03034e9579196d5af677887d4738d55d0671d
Tag(s): gch-begin-2,gch-end-2
-------
End commit: 
SHA: a843f457cbcb0136e03bb0725a3c1d172c53f8d3
Tag(s): gch-begin-3,gch-end-3

Lets try make a simple function, that takes an Int and returns a Maybe Person function.

So in the initiual tutorial they were using a get function… However looking this function up in the Hackage index for persistent-posgresql (http://hackage.haskell.org/package/persistent-postgresql-2.10.1/docs/doc-index-All.html) has no link suprisingly? Probably some type hackery of some sort going on… Grr

Oh no actually it’s just defined in the persistent hackage index (so maybe it’s re-exported?). http://hackage.haskell.org/package/persistent-2.10.4/docs/Database-Persist-Class.html#v:get

If we define a function as:

getUser :: Key Person -> ReaderT backend0 m0 ()
getUser x = do
  maybePerson <- get x
  case maybePerson of
      Nothing -> liftIO $ putStrLn "Just kidding, not really there"
      Just person -> liftIO $ print (person :: Person)

The above gives an error of:

    • Couldn't match type ‘BaseBackend backend0’ with 
‘SqlBackend’
        arising from a use of ‘get’
    • In a stmt of a 'do' block: maybePerson <- get x
      In the expression:
        do maybePerson <- get x
           case maybePerson of
             Nothing -> liftIO $ putStrLn "Just kidding, not 
really there"
             Just person -> liftIO $ print (person :: Person)

Googling this error shows up with a stackoverflow question I literally posted nearly 2+ years ago… (My last attempt with persistent ahem…)

Okay so taking the suggestion from stackoveflow we end up with:

getUser :: Key Person -> ReaderT SqlBackend m ()

Which errors with a missing monad instance for m… So filling those out we end up with:

getUser :: (MonadIO m) => Key Person -> ReaderT SqlBackend m ()

Yay!!! But wait we wanted an Int as input…

Hoogle shows 0 results for:

Int -> Key +persistent
Int -> Key +persistent-postgresql

A quick web search shows up with https://stackoverflow.com/questions/28068447/haskell-persistent-how-get-entity-from-db-by-key-if-i-have-key-in-integer-varia

Which points to use the following function:

http://www.stackage.org/haddock/lts-1.2/persistent-2.1.1.4/Database-Persist-Sql.html#v:toSqlKey

toSqlKey :: ToBackendKey SqlBackend record => Int64 -> Key record

AND FINALLY we end up with:

getUser :: (MonadIO m) => Int -> ReaderT SqlBackend m ()
getUser x = do
  maybePerson <- get $ toSqlKey x
  case maybePerson of
      Nothing -> liftIO $ putStrLn "Just kidding, not really there"
      Just person -> liftIO $ print (person :: Person)

Which errors with:

    • Couldn't match expected type ‘GHC.Int.Int64’
                  with actual type ‘Int’
    • In the first argument of ‘toSqlKey’, namely 
‘x’

Which we can use fromIntegral to fix, though I’m not 100% sure of any potential limitations due to it.

So to summarize this chapter we’ve ended up with:

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
import           Control.Monad.IO.Class  (liftIO)
import           Database.Persist
import           Database.Persist.TH
import           Database.Persist.Postgresql
import           Control.Monad.IO.Class  (liftIO)
import           Control.Monad.Logger    (runStderrLoggingT)
import Data.List (find)
import User
import Data.String


dbConStr :: ConnectionString
dbConStr = "host=127.0.0.1 port=5432 user=postgres dbname=postgres password=mysecretpassword"

main :: IO ()
main = do
  let input = [
          ("id", "1")
        , ("name", "Chris")
        , ("age", "100")
        ]
  let x = Person "" Nothing
  print x
  let inputId = case lookup "id" input of
        Just x -> read x
        Nothing -> error "no id specified"

  runStderrLoggingT $ withPostgresqlPool dbConStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
      runMigration migrateAll

      maybePerson <- getUser inputId
      liftIO $ print $ maybePerson
{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
module User where

import           Database.Persist
import           Database.Persist.TH
import           Database.Persist.Postgresql
import           Control.Monad.IO.Class  (liftIO)

import Control.Monad.Reader

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Person
    name String
    age Int Maybe
    deriving Show
BlogPost
    title String
    authorId PersonId
    deriving Show
|]

-- :: (MonadBaseControl IO m, MonadIO m, IsSqlBackend backend)  
-- => Text 

-- getUser :: Key Person -> ReaderT backend (NoLoggingT (ResourceT m)) a 
getUser :: (MonadIO m) => Int -> ReaderT SqlBackend m Person
getUser x = do
  maybePerson <- get $ toSqlKey $ fromIntegral x
  case maybePerson of
      Nothing -> error "Just kidding, not really there"
      Just person -> pure person
diff --git a/package.yaml b/package.yaml
index 874fc0e..09e53fe 100644
--- a/package.yaml
+++ b/package.yaml
@@ -10,6 +10,7 @@ dependencies:
 - persistent-postgresql
 - persistent-template
 - monad-logger
+- mtl
 executables:
   app:
     source-dirs: src

And the output from cabal run:

Resolving dependencies...
Build profile: -w ghc-8.6.5 -O1
In order, the following will be built (use -v for more details):
 - HaskellNixCabalStarter-0.1.0.0 (exe:app) (configuration changed)
Configuring executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Preprocessing executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Building executable 'app' for HaskellNixCabalStarter-0.1.0.0..
[1 of 3] Compiling Paths_HaskellNixCabalStarter ( /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/Paths_HaskellNixCabalStarter.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Paths_HaskellNixCabalStarter.o ) [/home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/autogen/cabal_macros.h changed]
[2 of 3] Compiling User             ( src/User.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/User.o )
[3 of 3] Compiling Main             ( src/Main.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Main.o )
Linking /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app ...
Person {personName = "", personAge = Nothing}
Person {personName = "John Doe", personAge = Just 35}

Real real world example - updating a database record

Okay lets try a real world example, updating a database record based on some user input (like something we’d get from a HTTP request).

To keep things simple we’ll just have a [(String,String)] input.

In order to update a record we need to use a “Query update combinators”. I’ll be using (https://hackage.haskell.org/package/persistent-2.10.4/docs/Database-Persist.html#v:-61-.)

(=.) :: forall v typ. PersistField typ => EntityField v typ -> typ -> Update v

And then with the following defined:

  usermapper :: String -> String -> Update Person
  usermapper "name" = (PersonName =.)
  usermapper "age" = (PersonAge =.) . Just . read
  usermapper _ = error "Invalid field"

We can use the above function as below, the important bits being:

  let input = [
          ("id", "1")
        , ("name", "Chris")
        , ("age", "100")
        ]

  let updates = fmap (\(a,b) -> usermapper a b) $ tail input

Nice and simple! So our Main.hs ends up with:

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
import           Control.Monad.IO.Class  (liftIO)
import           Database.Persist
import           Database.Persist.TH
import           Database.Persist.Postgresql
import           Control.Monad.IO.Class  (liftIO)
import           Control.Monad.Logger    (runStderrLoggingT)
import Data.List (find)
import User
import Data.String


dbConStr :: ConnectionString
dbConStr = "host=127.0.0.1 port=5432 user=postgres dbname=postgres password=mysecretpassword"

usermapper :: String -> String -> Update Person
usermapper "name" = (PersonName =.)
usermapper "age" = (PersonAge =.) . Just . read
usermapper _ = error "Invalid field"

main :: IO ()
main = do
  let input = [
          ("id", "1")
        , ("name", "Chris")
        , ("age", "100")
        ]
  let x = Person "" Nothing
  print x
  let inputId = case lookup "id" input of
        Just x -> read x
        Nothing -> error "no id specified"

  let updates = fmap (\(a,b) -> usermapper a b) $ tail input

  runStderrLoggingT $ withPostgresqlPool dbConStr 10 $ \pool -> liftIO $ do
    flip runSqlPersistMPool pool $ do
      runMigration migrateAll

      maybePerson <- getUser inputId
      liftIO $ print "Found user:"
      liftIO $ print $ maybePerson

      update (toSqlKey 10) updates

And the output from cabal run:

Build profile: -w ghc-8.6.5 -O1
In order, the following will be built (use -v for more details):
 - HaskellNixCabalStarter-0.1.0.0 (exe:app) (file src/Main.hs changed)
Preprocessing executable 'app' for HaskellNixCabalStarter-0.1.0.0..
Building executable 'app' for HaskellNixCabalStarter-0.1.0.0..
[3 of 3] Compiling Main             ( src/Main.hs, /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app-tmp/Main.o )
Linking /home/chris/NewProjects/HaskellTutorials/Persistent/dist-newstyle/build/x86_64-linux/ghc-8.6.5/HaskellNixCabalStarter-0.1.0.0/x/app/build/app/app ...
Person {personName = "", personAge = Nothing}
"Found user:"
Person {personName = "John Doe", personAge = Just 35}

Hopefully you’ve found this tutorial useful! Personally I’m happy to have finally gotten something simple working without battling the various types, something that scared me off from using persistent in the first place (and all those language extensions!).

Comments

No comments, yet!

Submit a comment


Github
Twitter
Youtube
Soundcloud
Stackoverflow
#!Dotfiles