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 module TSN.XML.EarlyLine (
   9   dtd,
  10   pickle_message,
  11   -- * Tests
  12   early_line_tests,
  13   -- * WARNING: these are private but exported to silence warnings
  14   EarlyLineConstructor(..),
  15   EarlyLineGameConstructor(..) )
  16 where
  17
  18 -- System imports.
  19 import Control.Monad ( forM_ )
  20 import Data.Time ( UTCTime(..) )
  21 import Data.Tuple.Curry ( uncurryN )
  22 import Database.Groundhog (
  23   countAll,
  24   deleteAll,
  25   insert_,
  26   migrate,
  27   runMigration,
  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 (
  33   groundhog,
  34   mkPersist )
  35 import Test.Tasty ( TestTree, testGroup )
  36 import Test.Tasty.HUnit ( (@?=), testCase )
  37 import Text.XML.HXT.Core (
  38   PU,
  39   xp4Tuple,
  40   xp7Tuple,
  41   xpAttr,
  42   xpElem,
  43   xpInt,
  44   xpList,
  45   xpOption,
  46   xpText,
  47   xpTriple,
  48   xpWrap )
  49
  50 -- Local imports.
  51 import TSN.Codegen ( tsn_codegen_config )
  52 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  53 import TSN.Picklers (
  54   xp_ambiguous_time,
  55   xp_early_line_date,
  56   xp_time_stamp )
  57 import TSN.XmlImport ( XmlImport(..) )
  58 import Xml (
  59   FromXml(..),
  60   ToDb(..),
  61   pickle_unpickle,
  62   unpickleable,
  63   unsafe_unpickle )
  64
  65
  66 -- | The DTD to which this module corresponds. Used to invoke dbimport.
  67 --
  68 dtd :: String
  69 dtd = "earlylineXML.dtd"
  70
  71 --
  72 -- DB/XML data types
  73 --
  74
  75 -- * EarlyLine/Message
  76
  77 -- | Database representation of a 'Message'. It lacks the \<date\>
  78 --   elements since they're really properties of the games that they
  79 --   contain.
  80 --
  81 data EarlyLine =
  82   EarlyLine {
  83     db_xml_file_id :: Int,
  84     db_heading :: String,
  85     db_category :: String,
  86     db_sport :: String,
  87     db_title :: String,
  88     db_time_stamp :: UTCTime }
  89   deriving (Eq, Show)
  90
  91
  92
  93 -- | XML Representation of an 'EarlyLine'. It has the same
  94 --   fields, but in addition contains the 'xml_dates'.
  95 --
  96 data Message =
  97   Message {
  98     xml_xml_file_id :: Int,
  99     xml_heading :: String,
 100     xml_category :: String,
 101     xml_sport :: String,
 102     xml_title :: String,
 103     xml_dates :: [EarlyLineDateXml],
 104     xml_time_stamp :: UTCTime }
 105   deriving (Eq, Show)
 106
 107
 108 instance ToDb Message where
 109   -- | The database analogue of a 'Message' is an 'EarlyLine'.
 110   --
 111   type Db Message = EarlyLine
 112
 113
 114 -- | The 'FromXml' instance for 'Message' is required for the
 115 --   'XmlImport' instance.
 116 --
 117 instance FromXml Message where
 118   -- | To convert a 'Message' to an 'EarlyLine', we just drop
 119   --   the 'xml_dates'.
 120   --
 121   from_xml Message{..} =
 122     EarlyLine {
 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 }
 129
 130
 131 -- | This allows us to insert the XML representation 'Message'
 132 --   directly.
 133 --
 134 instance XmlImport Message
 135
 136
 137
 138 -- * EarlyLineDateXml
 139
 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.
 144 --
 145 data EarlyLineDateXml =
 146   EarlyLineDateXml {
 147     xml_date_value :: UTCTime,
 148     xml_note :: String,
 149     xml_game :: EarlyLineGameXml }
 150   deriving (Eq, Show)
 151
 152
 153
 154 -- * EarlyLineGame / EarlyLineGameXml
 155
 156 data EarlyLineGame =
 157   EarlyLineGame {
 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 }
 164
 165 data EarlyLineGameXml =
 166   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 }
 171   deriving (Eq, Show)
 172
 173
 174 -- | XML representation of an earlyline team. It doubles as an
 175 --   embedded type within the DB representation 'EarlyLineGame'.
 176 --
 177 data EarlyLineGameTeam =
 178   EarlyLineGameTeam {
 179     db_rotation_number :: Int,
 180     db_line :: Maybe String, -- ^ Can be blank, a Double, or \"off\".
 181     db_team_name :: String }
 182   deriving (Eq, Show)
 183
 184
 185 date_to_game :: (DefaultKey EarlyLine) -> EarlyLineDateXml -> EarlyLineGame
 186 date_to_game fk date =
 187   EarlyLineGame {
 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) }
 194   where
 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)
 198
 199 --
 200 -- * Database stuff
 201 --
 202
 203 instance DbImport Message where
 204   dbmigrate _ =
 205     run_dbmigrate $ do
 206       migrate (undefined :: EarlyLine)
 207       migrate (undefined :: EarlyLineGame)
 208
 209   dbimport m = do
 210     -- Insert the message and obtain its ID.
 211     msg_id <- insert_xml m
 212
 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
 218       insert_ game
 219
 220     return ImportSucceeded
 221
 222
 223 mkPersist tsn_codegen_config [groundhog|
 224
 225 - entity: EarlyLine
 226   dbName: early_lines
 227   constructors:
 228     - name: EarlyLine
 229       uniques:
 230         - name: unique_early_lines
 231           type: constraint
 232           # Prevent multiple imports of the same message.
 233           fields: [db_xml_file_id]
 234
 235
 236 - entity: EarlyLineGame
 237   dbName: early_lines_games
 238   constructors:
 239     - name: EarlyLineGame
 240       fields:
 241         - name: db_early_lines_id
 242           reference:
 243             onDelete: cascade
 244         - name: db_away_team
 245           embeddedType:
 246             - {name: rotation_number, dbName: away_team_rotation_number}
 247             - {name: line, dbName: away_team_line}
 248             - {name: team_name, dbName: away_team_name}
 249         - name: db_home_team
 250           embeddedType:
 251             - {name: rotation_number, dbName: home_team_rotation_number}
 252             - {name: line, dbName: home_team_line}
 253             - {name: team_name, dbName: home_team_name}
 254
 255 - embedded: EarlyLineGameTeam
 256   fields:
 257     - name: db_rotation_number
 258       dbName: rotation_number
 259     - name: db_line
 260       dbName: line
 261     - name: db_team_name
 262       dbName: team_name
 263
 264 |]
 265
 266
 267
 268 --
 269 -- * Pickling
 270 --
 271 pickle_message :: PU Message
 272 pickle_message =
 273   xpElem "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)
 280              (xpList pickle_date)
 281              (xpElem "time_stamp" xp_time_stamp)
 282   where
 283     from_tuple = uncurryN Message
 284     to_tuple m = (xml_xml_file_id m,
 285                   xml_heading m,
 286                   xml_category m,
 287                   xml_sport m,
 288                   xml_title m,
 289                   xml_dates m,
 290                   xml_time_stamp m)
 291
 292 pickle_date :: PU EarlyLineDateXml
 293 pickle_date =
 294   xpElem "date" $
 295     xpWrap (from_tuple, to_tuple) $
 296     xpTriple (xpAttr "value" xp_early_line_date)
 297              (xpElem "note" xpText)
 298              pickle_game
 299   where
 300     from_tuple = uncurryN EarlyLineDateXml
 301     to_tuple m = (xml_date_value m, xml_note m, xml_game m)
 302
 303
 304 pickle_game :: PU EarlyLineGameXml
 305 pickle_game =
 306   xpElem "game" $
 307     xpWrap (from_tuple, to_tuple) $
 308     xp4Tuple (xpElem "time" xp_ambiguous_time)
 309              pickle_away_team
 310              pickle_home_team
 311              (xpElem "over_under" xpText)
 312   where
 313     from_tuple = uncurryN EarlyLineGameXml
 314     to_tuple m = (xml_game_time m,
 315                   xml_away_team m,
 316                   xml_home_team m,
 317                   xml_over_under m)
 318
 319
 320
 321 pickle_away_team :: PU EarlyLineGameTeam
 322 pickle_away_team = xpElem "teamA" pickle_team
 323
 324 pickle_home_team :: PU EarlyLineGameTeam
 325 pickle_home_team = xpElem "teamH" pickle_team
 326
 327 pickle_team :: PU EarlyLineGameTeam
 328 pickle_team =
 329   xpWrap (from_tuple, to_tuple) $
 330   xpTriple (xpAttr "rotation" xpInt)
 331            (xpAttr "line" (xpOption xpText))
 332            xpText
 333   where
 334     from_tuple = uncurryN EarlyLineGameTeam
 335     to_tuple m = (db_rotation_number m, db_line m, db_team_name m)
 336
 337
 338
 339 --
 340 -- * Tasty Tests
 341 --
 342
 343 -- | A list of all tests for this module.
 344 --
 345 early_line_tests :: TestTree
 346 early_line_tests =
 347   testGroup
 348     "EarlyLine tests"
 349     [ test_on_delete_cascade,
 350       test_pickle_of_unpickle_is_identity,
 351       test_unpickle_succeeds ]
 352
 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.
 356 --
 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
 362     actual @?= expected
 363
 364
 365
 366 -- | Make sure we can actually unpickle these things.
 367 --
 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
 373
 374     let expected = True
 375     actual @?= expected
 376
 377
 378
 379 -- | Make sure everything gets deleted when we delete the top-level
 380 --   record.
 381 --
 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
 389
 390     actual <- withSqliteConn ":memory:" $ runDbConn $ do
 391                 runMigration silentMigrationLogger $ do
 392                   migrate a
 393                   migrate b
 394                 _ <- dbimport results
 395                 deleteAll a
 396                 count_a <- countAll a
 397                 count_b <- countAll b
 398                 return $ sum [count_a, count_b]
 399     let expected = 0
 400     actual @?= expected