]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - XML/GameInfo.hs
Allow "TBA" laps in TSN.XML.AutoRacingSchedule.
[dead/htsn-import.git] / XML / GameInfo.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE QuasiQuotes #-}
4 {-# LANGUAGE RecordWildCards #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- | GameInfo represents a collection of DTDs that we don't really
9 -- handle but want to make available. The raw XML gets stored in the
10 -- database along with the XML_File_ID, but we don't parse any of it.
11 --
12 -- See also: TSN.XML.SportInfo
13 --
14 module TSN.XML.GameInfo (
15 dtds,
16 game_info_tests,
17 parse_xml,
18 -- * WARNING: these are private but exported to silence warnings
19 GameInfoConstructor(..) )
20 where
21
22 -- System imports.
23 import Data.Either ( rights )
24 import Data.String.Utils ( replace )
25 import Data.Time.Clock ( UTCTime )
26 import Database.Groundhog (
27 countAll,
28 insert_,
29 migrate,
30 runMigration,
31 silentMigrationLogger )
32 import Database.Groundhog.Generic ( runDbConn )
33 import Database.Groundhog.Sqlite ( withSqliteConn )
34 import Database.Groundhog.TH (
35 defaultCodegenConfig,
36 groundhog,
37 mkPersist )
38 import Test.Tasty ( TestTree, testGroup )
39 import Test.Tasty.HUnit ( (@?=), testCase )
40 import Text.XML.HXT.Core ( XmlTree )
41 import Text.XML.HXT.DOM.ShowXml ( xshow )
42
43 -- Local imports.
44 import TSN.DbImport (
45 DbImport(..),
46 ImportResult(..),
47 run_dbmigrate )
48 import TSN.Parse (
49 parse_message,
50 parse_xmlfid,
51 parse_xml_time_stamp )
52 import Xml ( unsafe_read_document )
53
54
55 -- | The DTDs for everything that we consider \"Game Info.\"
56 --
57 -- TODO: This is the list from the old implementation. We need to
58 -- make sure that we are really receiving XML for these DTDs
59 -- (i.e. the names are correct).
60 --
61 dtds :: [String]
62 dtds =
63 [ "CBASK_Lineup_XML.dtd",
64 "cbaskpreviewxml.dtd",
65 "cflpreviewxml.dtd",
66 "Matchup_NBA_NHL_XML.dtd",
67 "mlbpreviewxml.dtd",
68 "MLB_Gaming_Matchup_XML.dtd",
69 "MLB_Lineup_XML.dtd",
70 "MLB_Matchup_XML.dtd",
71 "MLS_Preview_XML.dtd",
72 "NBA_Gaming_Matchup_XML.dtd",
73 "NBA_Playoff_Matchup_XML.dtd",
74 "NBALineupXML.dtd",
75 "nbapreviewxml.dtd",
76 "NCAA_FB_Preview_XML.dtd",
77 "nflpreviewxml.dtd",
78 "NFL_NCAA_FB_Matchup_XML.dtd",
79 "nhlpreviewxml.dtd",
80 "recapxml.dtd",
81 "WorldBaseballPreviewXML.dtd" ]
82
83
84 -- | This serves as both the database and XML representation of a
85 -- GameInfo \<message\>.
86 --
87 data GameInfo =
88 GameInfo {
89 dtd :: String,
90 xml_file_id :: Int,
91 time_stamp :: UTCTime,
92 xml :: String }
93 deriving (Eq, Show)
94
95
96 -- | Attempt to parse a 'GameInfo' from an 'XmlTree'. If we cannot,
97 -- we fail with an error message.
98 --
99 parse_xml :: String -> XmlTree -> Either String GameInfo
100 parse_xml dtdname xmltree = do
101 xmlfid <- parse_xmlfid xmltree
102 timestamp <- parse_xml_time_stamp xmltree
103 message <- parse_message xmltree
104 return $ GameInfo dtdname (fromInteger xmlfid) timestamp (xshow [message])
105
106 --
107 -- Database code
108 --
109
110 instance DbImport GameInfo where
111 dbmigrate _ =
112 run_dbmigrate $ migrate (undefined :: GameInfo)
113
114 -- | We import a 'GameInfo' by inserting the whole thing at
115 -- once. Nothing fancy going on here.
116 dbimport msg = do
117 insert_ msg
118 return ImportSucceeded
119
120
121 -- | The database schema for GameInfo is trivial; all we need is for
122 -- the XML_File_ID to be unique.
123 --
124 mkPersist defaultCodegenConfig [groundhog|
125 - entity: GameInfo
126 constructors:
127 - name: GameInfo
128 uniques:
129 - name: unique_game_info
130 type: constraint
131 # Prevent multiple imports of the same message.
132 fields: [xml_file_id]
133 |]
134
135
136 --
137 -- Tasty Tests
138 --
139
140 -- | A list of all tests for this module.
141 --
142 game_info_tests :: TestTree
143 game_info_tests =
144 testGroup
145 "GameInfo tests"
146 [ test_accessors,
147 test_parse_xml_succeeds,
148 test_dbimport_succeeds ]
149
150
151 -- | Make sure the accessors work and that we can parse one file. Ok,
152 -- so the real point of this is to make the unused fields (dtd, xml,
153 -- ...) warning go away without having to mangle the groundhog code.
154 --
155 test_accessors :: TestTree
156 test_accessors = testCase "we can access a parsed game_info" $ do
157 xmltree <- unsafe_read_document "test/xml/gameinfo/recapxml.xml"
158 let Right t = parse_xml "recapxml.dtd" xmltree
159 let a1 = dtd t
160 let ex1 = "recapxml.dtd"
161 let a2 = xml_file_id t
162 let ex2 = 21201550
163 let a3 = show $ time_stamp t
164 let ex3 = "2014-05-31 20:13:00 UTC"
165 let a4 = take 9 (xml t)
166 let ex4 = "<message>"
167 let actual = (a1,a2,a3,a4)
168 let expected = (ex1,ex2,ex3,ex4)
169 actual @?= expected
170
171
172 -- | Sample XML documents for GameInfo types.
173 --
174 game_info_test_files :: [FilePath]
175 game_info_test_files =
176 map (change_suffix . add_path) dtds
177 where
178 add_path = ("test/xml/gameinfo/" ++ )
179 change_suffix = replace ".dtd" ".xml"
180
181 -- | Make sure we can parse every element of 'game_info_test_files'.
182 --
183 test_parse_xml_succeeds :: TestTree
184 test_parse_xml_succeeds =
185 testGroup "parse_xml" $ map check game_info_test_files
186 where
187 check t = testCase t $ do
188 x <- unsafe_read_document t
189 let result = parse_xml "dummy" x
190 let actual = case result of -- isRight appears in base-4.7
191 Left _ -> False
192 Right _ -> True
193 let expected = True
194 actual @?= expected
195
196
197 -- | Ensure that each element of 'game_info_test_files' can be imported
198 -- by counting the total number of database records (after
199 -- importing) and comparing it against the length of
200 -- 'game_info_test_files'.
201 --
202 test_dbimport_succeeds :: TestTree
203 test_dbimport_succeeds = testCase "dbimport succeeds" $ do
204 xmltrees <- mapM unsafe_read_document game_info_test_files
205 let msgs = rights $ map (parse_xml "dummy") xmltrees
206 actual <- withSqliteConn ":memory:" $ runDbConn $ do
207 runMigration silentMigrationLogger $
208 migrate (undefined :: GameInfo)
209 mapM_ dbimport msgs
210 countAll (undefined :: GameInfo)
211
212 actual @?= expected
213 where
214 expected = length game_info_test_files