some Yesod / Persistent examples

examples.cabal

library
  hs-source-dirs:      src
  exposed-modules:     Lib, Lib2
  build-depends:       base >= 4.7 && < 5, persistent, persistent-sqlite, transformers, persistent-template, time
  default-language:    Haskell2010

Lib.hs

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}

module Lib where
import           Control.Monad.IO.Class  (liftIO)
import           Database.Persist
import           Database.Persist.Sqlite
import           Database.Persist.TH

someFunc :: IO ()
someFunc = putStrLn "someFunc"

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

main1 :: IO ()
main1 = runSqlite ":memory:" $ do
    runMigration migrateAll
    michaelId <- insert $ Person "Michael" $ Just 26
    michael <- get michaelId
    liftIO $ print michael

main2 :: IO ()
main2 = 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]

Lib2.hs

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-- LANGUAGE NoMonomorphismRestriction  #-}
{-# LANGUAGE RankNTypes #-}

module Lib2 where

import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Data.Time
import Control.Monad.IO.Class (liftIO)
import Data.List (lookup)

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Person
    firstName String
    lastName String
    age Int
    PersonName firstName lastName
    deriving Show
|]

resultsForPage pageNumber = do
    let resultsPerPage = 10
    selectList
        [ PersonAge >=. 18
        ]
        [ Desc PersonAge
        , Asc PersonLastName
        , Asc PersonFirstName
        , LimitTo resultsPerPage
        , OffsetBy $ (pageNumber - 1) * resultsPerPage
        ]

foo = [ Desc PersonAge] :: [SelectOpt Person]

makeSelectOpt :: (Char,Char) -> SelectOpt Person
makeSelectOpt ('f','+') = Asc  PersonFirstName
makeSelectOpt ('f','-') = Desc PersonFirstName
makeSelectOpt ('l','+') = Asc  PersonLastName
makeSelectOpt ('l','-') = Desc PersonFirstName
makeSelectOpt ('a','+') = Asc  PersonAge
makeSelectOpt ('a','-') = Desc PersonAge

makeSelections :: [(Char,Char)] -> [SelectOpt Person]
makeSelections = map makeSelectOpt

updown '+' = Asc
updown _   = Desc

makeSelectOpt' :: (Char,Char) -> SelectOpt Person
makeSelectOpt' ('f',dir)  = updown dir $ PersonFirstName
makeSelectOpt' ('l',dir)  = updown dir $ PersonLastName
makeSelectOpt' ('a',dir)  = updown dir $ PersonAge

-- funcs = [ (\d -> d PersonFirstName), (\d -> d PersonLastName), (\d -> d PersonAge) ]

type ApplyToField = (forall t. EntityField Person t -> SelectOpt Person) -> SelectOpt Person

applyToFirstName, applyToLastName, applyToAge :: ApplyToField
applyToFirstName d = d PersonFirstName
applyToLastName d  = d PersonFirstName
applyToAge     d   = d PersonAge


makeSelectOpt''' :: (Char,Char) -> SelectOpt Person
makeSelectOpt''' (fld,d) = fn (updown d) 
  where
    table = [ ('f',applyToFirstName), ('l',applyToLastName), ('a',applyToAge) ]
    fn = case lookup fld table of
           Just f -> f
           Nothing -> error "bad field spec"

main :: IO ()
main = runSqlite ":memory:" $ do
    runMigration migrateAll
    insert $ Person "Michael" "Snoyman" 26
    michael <- getBy $ PersonName "Michael" "Snoyman"
    liftIO $ print michael

    people <- selectList [PersonAge >. 25, PersonAge <=. 30] []
    liftIO $ print people