@@ -3,13 +3,13 @@
33import ProjectM36.Client
44import ProjectM36.DataTypes.Primitive
55import ProjectM36.Tupleable
6+import ProjectM36.Error
67import Data.Either
7−import Control.Monad
88import GHC.Generics
99import Data.Binary
1010import Control.DeepSeq
1111import qualified Data.Text as T
12−import Data.Time.Calendar (Day)
12+import Data.Time.Calendar
1313import qualified Data.Vector as V
1414
1515--create various database value (atom) types
@@ -47,14 +47,6 @@ main = do
4747
4848 createSchema sessionId conn
4949
50−data Test = Test {
51− dateo :: Int,
52− date2o :: Int
53− }
54− deriving (Generic, Eq)
55−
56−instance Tupleable Test
57−
5850data Property = Property {
5951 address :: T.Text,
6052 price :: Price,
@@ -79,19 +71,19 @@ data Offer = Offer {
7971instance Tupleable Offer
8072
8173data Decision = Decision {
82− dec_address :: Address,
83− dec_offerDate :: Day, --the dec_ prefix is needed until OverloadedRecordFields is available
84− dec_bidderName :: Name,
85− dec_bidderAddress :: Address,
86− dec_decisionDate :: Day,
87− dec_accepted :: Bool
74+ decAddress :: Address,
75+ decOfferDate :: Day, --the dec prefix is needed until OverloadedRecordFields is available
76+ decBidderName :: Name,
77+ decBidderAddress :: Address,
78+ decDecisionDate :: Day,
79+ decAccepted :: Bool
8880 }
8981 deriving (Generic, Eq)
9082
9183instance Tupleable Decision
9284
9385data Room = Room {
94− room_address :: Address,
86+ roomAddress :: Address,
9587 roomName :: Name,
9688 width :: Double,
9789 breadth :: Double,
@@ -102,9 +94,9 @@ data Room = Room {
10294instance Tupleable Room
10395
10496data Floor = Floor {
105− floor_address :: Address,
106− floor_roomName :: Name,
107− floor :: Int
97+ floorAddress :: Address,
98+ floorRoomName :: Name,
99+ floorNum :: Int
108100 }
109101 deriving (Generic, Eq)
110102
@@ -126,25 +118,25 @@ createSchema sessionId conn = do
126118 --create uniqueness constraints
127119 incDepKeys = map (uncurry databaseContextExprForUniqueKey)
128120 [("property", ["address"]),
129− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"]),
130− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),
131− ("room", ["address", "roomName"]),
132− ("floor", ["address", "roomName"]),
121+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"]),
122+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),
123+ ("room", ["roomAddress", "roomName"]),
124+ ("floor", ["floorAddress", "floorRoomName"]),
133125 --"commision" misspelled in OotT
134126 ("commission", ["priceBand", "areaCode", "saleSpeed"])
135127 ]
136128 --create foreign key constraints
137129 foreignKeys = [("offer_property_fk",
138− ("offer", ["address"]),
130+ ("offer", ["offerAddress"]),
139131 ("property", ["address"])),
140132 ("decision_offer_fk",
141− ("decision", ["address", "offerDate", "bidderName", "bidderAddress"]),
142− ("offer", ["address", "offerDate", "bidderName", "bidderAddress"])),
133+ ("decision", ["decAddress", "decOfferDate", "decBidderName", "decBidderAddress"]),
134+ ("offer", ["offerAddress", "offerDate", "bidderName", "bidderAddress"])),
143135 ("room_property_fk",
144− ("room", ["address"]),
136+ ("room", ["roomAddress"]),
145137 ("property", ["address"])),
146138 ("floor_property_fk",
147− ("floor", ["address"]),
139+ ("floor", ["floorAddress"]),
148140 ("property", ["address"]))
149141 ]
150142 incDepForeignKeys = map (\(n, a, b) -> databaseContextExprForForeignKey n a b) foreignKeys
@@ -170,10 +162,87 @@ createSchema sessionId conn = do
170162 createScriptedAtomFunction "datesToSpeedBand" [dayTypeConstructor, dayTypeConstructor] (ADTypeConstructor "SpeedBand" []) speedBandScript
171163 ]
172164 --gather up and execute all database updates
173− eErrs <- mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
174− let errs = lefts eErrs
175− unless (null errs) (putStrLn (show errs))
165+ putStrLn "load relvars"
166+ _ <- handleIOErrors $ mapM (executeDatabaseContextExpr sessionId conn) (new_adts ++ rvDefs ++ incDepKeys ++ incDepForeignKeys)
167+
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
176193
177− eErrs' <- mapM (executeDatabaseContextIOExpr sessionId conn) atomFuncs
178− let errs' = lefts eErrs'
179− unless (null errs') (putStrLn (show errs'))
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
244+ case lefts eErrs of
245+ [] -> pure (rights eErrs)
246+ errs -> handleError (Left (someErrors errs))
247+
248+