1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 -- | Parse TSN XML for the DTD \"earlylineXML.dtd\". Each \<message\>
9 -- element contains a bunch of \<date\>s, and those \<date\>s
10 -- contain a single \<game\>. In the database, we merge the date
11 -- info into the games, and key the games to the messages.
13 module TSN.XML.EarlyLine (
18 -- * WARNING: these are private but exported to silence warnings
19 EarlyLineConstructor(..),
20 EarlyLineGameConstructor(..) )
24 import Control.Monad ( forM_ )
25 import Data.Time ( UTCTime(..) )
26 import Data.Tuple.Curry ( uncurryN )
27 import Database.Groundhog (
33 silentMigrationLogger )
34 import Database.Groundhog.Core ( DefaultKey )
35 import Database.Groundhog.Generic ( runDbConn )
36 import Database.Groundhog.Sqlite ( withSqliteConn )
37 import Database.Groundhog.TH (
40 import Test.Tasty ( TestTree, testGroup )
41 import Test.Tasty.HUnit ( (@?=), testCase )
42 import Text.XML.HXT.Core (
56 import TSN.Codegen ( tsn_codegen_config )
57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
62 import TSN.XmlImport ( XmlImport(..) )
71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
74 dtd = "earlylineXML.dtd"
80 -- * EarlyLine/Message
82 -- | Database representation of a 'Message'. It lacks the \<date\>
83 -- elements since they're really properties of the games that they
88 db_xml_file_id :: Int,
90 db_category :: String,
93 db_time_stamp :: UTCTime }
98 -- | XML Representation of an 'EarlyLine'. It has the same
99 -- fields, but in addition contains the 'xml_dates'.
103 xml_xml_file_id :: Int,
104 xml_heading :: String,
105 xml_category :: String,
108 xml_dates :: [EarlyLineDate],
109 xml_time_stamp :: UTCTime }
113 instance ToDb Message where
114 -- | The database analogue of a 'Message' is an 'EarlyLine'.
116 type Db Message = EarlyLine
119 -- | The 'FromXml' instance for 'Message' is required for the
120 -- 'XmlImport' instance.
122 instance FromXml Message where
123 -- | To convert a 'Message' to an 'EarlyLine', we just drop
126 from_xml Message{..} =
128 db_xml_file_id = xml_xml_file_id,
129 db_heading = xml_heading,
130 db_category = xml_category,
131 db_sport = xml_sport,
132 db_title = xml_title,
133 db_time_stamp = xml_time_stamp }
136 -- | This allows us to insert the XML representation 'Message'
139 instance XmlImport Message
145 -- | XML representation of a \<date\>. It has a \"value\" attribute
146 -- containing the actual date string. As children it contains a
147 -- (non-optional) note, and a game. The note and date value are
148 -- properties of the game as far as I can tell.
152 date_value :: UTCTime,
154 date_game :: EarlyLineGameXml }
159 -- * EarlyLineGame / EarlyLineGameXml
163 db_early_lines_id :: DefaultKey EarlyLine,
164 db_game_time :: UTCTime, -- ^ Combined date/time
165 db_note :: String, -- ^ Taken from the parent \<date\>
166 db_away_team :: EarlyLineGameTeam,
167 db_home_team :: EarlyLineGameTeam,
168 db_over_under :: String }
170 data EarlyLineGameXml =
172 xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
173 xml_away_team :: EarlyLineGameTeam,
174 xml_home_team :: EarlyLineGameTeam,
175 xml_over_under :: String }
179 -- | XML representation of an earlyline team. It doubles as an
180 -- embedded type within the DB representation 'EarlyLineGame'.
182 data EarlyLineGameTeam =
184 db_rotation_number :: Int,
185 db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
186 db_team_name :: String }
190 -- | Convert an 'EarlyLineDate' into an 'EarlyLineGame'. Each date has
191 -- exactly one game, and the fields that belong to the date should
192 -- really be in the game anyway. So the database representation of a
193 -- game has the combined fields of the XML date/game.
195 -- This function gets the game out of a date, and then sticks the
196 -- date value and note inside the game. It also adds the foreign key
197 -- reference to the game's parent message, and returns the result.
199 date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDate -> EarlyLineGame
200 date_to_game fk date =
202 db_early_lines_id = fk,
203 db_game_time = combined_date_time,
204 db_note = (date_note date),
205 db_away_team = xml_away_team (date_game date),
206 db_home_team = xml_home_team (date_game date),
207 db_over_under = xml_over_under (date_game date) }
209 date_part = date_value date
210 time_part = xml_game_time (date_game date)
211 combined_date_time = UTCTime (utctDay date_part) (utctDayTime time_part)
217 instance DbImport Message where
220 migrate (undefined :: EarlyLine)
221 migrate (undefined :: EarlyLineGame)
224 -- Insert the message and obtain its ID.
225 msg_id <- insert_xml m
227 -- Now loop through the message's <date>s.
228 forM_ (xml_dates m) $ \date -> do
229 -- Each date only contains one game, so we convert the date to a
230 -- game and then insert the game (keyed to the message).
231 let game = date_to_game msg_id date
234 return ImportSucceeded
237 mkPersist tsn_codegen_config [groundhog|
244 - name: unique_early_lines
246 # Prevent multiple imports of the same message.
247 fields: [db_xml_file_id]
250 - entity: EarlyLineGame
251 dbName: early_lines_games
253 - name: EarlyLineGame
255 - name: db_early_lines_id
260 - {name: rotation_number, dbName: away_team_rotation_number}
261 - {name: line, dbName: away_team_line}
262 - {name: team_name, dbName: away_team_name}
265 - {name: rotation_number, dbName: home_team_rotation_number}
266 - {name: line, dbName: home_team_line}
267 - {name: team_name, dbName: home_team_name}
269 - embedded: EarlyLineGameTeam
271 - name: db_rotation_number
272 dbName: rotation_number
287 -- | Pickler for the top-level 'Message'.
289 pickle_message :: PU Message
292 xpWrap (from_tuple, to_tuple) $
293 xp7Tuple (xpElem "XML_File_ID" xpInt)
294 (xpElem "heading" xpText)
295 (xpElem "category" xpText)
296 (xpElem "sport" xpText)
297 (xpElem "title" xpText)
299 (xpElem "time_stamp" xp_time_stamp)
301 from_tuple = uncurryN Message
302 to_tuple m = (xml_xml_file_id m,
311 -- | Pickler for the \<date\> elements within each \<message\>.
313 pickle_date :: PU EarlyLineDate
316 xpWrap (from_tuple, to_tuple) $
317 xpTriple (xpAttr "value" xp_early_line_date)
318 (xpElem "note" xpText)
321 from_tuple = uncurryN EarlyLineDate
322 to_tuple m = (date_value m, date_note m, date_game m)
326 -- | Pickler for the \<game\> element within each \<date\>.
328 pickle_game :: PU EarlyLineGameXml
331 xpWrap (from_tuple, to_tuple) $
332 xp4Tuple (xpElem "time" xp_ambiguous_time)
335 (xpElem "over_under" xpText)
337 from_tuple = uncurryN EarlyLineGameXml
338 to_tuple m = (xml_game_time m,
345 -- | Pickle an away team (\<teamA\>) element within a \<game\>. Most
346 -- of the work (common with the home team pickler) is done by
349 pickle_away_team :: PU EarlyLineGameTeam
350 pickle_away_team = xpElem "teamA" pickle_team
353 -- | Pickle a home team (\<teamH\>) element within a \<game\>. Most
354 -- of the work (common with theaway team pickler) is done by
357 pickle_home_team :: PU EarlyLineGameTeam
358 pickle_home_team = xpElem "teamH" pickle_team
361 -- | Team pickling common to both 'pickle_away_team' and
362 -- 'pickle_home_team'. Handles everything inside the \<teamA\> and
363 -- \<teamH\> elements.
365 pickle_team :: PU EarlyLineGameTeam
367 xpWrap (from_tuple, to_tuple) $
368 xpTriple (xpAttr "rotation" xpInt)
369 (xpAttr "line" (xpOption xpText))
372 from_tuple = uncurryN EarlyLineGameTeam
373 to_tuple m = (db_rotation_number m, db_line m, db_team_name m)
381 -- | A list of all tests for this module.
383 early_line_tests :: TestTree
387 [ test_on_delete_cascade,
388 test_pickle_of_unpickle_is_identity,
389 test_unpickle_succeeds ]
391 -- | If we unpickle something and then pickle it, we should wind up
392 -- with the same thing we started with. WARNING: success of this
393 -- test does not mean that unpickling succeeded.
395 test_pickle_of_unpickle_is_identity :: TestTree
396 test_pickle_of_unpickle_is_identity =
397 testCase "pickle composed with unpickle is the identity" $ do
398 let path = "test/xml/earlylineXML.xml"
399 (expected, actual) <- pickle_unpickle pickle_message path
404 -- | Make sure we can actually unpickle these things.
406 test_unpickle_succeeds :: TestTree
407 test_unpickle_succeeds =
408 testCase "unpickling succeeds" $ do
409 let path = "test/xml/earlylineXML.xml"
410 actual <- unpickleable path pickle_message
417 -- | Make sure everything gets deleted when we delete the top-level
420 test_on_delete_cascade :: TestTree
421 test_on_delete_cascade =
422 testCase "deleting early_lines deletes its children" $ do
423 let path = "test/xml/earlylineXML.xml"
424 results <- unsafe_unpickle path pickle_message
425 let a = undefined :: EarlyLine
426 let b = undefined :: EarlyLineGame
428 actual <- withSqliteConn ":memory:" $ runDbConn $ do
429 runMigration silentMigrationLogger $ do
432 _ <- dbimport results
434 count_a <- countAll a
435 count_b <- countAll b
436 return $ sum [count_a, count_b]