src/TSN/XML/Scores.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE QuasiQuotes #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8
   9 -- | Parse TSN XML for the DTD \"scoresxml.dtd\". Each document
  10 --   contains a single \<game\> and some \<location\>s.
  11 --
  12 module TSN.XML.Scores (
  13   pickle_message,
  14   -- * Tests
  15   scores_tests,
  16   -- * WARNING: these are private but exported to silence warnings
  17   Score_ScoreLocationConstructor(..),
  18   ScoreConstructor(..),
  19   ScoreGameConstructor(..),
  20   ScoreGameTeamConstructor(..),
  21   ScoreLocationConstructor(..),
  22   ScoreGame_ScoreGameTeamConstructor(..) )
  23 where
  24
  25 -- System imports.
  26 import Control.Monad ( forM_ )
  27 import Data.Data ( Data )
  28 import Data.Time ( UTCTime )
  29 import Data.Tuple.Curry ( uncurryN )
  30 import Data.Typeable ( Typeable )
  31 import Database.Groundhog (
  32   countAll,
  33   executeRaw,
  34   migrate,
  35   runMigration,
  36   silentMigrationLogger )
  37 import Database.Groundhog.Core ( DefaultKey )
  38 import Database.Groundhog.Generic ( runDbConn )
  39 import Database.Groundhog.Sqlite ( withSqliteConn )
  40 import Database.Groundhog.TH (
  41   defaultCodegenConfig,
  42   groundhog,
  43   mkPersist )
  44 import Test.Tasty ( TestTree, testGroup )
  45 import Test.Tasty.HUnit ( (@?=), testCase )
  46 import Text.XML.HXT.Core (
  47   PU,
  48   xp7Tuple,
  49   xp11Tuple,
  50   xp12Tuple,
  51   xpAttr,
  52   xpElem,
  53   xpInt,
  54   xpList,
  55   xpOption,
  56   xpPair,
  57   xpPrim,
  58   xpText,
  59   xpTriple,
  60   xpWrap )
  61
  62 -- Local imports.
  63 import TSN.Codegen (
  64   tsn_codegen_config )
  65 import TSN.DbImport ( DbImport(..), ImportResult(..), run_dbmigrate )
  66 import TSN.Picklers ( xp_gamedate, xp_time_stamp )
  67 import TSN.XmlImport ( XmlImport(..), XmlImportFk(..) )
  68 import Xml (
  69   FromXml(..),
  70   FromXmlFk(..),
  71   ToDb(..),
  72   pickle_unpickle,
  73   unpickleable,
  74   unsafe_unpickle )
  75
  76
  77 --
  78 -- DB/XML Data types
  79 --
  80
  81
  82 -- * Score / Message
  83
  84 data Score =
  85   Score {
  86     db_xml_file_id :: Int,
  87     db_heading :: String,
  88     db_game_id :: Int,
  89     db_schedule_id :: Int,
  90     db_tsnupdate :: Maybe Bool,
  91     db_category :: String,
  92     db_sport :: String,
  93     db_season_type :: String,
  94     db_time_stamp :: UTCTime }
  95
  96 data Message =
  97   Message {
  98     xml_xml_file_id :: Int,
  99     xml_heading :: String,
 100     xml_game_id :: Int,
 101     xml_schedule_id :: Int,
 102     xml_tsnupdate :: Maybe Bool,
 103     xml_category :: String,
 104     xml_sport :: String,
 105     xml_locations :: [ScoreLocation],
 106     xml_season_type :: String,
 107     xml_game :: ScoreGameXml,
 108     xml_time_stamp :: UTCTime }
 109   deriving (Eq, Show)
 110
 111
 112 -- * ScoreGame / ScoreGameXml
 113
 114 data ScoreGameStatus =
 115   ScoreGameStatus {
 116     db_status_numeral :: Int,
 117     db_status_type :: String, -- ^ These are probably only one-character long,
 118                               --   but they all take the same amount of space
 119                               --   in Postgres.
 120     db_status_text :: String }
 121   deriving (Data, Eq, Show, Typeable)
 122
 123 data ScoreGame =
 124   ScoreGame {
 125     db_scores_id :: DefaultKey Score,
 126     db_vscore :: Int,
 127     db_hscore :: Int,
 128     db_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 129     db_status :: ScoreGameStatus,
 130     db_notes  :: Maybe String }
 131
 132
 133 data ScoreGameXml =
 134   ScoreGameXml {
 135     xml_vteam  :: ScoreGameVTeam,
 136     xml_hteam  :: ScoreGameHTeam,
 137     xml_vscore :: Int,
 138     xml_hscore :: Int,
 139     xml_time_r :: Maybe String, -- ^ Time remaining, the format is uncertain.
 140     xml_status :: ScoreGameStatus,
 141     xml_notes  :: Maybe String }
 142   deriving (Eq, Show)
 143
 144 -- * ScoreGameTeam
 145
 146 data ScoreGameTeam =
 147   ScoreGameTeam {
 148     team_id :: String,
 149     team_name :: String }
 150   deriving (Eq, Show)
 151
 152 newtype ScoreGameVTeam =
 153   ScoreGameVTeam ScoreGameTeam
 154   deriving (Eq, Show)
 155
 156 newtype ScoreGameHTeam =
 157   ScoreGameHTeam ScoreGameTeam
 158   deriving (Eq, Show)
 159
 160 -- * ScoreGame_ScoreGameTeam
 161
 162 -- | Join a ScoreGame with its home/away teams.
 163 --
 164 data ScoreGame_ScoreGameTeam =
 165   ScoreGame_ScoreGameTeam
 166     (DefaultKey ScoreGame) -- ^ game id
 167     (DefaultKey ScoreGameTeam) -- ^ vteam id
 168     (DefaultKey ScoreGameTeam) -- ^ hteam id
 169
 170
 171 -- * ScoreLocation
 172
 173 data ScoreLocation =
 174   ScoreLocation {
 175     city :: Maybe String,
 176     state :: Maybe String,
 177     country :: String }
 178   deriving (Eq, Show)
 179
 180
 181 -- * Score_ScoreLocation
 182
 183 data Score_ScoreLocation =
 184   Score_ScoreLocation
 185     (DefaultKey Score)
 186     (DefaultKey ScoreLocation)
 187
 188
 189
 190
 191
 192 -- These types don't have special XML representations or field name
 193 -- collisions so we use the defaultCodegenConfig and give their
 194 -- fields nice simple names.
 195 mkPersist defaultCodegenConfig [groundhog|
 196 - entity: ScoreGameTeam
 197   dbName: scores_games_teams
 198   constructors:
 199     - name: ScoreGameTeam
 200       uniques:
 201         - name: unique_scores_games_team
 202           type: constraint
 203           fields: [team_id]
 204
 205 - entity: ScoreLocation
 206   dbName: scores_locations
 207   constructors:
 208     - name: ScoreLocation
 209       uniques:
 210         - name: unique_scores_location
 211           type: constraint
 212           fields: [city, state, country]
 213
 214 |]
 215
 216
 217
 218 -- These types have fields with e.g. db_ and xml_ prefixes, so we
 219 -- use our own codegen to peel those off before naming the columns.
 220 mkPersist tsn_codegen_config [groundhog|
 221 - entity: Score
 222   constructors:
 223     - name: Score
 224       uniques:
 225         - name: unique_scores
 226           type: constraint
 227           # Prevent multiple imports of the same message.
 228           fields: [db_xml_file_id]
 229
 230 - embedded: ScoreGameStatus
 231   fields:
 232     - name: db_status_numeral
 233       dbName: status_numeral
 234     - name: db_status_type
 235       dbName: status_type
 236     - name: db_status_text
 237       dbName: status_text
 238
 239 - entity: ScoreGame
 240   dbName: scores_games
 241   constructors:
 242     - name: ScoreGame
 243       fields:
 244         - name: db_scores_id
 245           reference:
 246             onDelete: cascade
 247         - name: db_status
 248           embeddedType:
 249             - { name: status_numeral, dbName: status_numeral }
 250             - { name: status_type, dbName: status_type }
 251             - { name: status_text, dbName: status_text }
 252
 253 - entity: ScoreGame_ScoreGameTeam
 254   dbName: scores__scores_games_teams
 255   constructors:
 256     - name: ScoreGame_ScoreGameTeam
 257       fields:
 258         - name: scoreGame_ScoreGameTeam0 # Default created by mkNormalFieldName
 259           dbName: scores_games_id
 260           reference:
 261             onDelete: cascade
 262         - name: scoreGame_ScoreGameTeam1 # Default created by mkNormalFieldName
 263           dbName: scores_games_teams_vteam_id
 264           reference:
 265             onDelete: cascade
 266         - name: scoreGame_ScoreGameTeam2 # Default created by mkNormalFieldName
 267           dbName: scores_games_teams_hteam_id
 268           reference:
 269             onDelete: cascade
 270
 271 - entity: Score_ScoreLocation
 272   dbName: scores__scores_locations
 273   constructors:
 274     - name: Score_ScoreLocation
 275       fields:
 276         - name: score_ScoreLocation0 # Default created by mkNormalFieldName
 277           dbName: scores_id
 278           reference:
 279             onDelete: cascade
 280         - name: score_ScoreLocation1 # Default created by mkNormalFieldName
 281           dbName: scores_locations_id
 282           reference:
 283             onDelete: cascade
 284 |]
 285
 286
 287 --
 288 -- Pickling
 289 --
 290
 291 -- | Convert a 'Message' to/from XML.
 292 --
 293 pickle_message :: PU Message
 294 pickle_message =
 295   xpElem "message" $
 296     xpWrap (from_tuple, to_tuple) $
 297     xp11Tuple (xpElem "XML_File_ID" xpInt)
 298               (xpElem "heading" xpText)
 299               (xpElem "game_id" xpInt)
 300               (xpElem "schedule_id" xpInt)
 301               (xpOption $ xpElem "tsnupdate" xpPrim)
 302               (xpElem "category" xpText)
 303               (xpElem "sport" xpText)
 304               (xpList pickle_location)
 305               (xpElem "seasontype" xpText)
 306               pickle_game
 307               (xpElem "time_stamp" xp_time_stamp)
 308   where
 309     from_tuple = uncurryN Message
 310     to_tuple m = (xml_xml_file_id m,
 311                   xml_heading m,
 312                   xml_game_id m,
 313                   xml_schedule_id m,
 314                   xml_tsnupdate m,
 315                   xml_category m,
 316                   xml_sport m,
 317                   xml_locations m,
 318                   xml_season_type m,
 319                   xml_game m,
 320                   xml_time_stamp m)
 321
 322
 323
 324 -- | Convert a 'ScoreLocation' to/from XML.
 325 --
 326 pickle_location :: PU ScoreLocation
 327 pickle_location =
 328   xpElem "location" $
 329     xpWrap (from_tuple, to_tuple) $
 330     xpTriple (xpOption (xpElem "city" xpText))
 331              (xpOption (xpElem "state" xpText))
 332              (xpElem "country" xpText)
 333   where
 334     from_tuple =
 335       uncurryN ScoreLocation
 336     to_tuple l = (city l, state l, country l)
 337
 338
 339 pickle_status :: PU ScoreGameStatus
 340 pickle_status =
 341   xpElem "status" $
 342     xpWrap (from_tuple, to_tuple) $
 343       xpTriple (xpAttr "numeral" xpInt)
 344                (xpAttr "type" xpText)
 345                xpText
 346   where
 347     from_tuple = uncurryN ScoreGameStatus
 348     to_tuple (ScoreGameStatus x y z) = (x,y,z)
 349
 350 pickle_game :: PU ScoreGameXml
 351 pickle_game =
 352   xpElem "game" $
 353     xpWrap (from_tuple, to_tuple) $
 354       xp7Tuple pickle_vteam
 355                pickle_hteam
 356                (xpElem "vscore" xpInt)
 357                (xpElem "hscore" xpInt)
 358                (xpOption $ xpElem "time_r" xpText)
 359                pickle_status
 360                (xpOption $ xpElem "notes" xpText)
 361   where
 362     from_tuple = uncurryN ScoreGameXml
 363     to_tuple ScoreGameXml{..} = (xml_vteam,
 364                                  xml_hteam,
 365                                  xml_vscore,
 366                                  xml_hscore,
 367                                  xml_time_r,
 368                                  xml_status,
 369                                  xml_notes)
 370
 371
 372 pickle_vteam :: PU ScoreGameVTeam
 373 pickle_vteam =
 374   xpElem "vteam" $
 375     xpWrap (from_tuple, to_tuple) $
 376       xpPair (xpAttr "id" xpText)
 377              xpText
 378   where
 379     from_tuple = ScoreGameVTeam . uncurry ScoreGameTeam
 380     to_tuple (ScoreGameVTeam (ScoreGameTeam x y)) = (x,y)
 381
 382
 383 pickle_hteam :: PU ScoreGameHTeam
 384 pickle_hteam =
 385   xpElem "hteam" $
 386     xpWrap (from_tuple, to_tuple) $
 387       xpPair (xpAttr "id" xpText)
 388              xpText
 389   where
 390     from_tuple = ScoreGameHTeam  . uncurry ScoreGameTeam
 391     to_tuple (ScoreGameHTeam (ScoreGameTeam x y)) = (x,y)
 392
 393
 394 ---
 395 --- Tasty tests
 396 ---
 397
 398 -- | A list of all tests for this module.
 399 --
 400 scores_tests :: TestTree
 401 scores_tests =
 402   testGroup
 403     "Scores tests"
 404     [ test_pickle_of_unpickle_is_identity,
 405       test_unpickle_succeeds ]
 406
 407
 408 -- | If we unpickle something and then pickle it, we should wind up
 409 --   with the same thing we started with. WARNING: success of this
 410 --   test does not mean that unpickling succeeded.
 411 --
 412 test_pickle_of_unpickle_is_identity :: TestTree
 413 test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 414   [ check "pickle composed with unpickle is the identity"
 415           "test/xml/scoresxml.xml",
 416
 417     check "pickle composed with unpickle is the identity (no locations)"
 418           "test/xml/scoresxml-no-locations.xml" ]
 419   where
 420     check desc path = testCase desc $ do
 421       (expected, actual) <- pickle_unpickle pickle_message path
 422       actual @?= expected
 423
 424
 425 -- | Make sure we can actually unpickle these things.
 426 --
 427 test_unpickle_succeeds :: TestTree
 428 test_unpickle_succeeds = testGroup "unpickle tests"
 429   [ check "unpickling succeeds"
 430           "test/xml/scoresxml.xml",
 431
 432     check "unpickling succeeds (no locations)"
 433           "test/xml/scoresxml-no-locations.xml" ]
 434   where
 435     check desc path = testCase desc $ do
 436       actual <- unpickleable path pickle_message
 437       let expected = True
 438       actual @?= expected