f87f0ee · project-m36 · git.iko.soy

3import ProjectM36.Client

4import ProjectM36.DataTypes.Primitive

5import ProjectM36.Tupleable

6+import ProjectM36.Error

6import Data.Either

7import Data.Either

7−import Control.Monad

8import GHC.Generics

9import Data.Binary

10import Control.DeepSeq

11import qualified Data.Text as T

12−import Data.Time.Calendar (Day)

12+import Data.Time.Calendar

13import qualified Data.Vector as V

14

15--create various database value (atom) types

47

48 createSchema sessionId conn

49

50−data Test = Test {

51− dateo :: Int,

52− date2o :: Int

53− }

54− deriving (Generic, Eq)

55−

56−instance Tupleable Test

57−

58data Property = Property {

50data Property = Property {

59 address :: T.Text,

51 address :: T.Text,

60 price :: Price,

52 price :: Price,

79instance Tupleable Offer

71instance Tupleable Offer

80

72

81data Decision = Decision {

73data Decision = Decision {

82− dec_address :: Address,

74+ decAddress :: Address,

83− dec_offerDate :: Day, --the dec_ prefix is needed until OverloadedRecordFields is available

75+ decOfferDate :: Day, --the dec prefix is needed until OverloadedRecordFields is available

84− dec_bidderName :: Name,

76+ decBidderName :: Name,

85− dec_bidderAddress :: Address,

77+ decBidderAddress :: Address,

86− dec_decisionDate :: Day,

78+ decDecisionDate :: Day,

87− dec_accepted :: Bool

79+ decAccepted :: Bool

88 }

80 }

89 deriving (Generic, Eq)

81 deriving (Generic, Eq)

90

82

91instance Tupleable Decision

83instance Tupleable Decision

92

84

93data Room = Room {

85data Room = Room {

94− room_address :: Address,

86+ roomAddress :: Address,

95 roomName :: Name,

87 roomName :: Name,

96 width :: Double,

88 width :: Double,

97 breadth :: Double,

89 breadth :: Double,

102instance Tupleable Room

94instance Tupleable Room

103

95

104data Floor = Floor {

96data Floor = Floor {

105− floor_address :: Address,

97+ floorAddress :: Address,

106− floor_roomName :: Name,

98+ floorRoomName :: Name,

107− floor :: Int

99+ floorNum :: Int

108 }

100 }

109 deriving (Generic, Eq)

101 deriving (Generic, Eq)

110

102

126 --create uniqueness constraints

118 --create uniqueness constraints

127 incDepKeys = map (uncurry databaseContextExprForUniqueKey)

119 incDepKeys = map (uncurry databaseContextExprForUniqueKey)

128 [("property", ["address"]),

120 [("property", ["address"]),

129− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),

121+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"]),

130− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),

122+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),

131− ("room", ["address", "roomName"]),

123+ ("room", ["roomAddress", "roomName"]),

132− ("floor", ["address", "roomName"]),

124+ ("floor", ["floorAddress", "floorRoomName"]),

133 --"commision" misspelled in OotT

125 --"commision" misspelled in OotT

134 ("commission", ["priceBand", "areaCode", "saleSpeed"])

126 ("commission", ["priceBand", "areaCode", "saleSpeed"])

135 ]

127 ]

136 --create foreign key constraints

128 --create foreign key constraints

137 foreignKeys = [("offer_property_fk",

129 foreignKeys = [("offer_property_fk",

138− ("offer", ["address"]),

130+ ("offer", ["offerAddress"]),

139 ("property", ["address"])),

131 ("property", ["address"])),

140 ("decision_offer_fk",

132 ("decision_offer_fk",

141− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),

133+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),

142− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])),

134+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"])),

143 ("room_property_fk",

135 ("room_property_fk",

144− ("room", ["address"]),

136+ ("room", ["roomAddress"]),

145 ("property", ["address"])),

137 ("property", ["address"])),

146 ("floor_property_fk",

138 ("floor_property_fk",

147− ("floor", ["address"]),

139+ ("floor", ["floorAddress"]),

148 ("property", ["address"]))

140 ("property", ["address"]))

