]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - TSN/XML/EarlyLine.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / TSN / XML / EarlyLine.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- | Parse TSN XML for the DTD \"earlylineXML.dtd\". For that DTD,
9 -- each \<message\> element contains a bunch of \<date\>s, and those
10 -- \<date\>s contain a single \<game\>. In the database, we merge
11 -- the date info into the games, and key the games to the messages.
12 --
13 -- Real life is not so simple, however. There is another module,
14 -- "TSN.XML.MLBEarlyLine" that is something of a subclass of this
15 -- one. It contains early lines, but only for MLB games. The data
16 -- types and XML schema are /almost/ the same, but TSN like to make
17 -- things difficult.
18 --
19 -- A full list of the differences is given in that module. In this
20 -- one, we mention where data types have been twerked a little to
21 -- support the second document type.
22 --
23 module TSN.XML.EarlyLine (
24 EarlyLine, -- Used in TSN.XML.MLBEarlyLine
25 EarlyLineGame, -- Used in TSN.XML.MLBEarlyLine
26 dtd,
27 pickle_message,
28 -- * Tests
29 early_line_tests,
30 -- * WARNING: these are private but exported to silence warnings
31 EarlyLineConstructor(..),
32 EarlyLineGameConstructor(..) )
33 where
34
35 -- System imports.
36 import Control.Monad ( join )
37 import Data.Time ( UTCTime(..) )
38 import Data.Tuple.Curry ( uncurryN )
39 import Database.Groundhog (
40 countAll,
41 deleteAll,
42 insert_,
43 migrate,
44 runMigration,
45 silentMigrationLogger )
46 import Database.Groundhog.Core ( DefaultKey )
47 import Database.Groundhog.Generic ( runDbConn )
48 import Database.Groundhog.Sqlite ( withSqliteConn )
49 import Database.Groundhog.TH (
50 groundhog,
51 mkPersist )
52 import Test.Tasty ( TestTree, testGroup )
53 import Test.Tasty.HUnit ( (@?=), testCase )
54 import Text.XML.HXT.Core (
55 PU,
56 xp4Tuple,
57 xp6Tuple,
58 xp7Tuple,
59 xpAttr,
60 xpElem,
61 xpInt,
62 xpList,
63 xpOption,
64 xpPair,
65 xpText,
66 xpWrap )
67
68 -- Local imports.
69 import TSN.Codegen ( tsn_codegen_config )
70 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
71 import TSN.Picklers (
72 xp_ambiguous_time,
73 xp_early_line_date,
74 xp_time_stamp )
75 import TSN.XmlImport ( XmlImport(..) )
76 import Xml (
77 FromXml(..),
78 ToDb(..),
79 pickle_unpickle,
80 unpickleable,
81 unsafe_unpickle )
82
83
84 -- | The DTD to which this module corresponds. Used to invoke dbimport.
85 --
86 dtd :: String
87 dtd = "earlylineXML.dtd"
88
89 --
90 -- * DB/XML data types
91 --
92
93 -- * EarlyLine/Message
94
95 -- | Database representation of a 'Message'. It lacks the \<date\>
96 -- elements since they're really properties of the games that they
97 -- contain.
98 --
99 data EarlyLine =
100 EarlyLine {
101 db_xml_file_id :: Int,
102 db_heading :: String,
103 db_category :: String,
104 db_sport :: String,
105 db_title :: String,
106 db_time_stamp :: UTCTime }
107 deriving (Eq, Show)
108
109
110
111 -- | XML Representation of an 'EarlyLine'. It has the same
112 -- fields, but in addition contains the 'xml_dates'.
113 --
114 data Message =
115 Message {
116 xml_xml_file_id :: Int,
117 xml_heading :: String,
118 xml_category :: String,
119 xml_sport :: String,
120 xml_title :: String,
121 xml_dates :: [EarlyLineDate],
122 xml_time_stamp :: UTCTime }
123 deriving (Eq, Show)
124
125
126 instance ToDb Message where
127 -- | The database analogue of a 'Message' is an 'EarlyLine'.
128 --
129 type Db Message = EarlyLine
130
131
132 -- | The 'FromXml' instance for 'Message' is required for the
133 -- 'XmlImport' instance.
134 --
135 instance FromXml Message where
136 -- | To convert a 'Message' to an 'EarlyLine', we just drop
137 -- the 'xml_dates'.
138 --
139 from_xml Message{..} =
140 EarlyLine {
141 db_xml_file_id = xml_xml_file_id,
142 db_heading = xml_heading,
143 db_category = xml_category,
144 db_sport = xml_sport,
145 db_title = xml_title,
146 db_time_stamp = xml_time_stamp }
147
148
149 -- | This allows us to insert the XML representation 'Message'
150 -- directly.
151 --
152 instance XmlImport Message
153
154
155
156 -- * EarlyLineDate / EarlyLineGameWithNote
157
158 -- | This is a very sad data type. It exists so that we can
159 -- successfully unpickle/pickle the MLB_earlylineXML.dtd documents
160 -- and get back what we started with. In that document type, the
161 -- dates all have multiple \<game\>s associated with them (as
162 -- children). But the dates also have multiple \<note\>s as
163 -- children, and we're supposed to figure out which notes go with
164 -- which games based on the order that they appear in the XML
165 -- file. Yeah, right.
166 --
167 -- In any case, instead of expecting the games and notes in some
168 -- nice order, we use this data type to expect \"a game and maybe a
169 -- note\" multiple times. This will pair the notes with only one
170 -- game, rather than all of the games that TSN think it should go
171 -- with. But it allows us to pickle and unpickle correctly at least.
172 --
173 data EarlyLineGameWithNote =
174 EarlyLineGameWithNote {
175 date_note :: Maybe String,
176 date_game :: EarlyLineGameXml }
177 deriving (Eq, Show)
178
179
180 -- | XML representation of a \<date\>. It has a \"value\" attribute
181 -- containing the actual date string. As children it contains a
182 -- (non-optional) note, and a game. The note and date value are
183 -- properties of the game as far as I can tell.
184 --
185 data EarlyLineDate =
186 EarlyLineDate {
187 date_value :: UTCTime,
188 date_games_with_notes :: [EarlyLineGameWithNote] }
189 deriving (Eq, Show)
190
191
192
193 -- * EarlyLineGame / EarlyLineGameXml
194
195 -- | Database representation of a \<game\> in earlylineXML.dtd and
196 -- MLB_earlylineXML.dtd. We've had to make a sacrifice here to
197 -- support both document types. Since it's not possible to pair the
198 -- \<note\>s with \<game\>s reliably in MLB_earlylineXML.dtd, we
199 -- have omitted the notes entirely. This is sad, but totally not our
200 -- fault.
201 --
202 -- In earlylineXML.dtd, each \<date\> and thus each \<note\> is
203 -- paired with exactly one \<game\>, so if we only cared about that
204 -- document type, we could have retained the notes.
205 --
206 -- In earlylinexml.DTD, the over/under is required, but in
207 -- MLB_earlylinexml.DTD it is not. So another compromise is to have
208 -- it optional here.
209 --
210 -- The 'db_game_time' should be the combined date/time using the
211 -- date value from the \<game\> element's containing
212 -- \<date\>. That's why EarlyLineGame isn't an instance of
213 -- 'FromXmlFk': the foreign key isn't enough to construct one, we
214 -- also need the date.
215 --
216 data EarlyLineGame =
217 EarlyLineGame {
218 db_early_lines_id :: DefaultKey EarlyLine,
219 db_game_time :: UTCTime, -- ^ Combined date/time
220 db_away_team :: EarlyLineGameTeam,
221 db_home_team :: EarlyLineGameTeam,
222 db_over_under :: Maybe String }
223
224
225 -- | XML representation of a 'EarlyLineGame'. Comparatively, it lacks
226 -- only the foreign key to the parent message.
227 --
228 data EarlyLineGameXml =
229 EarlyLineGameXml {
230 xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
231 xml_away_team :: EarlyLineGameTeamXml,
232 xml_home_team :: EarlyLineGameTeamXml,
233 xml_over_under :: Maybe String }
234 deriving (Eq, Show)
235
236
237
238 -- * EarlyLineGameTeam / EarlyLineGameTeamXml
239
240 -- | Database representation of an EarlyLine team, used in both
241 -- earlylineXML.dtd and MLB_earlylineXML.dtd. It doubles as an
242 -- embedded type within the DB representation 'EarlyLineGame'.
243 --
244 -- The team name is /not/ optional. However, since we're overloading
245 -- the XML representation, we're constructing 'db_team_name' name
246 -- from two Maybes, 'xml_team_name_attr' and
247 -- 'xml_team_name_text'. To ensure type safety (and avoid a runtime
248 -- crash), we allow the database field to be optional as well.
249 --
250 data EarlyLineGameTeam =
251 EarlyLineGameTeam {
252 db_rotation_number :: Int,
253 db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
254 db_team_name :: Maybe String, -- ^ NOT optional, see the data type docs.
255 db_pitcher :: Maybe String -- ^ Optional in MLB_earlylineXML.dtd,
256 -- always absent in earlylineXML.dtd.
257 }
258
259
260 -- | This here is an abomination. What we've got is an XML
261 -- representation, not for either earlylineXML.dtd or
262 -- MLB_earlylineXML.dtd, but one that will work for /both/. Even
263 -- though they represent the teams totally differently! Argh!
264 --
265 -- The earlylineXML.dtd teams look like,
266 --
267 -- \<teamA rotation=\"709\" line=\"\">Miami\</teamA\>
268 --
269 -- While the MLB_earlylineXML.dtd teams look like,
270 --
271 -- <teamA rotation="901" name="LOS">
272 -- <pitcher>D.Haren</pitcher>
273 -- <line>-130</line>
274 -- </teamA>
275 --
276 -- So that's cool. This data type has placeholders that should allow
277 -- the name/line to appear either as an attribute or as a text
278 -- node. We'll sort it all out in the conversion to
279 -- EarlyLineGameTeam.
280 --
281 data EarlyLineGameTeamXml =
282 EarlyLineGameTeamXml {
283 xml_rotation_number :: Int,
284 xml_line_attr :: Maybe String,
285 xml_team_name_attr :: Maybe String,
286 xml_team_name_text :: Maybe String,
287 xml_pitcher :: Maybe String,
288 xml_line_elem :: Maybe String }
289 deriving (Eq, Show)
290
291
292
293 instance ToDb EarlyLineGameTeamXml where
294 -- | The database analogue of a 'EarlyLineGameTeamXml' is an
295 -- 'EarlyLineGameTeam', although the DB type is merely embedded
296 -- in another type.
297 --
298 type Db EarlyLineGameTeamXml = EarlyLineGameTeam
299
300
301 -- | The 'FromXml' instance for 'EarlyLineGameTeamXml' lets us convert
302 -- it to a 'EarlyLineGameTeam' easily.
303 --
304 instance FromXml EarlyLineGameTeamXml where
305 -- | To convert a 'EarlyLineGameTeamXml' to an 'EarlyLineGameTeam',
306 -- we figure how its fields were represented and choose the ones
307 -- that are populated. For example if the \"line\" attribute was
308 -- there, we'll use it, but if now, we'll use the \<line\>
309 -- element.
310 --
311 from_xml EarlyLineGameTeamXml{..} =
312 EarlyLineGameTeam {
313 db_rotation_number = xml_rotation_number,
314 db_line = merge xml_line_attr xml_line_elem,
315 db_team_name = merge xml_team_name_attr xml_team_name_text,
316 db_pitcher = xml_pitcher }
317 where
318 merge :: Maybe String -> Maybe String -> Maybe String
319 merge Nothing y = y
320 merge x Nothing = x
321 merge _ _ = Nothing
322
323
324
325
326 -- | Convert an 'EarlyLineDate' into a list of 'EarlyLineGame's. Each
327 -- date has one or more games, and the fields that belong to the date
328 -- should really be in the game anyway. So the database
329 -- representation of a game has the combined fields of the XML
330 -- date/game.
331 --
332 -- This function gets the games out of a date, and then sticks the
333 -- date value inside the games. It also adds the foreign key
334 -- reference to the games' parent message, and returns the result.
335 --
336 -- This would convert a single date to a single game if we only
337 -- needed to support earlylineXML.dtd and not MLB_earlylineXML.dtd.
338 --
339 date_to_games :: (DefaultKey EarlyLine) -> EarlyLineDate -> [EarlyLineGame]
340 date_to_games fk date =
341 map convert_game games_only
342 where
343 -- | Get the list of games out of a date (i.e. drop the notes).
344 --
345 games_only :: [EarlyLineGameXml]
346 games_only = (map date_game (date_games_with_notes date))
347
348 -- | Stick the date value into the given game.
349 --
350 combine_date_time :: EarlyLineGameXml -> UTCTime
351 combine_date_time elgx =
352 UTCTime (utctDay $ date_value date) (utctDayTime $ xml_game_time elgx)
353
354 -- | Convert an XML game to a database one.
355 --
356 convert_game :: EarlyLineGameXml -> EarlyLineGame
357 convert_game gx =
358 EarlyLineGame {
359 db_early_lines_id = fk,
360 db_game_time = combine_date_time gx,
361 db_away_team = from_xml (xml_away_team gx),
362 db_home_team = from_xml (xml_home_team gx),
363 db_over_under = xml_over_under gx }
364
365
366 --
367 -- * Database stuff
368 --
369
370 instance DbImport Message where
371 dbmigrate _ =
372 run_dbmigrate $ do
373 migrate (undefined :: EarlyLine)
374 migrate (undefined :: EarlyLineGame)
375
376 dbimport m = do
377 -- Insert the message and obtain its ID.
378 msg_id <- insert_xml m
379
380 -- Create a function that will turn a list of dates into a list of
381 -- games by converting each date to its own list of games, and
382 -- then concatenating all of the game lists together.
383 let convert_dates_to_games = concatMap (date_to_games msg_id)
384
385 -- Now use it to make dem games.
386 let games = convert_dates_to_games (xml_dates m)
387
388 -- And insert all of them
389 mapM_ insert_ games
390
391 return ImportSucceeded
392
393
394 mkPersist tsn_codegen_config [groundhog|
395
396 - entity: EarlyLine
397 dbName: early_lines
398 constructors:
399 - name: EarlyLine
400 uniques:
401 - name: unique_early_lines
402 type: constraint
403 # Prevent multiple imports of the same message.
404 fields: [db_xml_file_id]
405
406
407 - entity: EarlyLineGame
408 dbName: early_lines_games
409 constructors:
410 - name: EarlyLineGame
411 fields:
412 - name: db_early_lines_id
413 reference:
414 onDelete: cascade
415 - name: db_away_team
416 embeddedType:
417 - {name: rotation_number, dbName: away_team_rotation_number}
418 - {name: line, dbName: away_team_line}
419 - {name: team_name, dbName: away_team_name}
420 - {name: pitcher, dbName: away_team_pitcher}
421 - name: db_home_team
422 embeddedType:
423 - {name: rotation_number, dbName: home_team_rotation_number}
424 - {name: line, dbName: home_team_line}
425 - {name: team_name, dbName: home_team_name}
426 - {name: pitcher, dbName: home_team_pitcher}
427
428 - embedded: EarlyLineGameTeam
429 fields:
430 - name: db_rotation_number
431 dbName: rotation_number
432 - name: db_line
433 dbName: line
434 - name: db_team_name
435 dbName: team_name
436 - name: db_pitcher
437 dbName: pitcher
438 |]
439
440
441
442 --
443 -- * Pickling
444 --
445
446
447 -- | Pickler for the top-level 'Message'.
448 --
449 pickle_message :: PU Message
450 pickle_message =
451 xpElem "message" $
452 xpWrap (from_tuple, to_tuple) $
453 xp7Tuple (xpElem "XML_File_ID" xpInt)
454 (xpElem "heading" xpText)
455 (xpElem "category" xpText)
456 (xpElem "sport" xpText)
457 (xpElem "title" xpText)
458 (xpList pickle_date)
459 (xpElem "time_stamp" xp_time_stamp)
460 where
461 from_tuple = uncurryN Message
462 to_tuple m = (xml_xml_file_id m,
463 xml_heading m,
464 xml_category m,
465 xml_sport m,
466 xml_title m,
467 xml_dates m,
468 xml_time_stamp m)
469
470
471
472 -- | Pickler for a '\<note\> followed by a \<game\>. We turn them into
473 -- a 'EarlyLineGameWithNote'.
474 --
475 pickle_game_with_note :: PU EarlyLineGameWithNote
476 pickle_game_with_note =
477 xpWrap (from_tuple, to_tuple) $
478 xpPair (xpOption $ xpElem "note" xpText)
479 pickle_game
480 where
481 from_tuple = uncurry EarlyLineGameWithNote
482 to_tuple m = (date_note m, date_game m)
483
484
485 -- | Pickler for the \<date\> elements within each \<message\>.
486 --
487 pickle_date :: PU EarlyLineDate
488 pickle_date =
489 xpElem "date" $
490 xpWrap (from_tuple, to_tuple) $
491 xpPair (xpAttr "value" xp_early_line_date)
492 (xpList pickle_game_with_note)
493 where
494 from_tuple = uncurry EarlyLineDate
495 to_tuple m = (date_value m, date_games_with_notes m)
496
497
498
499 -- | Pickler for the \<game\> elements within each \<date\>.
500 --
501 pickle_game :: PU EarlyLineGameXml
502 pickle_game =
503 xpElem "game" $
504 xpWrap (from_tuple, to_tuple) $
505 xp4Tuple (xpElem "time" xp_ambiguous_time)
506 pickle_away_team
507 pickle_home_team
508 (xpElem "over_under" (xpOption xpText))
509 where
510 from_tuple = uncurryN EarlyLineGameXml
511 to_tuple m = (xml_game_time m,
512 xml_away_team m,
513 xml_home_team m,
514 xml_over_under m)
515
516
517
518 -- | Pickle an away team (\<teamA\>) element within a \<game\>. Most
519 -- of the work (common with the home team pickler) is done by
520 -- 'pickle_team'.
521 --
522 pickle_away_team :: PU EarlyLineGameTeamXml
523 pickle_away_team = xpElem "teamA" pickle_team
524
525
526 -- | Pickle a home team (\<teamH\>) element within a \<game\>. Most
527 -- of the work (common with theaway team pickler) is done by
528 -- 'pickle_team'.
529 --
530 pickle_home_team :: PU EarlyLineGameTeamXml
531 pickle_home_team = xpElem "teamH" pickle_team
532
533
534 -- | Team pickling common to both 'pickle_away_team' and
535 -- 'pickle_home_team'. Handles everything inside the \<teamA\> and
536 -- \<teamH\> elements. We try to parse the line/name as both an
537 -- attribute and an element in order to accomodate
538 -- MLB_earlylineXML.dtd.
539 --
540 -- The \"line\" and \"pitcher\" fields wind up being double-Maybes,
541 -- since they can be empty even if they exist.
542 --
543 pickle_team :: PU EarlyLineGameTeamXml
544 pickle_team =
545 xpWrap (from_tuple, to_tuple) $
546 xp6Tuple (xpAttr "rotation" xpInt)
547 (xpOption $ xpAttr "line" (xpOption xpText))
548 (xpOption $ xpAttr "name" xpText)
549 (xpOption xpText)
550 (xpOption $ xpElem "pitcher" (xpOption xpText))
551 (xpOption $ xpElem "line" (xpOption xpText))
552 where
553 from_tuple (u,v,w,x,y,z) =
554 EarlyLineGameTeamXml u (join v) w x (join y) (join z)
555
556 to_tuple (EarlyLineGameTeamXml u v w x y z) =
557 (u, double_just v, w, x, double_just y, double_just z)
558 where
559 double_just val = case val of
560 Nothing -> Nothing
561 just_something -> Just just_something
562
563
564
565
566 --
567 -- * Tasty Tests
568 --
569
570 -- | A list of all tests for this module.
571 --
572 early_line_tests :: TestTree
573 early_line_tests =
574 testGroup
575 "EarlyLine tests"
576 [ test_on_delete_cascade,
577 test_pickle_of_unpickle_is_identity,
578 test_unpickle_succeeds ]
579
580 -- | If we unpickle something and then pickle it, we should wind up
581 -- with the same thing we started with. WARNING: success of this
582 -- test does not mean that unpickling succeeded.
583 --
584 test_pickle_of_unpickle_is_identity :: TestTree
585 test_pickle_of_unpickle_is_identity =
586 testCase "pickle composed with unpickle is the identity" $ do
587 let path = "test/xml/earlylineXML.xml"
588 (expected, actual) <- pickle_unpickle pickle_message path
589 actual @?= expected
590
591
592
593 -- | Make sure we can actually unpickle these things.
594 --
595 test_unpickle_succeeds :: TestTree
596 test_unpickle_succeeds =
597 testCase "unpickling succeeds" $ do
598 let path = "test/xml/earlylineXML.xml"
599 actual <- unpickleable path pickle_message
600
601 let expected = True
602 actual @?= expected
603
604
605
606 -- | Make sure everything gets deleted when we delete the top-level
607 -- record.
608 --
609 test_on_delete_cascade :: TestTree
610 test_on_delete_cascade =
611 testCase "deleting early_lines deletes its children" $ do
612 let path = "test/xml/earlylineXML.xml"
613 results <- unsafe_unpickle path pickle_message
614 let a = undefined :: EarlyLine
615 let b = undefined :: EarlyLineGame
616
617 actual <- withSqliteConn ":memory:" $ runDbConn $ do
618 runMigration silentMigrationLogger $ do
619 migrate a
620 migrate b
621 _ <- dbimport results
622 deleteAll a
623 count_a <- countAll a
624 count_b <- countAll b
625 return $ sum [count_a, count_b]
626 let expected = 0
627 actual @?= expected