-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.hs
executable file
·97 lines (74 loc) · 2.5 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
#!/usr/bin/env stack
{- stack
--resolver lts-5.10
--install-ghc
runghc
--package unordered-containers
--package yesod
--package persistent-sqlite
-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
import Control.Monad.Trans.Resource (runResourceT)
import Control.Monad.Logger (runStderrLoggingT)
import Data.Aeson (FromJSON, ToJSON, decode, encode)
import qualified Data.HashMap.Strict as HM
import Data.Text (Text)
import Data.Time.Clock
import Database.Persist.Sqlite
import GHC.Generics (Generic)
import Network.HTTP.Types
import Yesod
data App = App ConnectionPool
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Store
name Text
deriving Show Generic
Product
name Text
price Int
store StoreId
deriving Show Generic
|]
mkYesod "App" [parseRoutes|
/#StoreId StoreR GET
|]
instance Yesod App
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
runDB action = do
App pool <- getYesod
runSqlPool action pool
instance RenderMessage App FormMessage where
renderMessage _ _ = defaultFormMessage
instance ToJSON Store
instance ToJSON Product
getStoreR :: StoreId -> Handler Value
getStoreR storeId = do
store <- runDB $ get404 storeId
products <- runDB $ selectList [StoreId ==. storeId] []
let productsJson = [entityIdToJSON (Entity k r) | Entity k r <- products]
let storeJson = entityIdToJSON (Entity storeId store)
-- Inject productsJson under "products" property
let storeJsonWithProducts = HM.insert "products" productsJson storeJson
return $ object ["data" .= storeJsonWithProducts]
openConnectionCount :: Int
openConnectionCount = 10
main :: IO ()
main = runStderrLoggingT $ withSqlitePool "test.db3" openConnectionCount $ \pool -> liftIO $ do
runResourceT $ flip runSqlPool pool $ do
runMigration migrateAll
store <- insert $ Store "Store1"
_ <- insert $ Product "Product1" 10 store
_ <- insert $ Product "Product2" 50 store
insert $ Product "Product3" 100 store
warp 3000 $ App pool