src/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\". 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.
  12 --
  13 module TSN.XML.EarlyLine (
  14   dtd,
  15   pickle_message,
  16   -- * Tests
  17   early_line_tests,
  18   -- * WARNING: these are private but exported to silence warnings
  19   EarlyLineConstructor(..),
  20   EarlyLineGameConstructor(..) )
  21 where
  22
  23 -- System imports.
  24 import Control.Monad ( forM_ )
  25 import Data.Time ( UTCTime(..) )
  26 import Data.Tuple.Curry ( uncurryN )
  27 import Database.Groundhog (
  28   countAll,
  29   deleteAll,
  30   insert_,
  31   migrate,
  32   runMigration,
  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 (
  38   groundhog,
  39   mkPersist )
  40 import Test.Tasty ( TestTree, testGroup )
  41 import Test.Tasty.HUnit ( (@?=), testCase )
  42 import Text.XML.HXT.Core (
  43   PU,
  44   xp4Tuple,
  45   xp7Tuple,
  46   xpAttr,
  47   xpElem,
  48   xpInt,
  49   xpList,
  50   xpOption,
  51   xpText,
  52   xpTriple,
  53   xpWrap )
  54
  55 -- Local imports.
  56 import TSN.Codegen ( tsn_codegen_config )
  57 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  58 import TSN.Picklers (
  59   xp_ambiguous_time,
  60   xp_early_line_date,
  61   xp_time_stamp )
  62 import TSN.XmlImport ( XmlImport(..) )
  63 import Xml (
  64   FromXml(..),
  65   ToDb(..),
  66   pickle_unpickle,
  67   unpickleable,
  68   unsafe_unpickle )
  69
  70
  71 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  72 --
  73 dtd :: String
  74 dtd = "earlylineXML.dtd"
  75
  76 --
  77 -- DB/XML data types
  78 --
  79
  80 -- * EarlyLine/Message
  81
  82 -- | Database representation of a 'Message'. It lacks the \<date\>
  83 --   elements since they're really properties of the games that they
  84 --   contain.
  85 --
  86 data EarlyLine =
  87   EarlyLine {
  88     db_xml_file_id :: Int,
  89     db_heading :: String,
  90     db_category :: String,
  91     db_sport :: String,
  92     db_title :: String,
  93     db_time_stamp :: UTCTime }
  94   deriving (Eq, Show)
  95
  96
  97
  98 -- | XML Representation of an 'EarlyLine'. It has the same
  99 --   fields, but in addition contains the 'xml_dates'.
 100 --
 101 data Message =
 102   Message {
 103     xml_xml_file_id :: Int,
 104     xml_heading :: String,
 105     xml_category :: String,
 106     xml_sport :: String,
 107     xml_title :: String,
 108     xml_dates :: [EarlyLineDate],
 109     xml_time_stamp :: UTCTime }
 110   deriving (Eq, Show)
 111
 112
 113 instance ToDb Message where
 114   -- | The database analogue of a 'Message' is an 'EarlyLine'.
 115   --
 116   type Db Message = EarlyLine
 117
 118
 119 -- | The 'FromXml' instance for 'Message' is required for the
 120 --   'XmlImport' instance.
 121 --
 122 instance FromXml Message where
 123   -- | To convert a 'Message' to an 'EarlyLine', we just drop
 124   --   the 'xml_dates'.
 125   --
 126   from_xml Message{..} =
 127     EarlyLine {
 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 }
 134
 135
 136 -- | This allows us to insert the XML representation 'Message'
 137 --   directly.
 138 --
 139 instance XmlImport Message
 140
 141
 142
 143 -- * EarlyLineDate
 144
 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.
 149 --
 150 data EarlyLineDate =
 151   EarlyLineDate {
 152     date_value :: UTCTime,
 153     date_note :: String,
 154     date_game :: EarlyLineGameXml }
 155   deriving (Eq, Show)
 156
 157
 158
 159 -- * EarlyLineGame / EarlyLineGameXml
 160
 161 data EarlyLineGame =
 162   EarlyLineGame {
 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 }
 169
 170 data EarlyLineGameXml =
 171   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 }
 176   deriving (Eq, Show)
 177
 178
 179 -- | XML representation of an earlyline team. It doubles as an
 180 --   embedded type within the DB representation 'EarlyLineGame'.
 181 --
 182 data EarlyLineGameTeam =
 183   EarlyLineGameTeam {
 184     db_rotation_number :: Int,
 185     db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
 186     db_team_name :: String }
 187   deriving (Eq, Show)
 188
 189
 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.
 194 --
 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.
 198 --
 199 date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDate -> EarlyLineGame
 200 date_to_game fk date =
 201   EarlyLineGame {
 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) }
 208   where
 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)
 212
 213 --
 214 -- * Database stuff
 215 --
 216
 217 instance DbImport Message where
 218   dbmigrate _ =
 219     run_dbmigrate $ do
 220       migrate (undefined :: EarlyLine)
 221       migrate (undefined :: EarlyLineGame)
 222
 223   dbimport m = do
 224     -- Insert the message and obtain its ID.
 225     msg_id <- insert_xml m
 226
 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
 232       insert_ game
 233
 234     return ImportSucceeded
 235
 236
 237 mkPersist tsn_codegen_config [groundhog|
 238
 239 - entity: EarlyLine
 240   dbName: early_lines
 241   constructors:
 242     - name: EarlyLine
 243       uniques:
 244         - name: unique_early_lines
 245           type: constraint
 246           # Prevent multiple imports of the same message.
 247           fields: [db_xml_file_id]
 248
 249
 250 - entity: EarlyLineGame
 251   dbName: early_lines_games
 252   constructors:
 253     - name: EarlyLineGame
 254       fields:
 255         - name: db_early_lines_id
 256           reference:
 257             onDelete: cascade
 258         - name: db_away_team
 259           embeddedType:
 260             - {name: rotation_number, dbName: away_team_rotation_number}
 261             - {name: line, dbName: away_team_line}
 262             - {name: team_name, dbName: away_team_name}
 263         - name: db_home_team
 264           embeddedType:
 265             - {name: rotation_number, dbName: home_team_rotation_number}
 266             - {name: line, dbName: home_team_line}
 267             - {name: team_name, dbName: home_team_name}
 268
 269 - embedded: EarlyLineGameTeam
 270   fields:
 271     - name: db_rotation_number
 272       dbName: rotation_number
 273     - name: db_line
 274       dbName: line
 275     - name: db_team_name
 276       dbName: team_name
 277
 278 |]
 279
 280
 281
 282 --
 283 -- * Pickling
 284 --
 285
 286
 287 -- | Pickler for the top-level 'Message'.
 288 --
 289 pickle_message :: PU Message
 290 pickle_message =
 291   xpElem "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)
 298              (xpList pickle_date)
 299              (xpElem "time_stamp" xp_time_stamp)
 300   where
 301     from_tuple = uncurryN Message
 302     to_tuple m = (xml_xml_file_id m,
 303                   xml_heading m,
 304                   xml_category m,
 305                   xml_sport m,
 306                   xml_title m,
 307                   xml_dates m,
 308                   xml_time_stamp m)
 309
 310
 311 -- | Pickler for the \<date\> elements within each \<message\>.
 312 --
 313 pickle_date :: PU EarlyLineDate
 314 pickle_date =
 315   xpElem "date" $
 316     xpWrap (from_tuple, to_tuple) $
 317     xpTriple (xpAttr "value" xp_early_line_date)
 318              (xpElem "note" xpText)
 319              pickle_game
 320   where
 321     from_tuple = uncurryN EarlyLineDate
 322     to_tuple m = (date_value m, date_note m, date_game m)
 323
 324
 325
 326 -- | Pickler for the \<game\> element within each \<date\>.
 327 --
 328 pickle_game :: PU EarlyLineGameXml
 329 pickle_game =
 330   xpElem "game" $
 331     xpWrap (from_tuple, to_tuple) $
 332     xp4Tuple (xpElem "time" xp_ambiguous_time)
 333              pickle_away_team
 334              pickle_home_team
 335              (xpElem "over_under" xpText)
 336   where
 337     from_tuple = uncurryN EarlyLineGameXml
 338     to_tuple m = (xml_game_time m,
 339                   xml_away_team m,
 340                   xml_home_team m,
 341                   xml_over_under m)
 342
 343
 344
 345 -- | Pickle an away team (\<teamA\>) element within a \<game\>. Most
 346 --   of the work (common with the home team pickler) is done by
 347 --   'pickle_team'.
 348 --
 349 pickle_away_team :: PU EarlyLineGameTeam
 350 pickle_away_team = xpElem "teamA" pickle_team
 351
 352
 353 -- | Pickle a home team (\<teamH\>) element within a \<game\>. Most
 354 --   of the work (common with theaway team pickler) is done by
 355 --   'pickle_team'.
 356 --
 357 pickle_home_team :: PU EarlyLineGameTeam
 358 pickle_home_team = xpElem "teamH" pickle_team
 359
 360
 361 -- | Team pickling common to both 'pickle_away_team' and
 362 --   'pickle_home_team'. Handles everything inside the \<teamA\> and
 363 --   \<teamH\> elements.
 364 --
 365 pickle_team :: PU EarlyLineGameTeam
 366 pickle_team =
 367   xpWrap (from_tuple, to_tuple) $
 368   xpTriple (xpAttr "rotation" xpInt)
 369            (xpAttr "line" (xpOption xpText))
 370            xpText
 371   where
 372     from_tuple = uncurryN EarlyLineGameTeam
 373     to_tuple m = (db_rotation_number m, db_line m, db_team_name m)
 374
 375
 376
 377 --
 378 -- * Tasty Tests
 379 --
 380
 381 -- | A list of all tests for this module.
 382 --
 383 early_line_tests :: TestTree
 384 early_line_tests =
 385   testGroup
 386     "EarlyLine tests"
 387     [ test_on_delete_cascade,
 388       test_pickle_of_unpickle_is_identity,
 389       test_unpickle_succeeds ]
 390
 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.
 394 --
 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
 400     actual @?= expected
 401
 402
 403
 404 -- | Make sure we can actually unpickle these things.
 405 --
 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
 411
 412     let expected = True
 413     actual @?= expected
 414
 415
 416
 417 -- | Make sure everything gets deleted when we delete the top-level
 418 --   record.
 419 --
 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
 427
 428     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 429                 runMigration silentMigrationLogger $ do
 430                   migrate a
 431                   migrate b
 432                 _ <- dbimport results
 433                 deleteAll a
 434                 count_a <- countAll a
 435                 count_b <- countAll b
 436                 return $ sum [count_a, count_b]
 437     let expected = 0
 438     actual @?= expected