Make the JFile <Game_Time> elements optional (they can contain "TBA").

[dead/htsn-import.git] / src / TSN / XML / JFile.hs

diff --git a/src/TSN/XML/JFile.hs b/src/TSN/XML/JFile.hs
index 51db0abfa32af3b0be591e1099803a5289b4b853..84e6b66ebd642e148241a7d5acc042bb66dfa880 100644 (file)
--- a/src/TSN/XML/JFile.hs
+++ b/src/TSN/XML/JFile.hs
@@ -67,17 +67,20 @@ import TSN.Picklers (
   xp_date,
   xp_date_padded,
   xp_datetime,
-  xp_time,
+  xp_tba_time,
   xp_time_dots,
   xp_time_stamp )
-import TSN.Team ( Team(..) )
+import TSN.Team (
+  FromXmlFkTeams(..),
+  HTeam(..),
+  Team(..),
+  VTeam(..) )
 import TSN.XmlImport (
   XmlImport(..),
   XmlImportFkTeams(..) )
 import Xml (
   Child(..),
   FromXml(..),
-  FromXmlFkTeams(..),
   ToDb(..),
   pickle_unpickle,
   unpickleable,
@@ -211,7 +214,7 @@ data JFileGame =
     db_schedule_id :: Int,
     db_odds_info :: JFileGameOddsInfo,
     db_season_type :: Maybe String,
-    db_game_time :: UTCTime,
+    db_game_time :: Maybe UTCTime,
     db_vleague :: Maybe String,
     db_hleague :: Maybe String,
     db_vscore :: Int,
@@ -233,10 +236,10 @@ data JFileGameXml =
     xml_odds_info :: JFileGameOddsInfo,
     xml_season_type :: Maybe String,
     xml_game_date :: UTCTime,
-    xml_game_time :: UTCTime,
-    xml_vteam :: Team,
+    xml_game_time :: Maybe UTCTime,
+    xml_vteam :: VTeam,
     xml_vleague :: Maybe String,
-    xml_hteam :: Team,
+    xml_hteam :: HTeam,
     xml_hleague :: Maybe String,
     xml_vscore :: Int,
     xml_hscore :: Int,
@@ -294,11 +297,15 @@ instance FromXmlFkTeams JFileGameXml where
       db_time_remaining = xml_time_remaining,
       db_game_status = xml_game_status }
     where
-      -- | Make the database \"game time\" from the XML
-      --   date/time. Simply take the day part from one and the time
-      --   from the other.
-      --
-      make_game_time d t = UTCTime (utctDay d) (utctDayTime t)
+      -- | Construct the database game time from the XML \<Game_Date\>
+      --   and \<Game_Time\> elements. The \<Game_Time\> elements
+      --   sometimes have a value of \"TBA\"; in that case, we don't
+      --   want to pretend that we know the time by setting it to
+      --   e.g. midnight, so instead we make the entire date/time
+      --   Nothing.
+      make_game_time :: UTCTime -> Maybe UTCTime -> Maybe UTCTime
+      make_game_time _ Nothing = Nothing
+      make_game_time d (Just t) = Just $ UTCTime (utctDay d) (utctDayTime t)
 
 
 -- | This allows us to insert the XML representation
@@ -325,8 +332,8 @@ instance DbImport Message where
     -- Now loop through the message's games
     forM_ (xml_games $ xml_gamelist m) $ \game -> do
       -- First we insert the home and away teams.
-      away_team_id <- insert_or_select (xml_vteam game)
-      home_team_id <- insert_or_select (xml_hteam game)
+      away_team_id <- insert_or_select (vteam $ xml_vteam game)
+      home_team_id <- insert_or_select (hteam $ xml_hteam game)
 
       -- Now insert the game keyed to the "jfile" and its teams.
       insert_xml_fk_teams_ msg_id away_team_id home_team_id game
