-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.hs
executable file
·98 lines (77 loc) · 2.62 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
98
#!/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 GHC.Exts
import qualified Data.Vector as V
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
let storeJson = entityIdToJSON (Entity storeId store)
let (Object storeHashMap) = storeJson
products <- runDB $ selectList [ProductStore ==. storeId] [] :: Handler [Entity Product]
let productsJson = [entityIdToJSON (Entity k r) | Entity k r <- products]
let productsValue = Array (V.fromList productsJson)
let storeWithProducts = HM.insert "products" productsValue storeHashMap
return $ object ["data" .= storeWithProducts]
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