149 ]

141 ]

150 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys

142 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys

170 createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript

162 createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript

171 ]

163 ]

172 --gather up and execute all database updates

164 --gather up and execute all database updates

165+ putStrLn "load relvars"

173− eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)

166+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)

174− let errs = lefts eErrs

167+

175− unless (null errs) (putStrLn (show errs))

168+ putStrLn "load atom functions"

169+ _ <- handleIOErrors $ mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

170+

171+ putStrLn "load data"

172+ let properties = [Property { address = "123 Main St.",

173+ price = 200000,

174+ photo = "123_main.jpg",

175+ dateRegistered = fromGregorian 2016 4 3},

176+ Property { address = "456 Main St.",

177+ price = 150000,

178+ photo = "456_main.jpg",

179+ dateRegistered = fromGregorian 2016 5 6}]

180+ insertPropertiesExpr <- handleError $ toInsertExpr properties "property"

181+ handleIOError $ executeDatabaseContextExpr sessionId conn insertPropertiesExpr

182+

183+ let offers = [Offer { offerAddress = "123 Main St.",

184+ offerPrice = 180000,

185+ offerDate = fromGregorian 2017 1 2,

186+ bidderName = "Steve",

187+ bidderAddress = "789 Main St.",

188+ decisionDate = fromGregorian 2017 2 2,

189+ accepted = False }]

190+

191+ insertOffersExpr <- handleError $ toInsertExpr offers "offer"

192+ handleIOError $ executeDatabaseContextExpr sessionId conn insertOffersExpr

176

193

177− eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs

194+ let rooms = [Room { roomAddress = "123 Main St.",

195+ roomName = "Fabulous Kitchen",

196+ width = 10,

197+ breadth = 10,

198+ roomType = Kitchen },

199+ Room { roomAddress = "123 Main St.",

200+ roomName = "Clean Bathroom",

201+ width = 7,

202+ breadth = 5,

203+ roomType = Bathroom }]

204+

205+ insertRoomsExpr <- handleError $ toInsertExpr rooms "room"

206+ handleIOError $ executeDatabaseContextExpr sessionId conn insertRoomsExpr

207+

208+ let decisions = [Decision { decAddress = "123 Main St.",

209+ decOfferDate = fromGregorian 2017 1 2,

210+ decBidderName = "Steve",

211+ decBidderAddress = "789 Main St.",

212+ decDecisionDate = fromGregorian 2017 05 04,

213+ decAccepted = False }]

214+ insertDecisionsExpr <- handleError $ toInsertExpr decisions "decision"

215+ handleIOError $ executeDatabaseContextExpr sessionId conn insertDecisionsExpr

216+

217+ let floors = [Floor { floorAddress = "123 Main St.",

218+ floorRoomName = "Bathroom",

219+ floorNum = 1

220+ }]

221+ insertFloorsExpr <- handleError $ toInsertExpr floors "floor"

222+ handleIOError $ executeDatabaseContextExpr sessionId conn insertFloorsExpr

223+

224+ let commissions = [Commission { priceBand = Medium,

225+ areaCode = City,

226+ saleSpeed = MediumBand,

227+ commission = 10000 }]

228+ insertCommissionsExpr <- handleError $ toInsertExpr commissions "commission"

229+ handleIOError $ executeDatabaseContextExpr sessionId conn insertCommissionsExpr

230+

231+handleError :: Either RelationalError a -> IO a

232+handleError eErr = case eErr of

233+ Left err -> print err >> error "Died due to errors."

234+ Right v -> pure v

235+

236+handleIOError :: IO (Either RelationalError a) -> IO a

237+handleIOError m = do

238+ e <- m

239+ handleError e

240+

241+handleIOErrors :: IO [Either RelationalError a] -> IO [a]

242+handleIOErrors m = do

243+ eErrs <- m

178− let errs' = lefts eErrs'

244+ case lefts eErrs of

179− unless (null errs') (putStrLn (show errs'))

245+ [] -> pure (rights eErrs)

246+ errs -> handleError (Left (someErrors errs))

247+

248+