81 lines
2.2 KiB
Haskell
81 lines
2.2 KiB
Haskell
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, TypeFamilies #-}
|
|
{-# LANGUAGE EmptyDataDecls, FlexibleContexts, GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
module Yesod.PersistSpec where
|
|
|
|
import Test.Hspec
|
|
import Database.Persist.Sqlite
|
|
import Network.Wai.Test
|
|
import Yesod.Core
|
|
import Data.Conduit
|
|
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
|
import Yesod.Persist
|
|
import Data.Text (Text)
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
|
Person
|
|
name Text
|
|
UniquePerson name
|
|
|]
|
|
|
|
data App = App
|
|
{ appConfig :: SqliteConf
|
|
, appPool :: ConnectionPool
|
|
}
|
|
|
|
mkYesod "App" [parseRoutes|
|
|
/ HomeR GET
|
|
/ins InsertR GET
|
|
|]
|
|
|
|
instance Yesod App
|
|
instance YesodPersist App where
|
|
type YesodPersistBackend App = SqlBackend
|
|
runDB = defaultRunDB appConfig appPool
|
|
instance YesodPersistRunner App where
|
|
getDBRunner = defaultGetDBRunner appPool
|
|
|
|
getHomeR :: Handler TypedContent
|
|
getHomeR = do
|
|
runDB $ do
|
|
runMigration migrateAll
|
|
deleteWhere ([] :: [Filter Person])
|
|
insert_ $ Person "Charlie"
|
|
insert_ $ Person "Alice"
|
|
insert_ $ Person "Bob"
|
|
respondSourceDB typePlain $ selectSource [] [Asc PersonName] .| awaitForever toBuilder
|
|
where
|
|
toBuilder (Entity _ (Person name)) = do
|
|
yield $ Chunk $ fromText name
|
|
yield $ Chunk $ fromText "\n"
|
|
yield Flush
|
|
|
|
getInsertR :: Handler ()
|
|
getInsertR = runDB $ insert400_ $ Person "Alice"
|
|
|
|
test :: String -> Session () -> Spec
|
|
test name session = it name $ do
|
|
let config = SqliteConf ":memory:" 1
|
|
pool <- createPoolConfig config
|
|
app <- toWaiApp $ App config pool
|
|
runSession session app
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
test "streaming" $ do
|
|
sres <- request defaultRequest
|
|
assertBody "Alice\nBob\nCharlie\n" sres
|
|
assertStatus 200 sres
|
|
test "insert400" $ do
|
|
sres <- request defaultRequest
|
|
assertStatus 200 sres
|
|
sres' <- request $ defaultRequest `setPath` "/ins"
|
|
assertStatus 400 sres'
|