1 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
8 module TSN.XML.EarlyLine (
13 -- * WARNING: these are private but exported to silence warnings
14 EarlyLineConstructor(..),
15 EarlyLineGameConstructor(..) )
19 import Control.Monad ( forM_ )
20 import Data.Time ( UTCTime(..) )
21 import Data.Tuple.Curry ( uncurryN )
22 import Database.Groundhog (
28 silentMigrationLogger )
29 import Database.Groundhog.Core ( DefaultKey )
30 import Database.Groundhog.Generic ( runDbConn )
31 import Database.Groundhog.Sqlite ( withSqliteConn )
32 import Database.Groundhog.TH (
35 import Test.Tasty ( TestTree, testGroup )
36 import Test.Tasty.HUnit ( (@?=), testCase )
37 import Text.XML.HXT.Core (
51 import TSN.Codegen ( tsn_codegen_config )
52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
57 import TSN.XmlImport ( XmlImport(..) )
66 -- | The DTD to which this module corresponds. Used to invoke dbimport.
69 dtd = "earlylineXML.dtd"
75 -- * EarlyLine/Message
77 -- | Database representation of a 'Message'. It lacks the \<date\>
78 -- elements since they're really properties of the games that they
83 db_xml_file_id :: Int,
85 db_category :: String,
88 db_time_stamp :: UTCTime }
93 -- | XML Representation of an 'EarlyLine'. It has the same
94 -- fields, but in addition contains the 'xml_dates'.
98 xml_xml_file_id :: Int,
99 xml_heading :: String,
100 xml_category :: String,
103 xml_dates :: [EarlyLineDateXml],
104 xml_time_stamp :: UTCTime }
108 instance ToDb Message where
109 -- | The database analogue of a 'Message' is an 'EarlyLine'.
111 type Db Message = EarlyLine
114 -- | The 'FromXml' instance for 'Message' is required for the
115 -- 'XmlImport' instance.
117 instance FromXml Message where
118 -- | To convert a 'Message' to an 'EarlyLine', we just drop
121 from_xml Message{..} =
123 db_xml_file_id = xml_xml_file_id,
124 db_heading = xml_heading,
125 db_category = xml_category,
126 db_sport = xml_sport,
127 db_title = xml_title,
128 db_time_stamp = xml_time_stamp }
131 -- | This allows us to insert the XML representation 'Message'
134 instance XmlImport Message
138 -- * EarlyLineDateXml
140 -- | XML representation of a \<date\>. It has a \"value\" attribute
141 -- containing the actual date string. As children it contains a
142 -- (non-optional) note, and a game. The note and date value are
143 -- properties of the game as far as I can tell.
145 data EarlyLineDateXml =
147 xml_date_value :: UTCTime,
149 xml_game :: EarlyLineGameXml }
154 -- * EarlyLineGame / EarlyLineGameXml
158 db_early_lines_id :: DefaultKey EarlyLine,
159 db_game_time :: UTCTime, -- ^ Combined date/time
160 db_note :: String, -- ^ Taken from the parent \<date\>
161 db_away_team :: EarlyLineGameTeam,
162 db_home_team :: EarlyLineGameTeam,
163 db_over_under :: String }
165 data EarlyLineGameXml =
167 xml_game_time :: UTCTime, -- ^ Only an ambiguous time string, e.g. \"8:30\"
168 xml_away_team :: EarlyLineGameTeam,
169 xml_home_team :: EarlyLineGameTeam,
170 xml_over_under :: String }
174 -- | XML representation of an earlyline team. It doubles as an
175 -- embedded type within the DB representation 'EarlyLineGame'.
177 data EarlyLineGameTeam =
179 db_rotation_number :: Int,
180 db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
181 db_team_name :: String }
185 date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDateXml -> EarlyLineGame
186 date_to_game fk date =
188 db_early_lines_id = fk,
189 db_game_time = combined_date_time,
190 db_note = (xml_note date),
191 db_away_team = xml_away_team (xml_game date),
192 db_home_team = xml_home_team (xml_game date),
193 db_over_under = xml_over_under (xml_game date) }
195 date_part = xml_date_value date
196 time_part = xml_game_time (xml_game date)
197 combined_date_time = UTCTime (utctDay date_part) (utctDayTime time_part)
203 instance DbImport Message where
206 migrate (undefined :: EarlyLine)
207 migrate (undefined :: EarlyLineGame)
210 -- Insert the message and obtain its ID.
211 msg_id <- insert_xml m
213 -- Now loop through the message's <date>s.
214 forM_ (xml_dates m) $ \date -> do
215 -- Each date only contains one game, so we convert the date to a
216 -- game and then insert the game (keyed to the message).
217 let game = date_to_game msg_id date
220 return ImportSucceeded
223 mkPersist tsn_codegen_config [groundhog|
230 - name: unique_early_lines
232 # Prevent multiple imports of the same message.
233 fields: [db_xml_file_id]
236 - entity: EarlyLineGame
237 dbName: early_lines_games
239 - name: EarlyLineGame
241 - name: db_early_lines_id
246 - {name: rotation_number, dbName: away_team_rotation_number}
247 - {name: line, dbName: away_team_line}
248 - {name: team_name, dbName: away_team_name}
251 - {name: rotation_number, dbName: home_team_rotation_number}
252 - {name: line, dbName: home_team_line}
253 - {name: team_name, dbName: home_team_name}
255 - embedded: EarlyLineGameTeam
257 - name: db_rotation_number
258 dbName: rotation_number
271 pickle_message :: PU Message
274 xpWrap (from_tuple, to_tuple) $
275 xp7Tuple (xpElem "XML_File_ID" xpInt)
276 (xpElem "heading" xpText)
277 (xpElem "category" xpText)
278 (xpElem "sport" xpText)
279 (xpElem "title" xpText)
281 (xpElem "time_stamp" xp_time_stamp)
283 from_tuple = uncurryN Message
284 to_tuple m = (xml_xml_file_id m,
292 pickle_date :: PU EarlyLineDateXml
295 xpWrap (from_tuple, to_tuple) $
296 xpTriple (xpAttr "value" xp_early_line_date)
297 (xpElem "note" xpText)
300 from_tuple = uncurryN EarlyLineDateXml
301 to_tuple m = (xml_date_value m, xml_note m, xml_game m)
304 pickle_game :: PU EarlyLineGameXml
307 xpWrap (from_tuple, to_tuple) $
308 xp4Tuple (xpElem "time" xp_ambiguous_time)
311 (xpElem "over_under" xpText)
313 from_tuple = uncurryN EarlyLineGameXml
314 to_tuple m = (xml_game_time m,
321 pickle_away_team :: PU EarlyLineGameTeam
322 pickle_away_team = xpElem "teamA" pickle_team
324 pickle_home_team :: PU EarlyLineGameTeam
325 pickle_home_team = xpElem "teamH" pickle_team
327 pickle_team :: PU EarlyLineGameTeam
329 xpWrap (from_tuple, to_tuple) $
330 xpTriple (xpAttr "rotation" xpInt)
331 (xpAttr "line" (xpOption xpText))
334 from_tuple = uncurryN EarlyLineGameTeam
335 to_tuple m = (db_rotation_number m, db_line m, db_team_name m)
343 -- | A list of all tests for this module.
345 early_line_tests :: TestTree
349 [ test_on_delete_cascade,
350 test_pickle_of_unpickle_is_identity,
351 test_unpickle_succeeds ]
353 -- | If we unpickle something and then pickle it, we should wind up
354 -- with the same thing we started with. WARNING: success of this
355 -- test does not mean that unpickling succeeded.
357 test_pickle_of_unpickle_is_identity :: TestTree
358 test_pickle_of_unpickle_is_identity =
359 testCase "pickle composed with unpickle is the identity" $ do
360 let path = "test/xml/earlylineXML.xml"
361 (expected, actual) <- pickle_unpickle pickle_message path
366 -- | Make sure we can actually unpickle these things.
368 test_unpickle_succeeds :: TestTree
369 test_unpickle_succeeds =
370 testCase "unpickling succeeds" $ do
371 let path = "test/xml/earlylineXML.xml"
372 actual <- unpickleable path pickle_message
379 -- | Make sure everything gets deleted when we delete the top-level
382 test_on_delete_cascade :: TestTree
383 test_on_delete_cascade =
384 testCase "deleting early_lines deletes its children" $ do
385 let path = "test/xml/earlylineXML.xml"
386 results <- unsafe_unpickle path pickle_message
387 let a = undefined :: EarlyLine
388 let b = undefined :: EarlyLineGame
390 actual <- withSqliteConn ":memory:" $ runDbConn $ do
391 runMigration silentMigrationLogger $ do
394 _ <- dbimport results
396 count_a <- countAll a
397 count_b <- countAll b
398 return $ sum [count_a, count_b]