]> gitweb.michael.orlitzky.com - dead/htsn-import.git/blob - src/TSN/XML/GameInfo.hs
Add a minor TODO note.
[dead/htsn-import.git] / src / TSN / 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 gameinfo_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.Time.Clock ( UTCTime )
25 import Database.Groundhog (
26 countAll,
27 migrate,
28 runMigration,
29 silentMigrationLogger )
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 ( XmlTree )
38 import Text.XML.HXT.DOM.ShowXml ( xshow )
39
40 -- Local imports.
41 import TSN.Codegen ( tsn_codegen_config )
42 import TSN.DbImport (
43 DbImport(..),
44 ImportResult(..),
45 run_dbmigrate )
46 import TSN.Parse (
47 parse_message,
48 parse_xmlfid,
49 parse_xml_time_stamp )
50 import TSN.XmlImport ( XmlImport(..) )
51 import Xml (
52 FromXml(..),
53 ToDb(..),
54 unsafe_read_document )
55
56
57 -- | The DTDs for everything that we consider "Game Info."
58 --
59 -- TODO: This is the list from the old implementation. We need to
60 -- make sure that we are really receiving XML for these DTDs
61 -- (i.e. the names are correct).
62 --
63 dtds :: [String]
64 dtds =
65 [ "CBASK_Lineup_XML.dtd",
66 "cbaskpreviewxml.dtd",
67 "cflpreviewxml.dtd",
68 "Matchup_NBA_NHL_XML.dtd",
69 "mlbpreviewxml.dtd",
70 "MLB_Gaming_Matchup_XML.dtd",
71 "MLB_Lineup_XML.dtd",
72 "MLB_Matchup_XML.dtd",
73 "MLS_Preview_XML.dtd",
74 "NBA_Gaming_Matchup_XML.dtd",
75 "NBA_Playoff_Matchup_XML.dtd",
76 "NBALineupXML.dtd",
77 "nbapreviewxml.dtd",
78 "NCAA_FB_Preview_XML.dtd",
79 "nflpreviewxml.dtd",
80 "NFL_NCAA_FB_Matchup_XML.dtd",
81 "nhlpreviewxml.dtd",
82 "recapxml.dtd",
83 "WorldBaseballPreviewXML.dtd" ]
84
85
86 -- | XML representation of a GameInfo \<message\>.
87 --
88 data Message =
89 Message {
90 xml_dtd :: String,
91 xml_xml_file_id :: Int,
92 xml_time_stamp :: UTCTime,
93 xml_xml :: String }
94 deriving (Eq, Show)
95
96
97 -- | Attempt to parse a 'Message' from an 'XmlTree'. If we cannot,
98 -- we fail with an error message.
99 --
100 parse_xml :: String -> XmlTree -> Either String Message
101 parse_xml dtdname xmltree = do
102 xmlfid <- parse_xmlfid xmltree
103 timestamp <- parse_xml_time_stamp xmltree
104 message <- parse_message xmltree
105 return $ Message dtdname (fromInteger xmlfid) timestamp (xshow [message])
106
107
108 -- | Database representation of a 'Message'.
109 --
110 data GameInfo =
111 GameInfo {
112 db_dtd :: String,
113 db_xml_file_id :: Int,
114 db_time_stamp :: UTCTime,
115 db_xml :: String }
116
117
118 instance ToDb Message where
119 -- | The database analogue of a 'Message' is an 'GameInfo'.
120 type Db Message = GameInfo
121
122 instance FromXml Message where
123 -- | The XML to DB conversion is trivial here.
124 --
125 from_xml Message{..} = GameInfo {
126 db_dtd = xml_dtd,
127 db_xml_file_id = xml_xml_file_id,
128 db_time_stamp = xml_time_stamp,
129 db_xml = xml_xml }
130
131
132 -- | This allows us to insert the XML representation 'Message'
133 -- directly.
134 --
135 instance XmlImport Message
136
137
138 --
139 -- Database code
140 --
141
142 instance DbImport Message where
143 dbmigrate _ =
144 run_dbmigrate $ migrate (undefined :: GameInfo)
145
146 -- | We import a 'Message' by inserting the whole thing at
147 -- once. Nothing fancy going on here.
148 dbimport msg = do
149 insert_xml_ msg
150 return ImportSucceeded
151
152
153 -- | The database schema for GameInfo is trivial; all we need is for
154 -- the XML_File_ID to be unique.
155 --
156 mkPersist tsn_codegen_config [groundhog|
157 - entity: GameInfo
158 constructors:
159 - name: GameInfo
160 uniques:
161 - name: unique_game_info
162 type: constraint
163 # Prevent multiple imports of the same message.
164 fields: [db_xml_file_id]
165 |]
166
167
168 --
169 -- Tasty Tests
170 --
171
172 -- | A list of all tests for this module.
173 --
174 gameinfo_tests :: TestTree
175 gameinfo_tests =
176 testGroup
177 "GameInfo tests"
178 [ test_parse_xml_succeeds,
179 test_dbimport_succeeds ]
180
181
182 -- | Sample XML documents for GameInfo types.
183 --
184 gameinfo_test_files :: [FilePath]
185 gameinfo_test_files =
186 [ "test/xml/gameinfo/CBASK_Lineup_XML.xml",
187 "test/xml/gameinfo/cbaskpreviewxml.xml",
188 "test/xml/gameinfo/cflpreviewxml.xml",
189 "test/xml/gameinfo/Matchup_NBA_NHL_XML.xml",
190 "test/xml/gameinfo/MLB_Gaming_Matchup_XML.xml",
191 "test/xml/gameinfo/MLB_Lineup_XML.xml",
192 "test/xml/gameinfo/MLB_Matchup_XML.xml",
193 "test/xml/gameinfo/mlbpreviewxml.xml",
194 "test/xml/gameinfo/MLS_Preview_XML.xml",
195 "test/xml/gameinfo/NBA_Gaming_Matchup_XML.xml",
196 "test/xml/gameinfo/NBALineupXML.xml",
197 "test/xml/gameinfo/NBA_Playoff_Matchup_XML.xml",
198 "test/xml/gameinfo/NCAA_FB_Preview_XML.xml",
199 "test/xml/gameinfo/nbapreviewxml.xml",
200 "test/xml/gameinfo/nflpreviewxml.xml",
201 "test/xml/gameinfo/NFL_NCAA_FB_Matchup_XML.xml",
202 "test/xml/gameinfo/nhlpreviewxml.xml",
203 "test/xml/gameinfo/recapxml.xml",
204 "test/xml/gameinfo/WorldBaseballPreviewXML.xml" ]
205
206
207 -- | Make sure we can parse every element of 'gameinfo_test_files'.
208 --
209 test_parse_xml_succeeds :: TestTree
210 test_parse_xml_succeeds =
211 testGroup "parse_xml" $ map check gameinfo_test_files
212 where
213 check t = testCase t $ do
214 x <- unsafe_read_document t
215 let result = parse_xml "dummy" x
216 let actual = case result of -- isRight appears in base-4.7
217 Left _ -> False
218 Right _ -> True
219 let expected = True
220 actual @?= expected
221
222
223 -- | Ensure that each element of 'gameinfo_test_files' can be imported
224 -- by counting the total number of database records (after
225 -- importing) and comparing it against the length of
226 -- 'gameinfo_test_files'.
227 --
228 test_dbimport_succeeds :: TestTree
229 test_dbimport_succeeds = testCase "dbimport succeeds" $ do
230 xmltrees <- mapM unsafe_read_document gameinfo_test_files
231 let msgs = rights $ map (parse_xml "dummy") xmltrees
232 actual <- withSqliteConn ":memory:" $ runDbConn $ do
233 runMigration silentMigrationLogger $ do
234 migrate (undefined :: GameInfo)
235 mapM_ dbimport msgs
236 countAll (undefined :: GameInfo)
237
238 actual @?= expected
239 where
240 expected = length gameinfo_test_files