@@ -353,8 +360,8 @@ mkPersist tsn_codegen_config [groundhog|
     - name: db_status
       dbName: status
 
-# Many of the JFileGameOddsInfo fields are redundant and have
-# been left out.
+  # Many of the JFileGameOddsInfo fields are redundant and have
+  # been left out.
 - embedded: JFileGameOddsInfo
   fields:
     - name: db_list_date
@@ -450,7 +457,7 @@ pickle_game =
               pickle_odds_info
               (xpElem "seasontype" (xpOption xpText))
               (xpElem "Game_Date" xp_date_padded)
-              (xpElem "Game_Time" xp_time)
+              (xpElem "Game_Time" xp_tba_time)
               pickle_away_team
               (xpOption $ xpElem "vleague" xpText)
               pickle_home_team
@@ -541,7 +548,7 @@ pickle_odds_info =
 -- | (Un)pickle a home team to/from the dual XML/DB representation
 --   'Team'.
 --
-pickle_home_team :: PU Team
+pickle_home_team :: PU HTeam
 pickle_home_team =
   xpElem "hteam" $
     xpWrap (from_tuple, to_tuple) $
@@ -549,16 +556,16 @@ pickle_home_team =
              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
              (xpOption xpText) -- Yup, some are nameless
   where
-    from_tuple = uncurryN Team
-    to_tuple t = (team_id t,
-                  abbreviation t,
-                  name t)
+    from_tuple = HTeam . (uncurryN Team)
+    to_tuple (HTeam t) = (team_id t,
+                          abbreviation t,
+                          name t)
 
 
 -- | (Un)pickle an away team to/from the dual XML/DB representation
 --   'Team'.
 --
-pickle_away_team :: PU Team
+pickle_away_team :: PU VTeam
 pickle_away_team =
   xpElem "vteam" $
     xpWrap (from_tuple, to_tuple) $
@@ -566,10 +573,10 @@ pickle_away_team =
              (xpAttr "abbr" (xpOption xpText)) -- Some are blank
              (xpOption xpText) -- Yup, some are nameless
   where
-    from_tuple = uncurryN Team
-    to_tuple t = (team_id t,
-                  abbreviation t,
-                  name t)
+    from_tuple = VTeam . (uncurryN Team)
+    to_tuple (VTeam t) = (team_id t,
+                          abbreviation t,
+                          name t)
 
 
 pickle_status :: PU JFileGameStatus
@@ -609,7 +616,10 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
   [ check "pickle composed with unpickle is the identity"
           "test/xml/jfilexml.xml",
     check "pickle composed with unpickle is the identity (missing fields)"
-          "test/xml/jfilexml-missing-fields.xml" ]
+          "test/xml/jfilexml-missing-fields.xml",
+
+    check "pickle composed with unpickle is the identity (TBA game time)"
+          "test/xml/jfilexml-tba-game-time.xml"]
   where
     check desc path = testCase desc $ do
       (expected, actual) <- pickle_unpickle pickle_message path
@@ -622,8 +632,12 @@ test_pickle_of_unpickle_is_identity = testGroup "pickle-unpickle tests"
 test_unpickle_succeeds :: TestTree
 test_unpickle_succeeds = testGroup "unpickle tests"
   [ check "unpickling succeeds" "test/xml/jfilexml.xml",
+
     check "unpickling succeeds (missing fields)"
-          "test/xml/jfilexml-missing-fields.xml" ]
+          "test/xml/jfilexml-missing-fields.xml",
+
+    check "unpickling succeeds (TBA game time)"
+          "test/xml/jfilexml-tba-game-time.xml" ]
   where
     check desc path = testCase desc $ do
     actual <- unpickleable path pickle_message
@@ -640,10 +654,15 @@ test_on_delete_cascade :: TestTree
 test_on_delete_cascade = testGroup "cascading delete tests"
   [ check "deleting auto_racing_results deletes its children"
           "test/xml/jfilexml.xml"
-          20,
+          20, -- teams
+
     check "deleting auto_racing_results deletes its children (missing fields)"
           "test/xml/jfilexml-missing-fields.xml"
-          44 ]
+          44,
+
+    check "deleting auto_racing_results deletes its children (TBA game time)"
+          "test/xml/jfilexml-tba-game-time.xml"
+          8 ]
   where
     check desc path expected = testCase desc $ do
       results <- unsafe_unpickle path pickle_message