« back to all changes in this revision
Viewing changes to daemons/Models.hs
- browse files at revision 619
- compare with another revision
- compare with revision 619
- download diff
- download tarball
- view history from revision 619
- Committer: Brian Kassouf
- Date: 2009-05-04 19:24:30 UTC
- mfrom: (615.2.28 resonate)
- Revision ID: brian@brian-laptop-20090504192430-d99ollvz4nrfkz27
pulled in the new revisions from trunk branch
- files added:
- .bzrignore
- daemons
- daemons/test
- daemons/test/resources
- files renamed:
- resonate/test/unit_tests/models/test_models.py => resonate/test/unit_tests/models/test_models_api.py
- files modified:
- resonate/__init__.py
added
removed
daemons/Models.hs
1
module Models (DatabaseParams(..), deleteTracksForHost, updateTrackListForHost,
2
removeOldObjectsFromDb,
3
{- XXX: These functions are only needed for running the test suite. How can we
4
hide it from everyone else? -}
5
insertOrUpdateTrack, updateTrackOrPrintError, connectToDatabase,
6
CollectionServer(..), findOrCreateCollectionServer,
7
findOrCreateArtist, findOrCreateAlbum, findOrCreateRelease,
8
findOrCreateEncoding, findOrCreateTrack, createFile, getId)
9
where
10
11
import Messages (Track(..), Tag(..))
12
import Database.HDBC.PostgreSQL (connectPostgreSQL, Connection)
13
import Database.HDBC (run, quickQuery', toSql, fromSql, handleSqlError,
14
catchSql, commit, disconnect, SqlType, SqlValue)
15
import Data.Maybe (fromJust)
16
import Data.List (intercalate)
17
import System.FilePath.Posix (takeExtension)
18
19
data DatabaseParams = DatabaseParams { dbName :: String, dbUsername :: String,
20
dbPassword :: String }
21
22
deleteTracksForHost dbParams hostname = do
23
c <- connectToDatabase dbParams
24
putStrLn $ "Going to delete files and tag values for server " ++ hostname ++ "."
25
handleSqlError $ do
26
server <- findOrCreateCollectionServer c hostname
27
r <- quickQuery' c
28
("delete from tag_values where file_id in " ++
29
"(select id from files where collection_server_id = ?)")
30
[toSql $ getId server]
31
r <- quickQuery' c "delete from files where collection_server_id = ?"
32
[toSql $ getId server]
33
commit c
34
putStrLn $ "Done deleting files and tag values for server " ++ hostname ++ "."
35
36
removeOldObjectsFromDb dbParams = do
37
c <- connectToDatabase dbParams
38
handleSqlError $ do
39
removeWhereNotReferenced c "release_encodings" "files" "release_encoding_id"
40
--removeWhereNotReferenced c "tracks" "files" "track_id"
41
--removeWhereNotReferenced c "releases" "tracks" "release_id"
42
--removeWhereNotReferenced c "albums" "releases" "album_id"
43
artistIdLists <- mapM
44
(\table -> do
45
r <- quickQuery' c ("select artist_id from " ++ table) []
46
return $ map head r)
47
["albums", "tracks"]
48
let artistIds = concat artistIdLists
49
let query = if (length artistIds == 0) then "delete from artists" else ("delete from artists where id not in (" ++ (questionMarks $ length artistIds) ++ ")")
50
_ <- quickQuery' c query artistIds
51
commit c
52
disconnect c
53
where
54
removeWhereNotReferenced c tableToClean referencingTable idField = do
55
_ <- quickQuery' c query []
56
putStrLn $ "Removed unreferenced entries from table " ++ tableToClean
57
where
58
query = "delete from " ++ tableToClean ++ " where id not in " ++
59
"(select distinct " ++ idField ++ " from " ++
60
referencingTable ++ " where " ++ idField ++ " is not null)"
61
62
updateTrackListForHost dbParams hostname tracks = do
63
c <- connectToDatabase dbParams
64
server <- findOrCreateCollectionServer c hostname
65
putStrLn "Placing tracks and tags into database..."
66
mapM (updateTrackOrPrintError c server) tracks
67
commit c
68
putStrLn "Finished!"
69
70
updateTrackOrPrintError conn server track = do
71
catchSql
72
(insertOrUpdateTrack conn server track)
73
(\err -> do
74
putStrLn $ "An error occurred when attempting to add track with file " ++
75
"path '" ++ (path track) ++ "' on server " ++ (hostname server) ++
76
":" ++ (show err))
77
where
78
path (Track (p, _, _)) = p
79
hostname (CollectionServer _ h) = h
80
81
insertOrUpdateTrack c server (Track (pathToFile, tags, playtime)) = do
82
putStrLn $ "Updating file `" ++ pathToFile ++ "`."
83
r <- quickQuery' c
84
("delete from tag_values where file_id in " ++
85
"(select id from files where collection_server_id = ? and path_to_file = ?)")
86
[toSql $ getId server, toSql pathToFile]
87
r <- quickQuery' c
88
"delete from files where collection_server_id = ? and path_to_file = ?"
89
[toSql $ getId server, toSql pathToFile]
90
let artistName = getTagValue "artist" tags
91
artist <- case artistName of
92
Just name -> do
93
a <- findOrCreateArtist c name
94
return $ Just a
95
Nothing -> return Nothing
96
let albumTitle = getTagValue "album" tags
97
release <- case albumTitle of
98
Just title -> do
99
album <- findOrCreateAlbum c artist title
100
r <- findOrCreateRelease c album
101
return $ Just r
102
Nothing -> return Nothing
103
let format = drop 1 $ takeExtension pathToFile
104
encoding <- case release of
105
Just r -> do
106
e <- findOrCreateEncoding c r format server
107
return $ Just e
108
Nothing -> return Nothing
109
let trackTitle = getTagValue "title" tags
110
let trackNumber = getTagValue "tracknumber" tags
111
trackNum <- case trackNumber of
112
Just num -> return num
113
Nothing -> return ""
114
track <- case trackTitle of
115
Just title -> do
116
t <- findOrCreateTrack c artist release title playtime trackNum
117
return $ Just t
118
Nothing -> return Nothing
119
fileId <- createFile c server pathToFile track encoding
120
mapM_ (insertTagValues c fileId) tags
121
where
122
getTagValue :: String -> [Tag] -> Maybe String
123
getTagValue label tags = if length matches == 0 then Nothing
124
else Just $ getFirstValue $ head matches
125
where
126
matches = filter (\t -> getLabel t == label) tags
127
getLabel (Tag (l, _)) = l
128
getFirstValue :: Tag -> String
129
getFirstValue (Tag (_, values)) = head values
130
131
findOrCreateTrack :: Connection -> Maybe Artist -> Maybe Release ->
132
String -> Int -> String -> IO TrackModel
133
findOrCreateTrack c artist release title playtime trackNum = do
134
selectResult <- quickQuery' c
135
("select id, artist_id, release_id, title from tracks " ++
136
"where artist_id = ? and release_id = ? and lower(title) = lower(?)")
137
[toSql $ getIdOrNothing artist, toSql $ getIdOrNothing release,
138
toSql title]
139
case length selectResult of
140
0 -> do
141
r <- quickQuery' c
142
("insert into tracks " ++
143
"(artist_id, release_id, title, playtime, track_num) " ++
144
"values (?, ?, ?, ?, ?) returning id")
145
[toSql $ getIdOrNothing artist, toSql $ getIdOrNothing release,
146
toSql title, toSql playtime, toSql trackNum]
147
let trackId = (fromSql $ head $ head r)::Integer
148
return $ TrackModel trackId (getIdOrNothing artist)
149
(getIdOrNothing release) title
150
1 -> do
151
let row = head selectResult
152
let id = fromSql $ row !! 0
153
let artistId = fromSql $ row !! 1
154
let releaseId = fromSql $ row !! 2
155
let title = fromSql $ row !! 3
156
return $ TrackModel id artistId releaseId title
157
_ -> error "Multiple matching tracks found"
158
159
createFile :: Connection -> CollectionServer -> String -> Maybe TrackModel ->
160
Maybe Encoding -> IO Integer
161
createFile c server pathToFile track encoding = do
162
r <- quickQuery' c
163
("insert into files " ++
164
"(collection_server_id, path_to_file, track_id, " ++
165
"release_encoding_id) " ++
166
"values (?, ?, ?, ?) returning id")
167
[toSql $ getId server, toSql pathToFile, toSql $ getIdOrNothing track,
168
toSql $ getIdOrNothing encoding]
169
let fileId = (fromSql $ head $ head $ r)::Integer
170
return fileId
171
172
insertTagValues c fileId (Tag (label, values)) =
173
mapM (insertTagValue c fileId label) values
174
where
175
insertTagValue c fileId label value = run c
176
"insert into tag_values (file_id, label, value) values (?, ?, ?)"
177
[toSql fileId, toSql label, toSql value]
178
179
connectToDatabase dbParams = do
180
c <- handleSqlError $ connectPostgreSQL
181
(unwords ["host=localhost", "port=5432",
182
"dbname=" ++ dbName dbParams,
183
"user=" ++ dbUsername dbParams,
184
"password=" ++ dbPassword dbParams])
185
return c
186
187
findOrCreateCollectionServer :: Connection -> String -> IO CollectionServer
188
findOrCreateCollectionServer c hostname =
189
findOrCreate c "collection_servers" "lower(hostname) = lower(?)"
190
[hostname] ["hostname"] [hostname] makeCollectionServer
191
192
findOrCreateArtist :: Connection -> String -> IO Artist
193
findOrCreateArtist c name = do
194
selectResult <- quickQuery' c
195
("select id, name, sortname, comment from artists " ++
196
"where lower(name) like lower(?)")
197
[toSql name]
198
case length selectResult of
199
0 -> do
200
putStrLn "inserting into artists table..."
201
r <- quickQuery' c
202
"insert into artists (name) values (?) returning id" [toSql name]
203
let artistId = (fromSql $ head $ head r)::Integer
204
putStrLn $ "successfully created artist with ID of " ++ (show artistId)
205
return $ Artist { artistId = artistId, name = name, sortname = "",
206
comment = "" }
207
1 -> do
208
let row = head selectResult
209
let id = fromSql $ row !! 0
210
let name = fromSql $ row !! 1
211
-- XXX: get other fields...
212
return $ Artist { artistId = id, name = name, sortname = "",
213
comment = "" }
214
_ -> error $ "Multiple artists found with name '" ++ name ++ "'"
215
216
findOrCreateAlbum :: Connection -> Maybe Artist -> String -> IO Album
217
findOrCreateAlbum c artist albumTitle =
218
findOrCreate2 c "albums" "lower(title) like lower(?)" [toSql albumTitle]
219
["title", "artist_id"] [toSql albumTitle, toSql $ getIdOrNothing artist]
220
makeAlbum
221
222
findOrCreateRelease :: Connection -> Album -> IO Release
223
findOrCreateRelease c album =
224
findOrCreate c "releases" "album_id = ?" [getId album]
225
["album_id"] [getId album] makeRelease
226
227
findOrCreateEncoding :: Connection -> Release -> String -> CollectionServer -> IO Encoding
228
findOrCreateEncoding c release format server = do
229
id <- findOrCreate3 c "release_encodings"
230
[Field "release_id" IntegerType, Field "format" (StringType False),
231
Field "collection_server_id" IntegerType]
232
[toSql $ getId release, toSql format, toSql $ getId server]
233
return $ Encoding id (getId release) format (getId server)
234
{- selectResult <- quickQuery' c
235
("select id, release_id, format, collection_server_id " ++
236
"from release_encodings " ++
237
"where release_id = ? and format = ? and collection_server_id = ?")
238
[toSql $ getId release, toSql format, toSql $ getId server]
239
case length selectResult of
240
0 -> do
241
r <- quickQuery' c
242
("insert into release_encodings " ++
243
"(release_id, format, collection_server_id) " ++
244
"values (?, ?, ?) returning id")
245
[toSql $ getId release, toSql format, toSql $ getId server]
246
let encodingId = (fromSql $ head $ head r)::Integer
247
return $ Encoding encodingId (getId release) format (getId server)
248
1 -> do
249
let row = head selectResult
250
let id = fromSql $ row !! 0
251
let releaseId = fromSql $ row !! 1
252
let format = fromSql $ row !! 2
253
let serverId = fromSql $ row !! 3
254
return $ Encoding id releaseId format serverId
255
_ -> error "Multiple matching encodings found"
256
-}
257
258
findOrCreate3 :: Connection -> String -> [Field] -> [SqlValue] -> IO Integer
259
findOrCreate3 c table fields values = do
260
selectResult <- quickQuery' c
261
("select id, " ++ fieldListSql ++ " from " ++ table ++
262
" where " ++ whereClause)
263
values
264
case length selectResult of
265
0 -> do
266
r <- quickQuery' c
267
("insert into " ++ table ++ " (" ++ fieldListSql ++ ") values (" ++
268
(commatize $ map (\_ -> "?") values) ++ ") returning id")
269
values
270
let id = (fromSql $ head $ head r)::Integer
271
return id
272
1 -> do
273
let row = head selectResult
274
return $ fromSql $ head row
275
--return $ makeFunc (fromSql $ head row) (map fromSql $ tail row)
276
_ -> error $ "Multiple matching rows found"
277
where
278
fieldListSql = commatize fieldNames
279
where fieldNames = map columnName fields
280
whereClause = intercalate " and " constraints
281
where
282
constraints = map
283
(\f -> (leftOperand f) ++ " = " ++ (rightOperand f))
284
fields
285
leftOperand (Field colName colType) = getOperand colName colType
286
rightOperand (Field _ colType) = getOperand "?" colType
287
getOperand x IntegerType = x
288
getOperand x (StringType caseSensitive) =
289
if caseSensitive then x else ("lower(" ++ x ++ ")")
290
291
{-
292
findOrCreate3 :: (NewModel m) =>
293
Connection -> m -> IO Integer
294
findOrCreate3 c m = do
295
selectResult <- quickQuery' c
296
("select id, " ++ fieldListSql ++ " from " ++ table ++
297
" where " ++ (sqlToLocate m))
298
(getConstraintValues m)
299
case length selectResult of
300
0 -> do
301
r <- quickQuery' c
302
("insert into " ++ table ++ " (" ++ fieldListSql ++ ") values (" ++
303
(commatize $ map (\_ -> "?") values) ++ ") returning id")
304
values
305
let id = (fromSql $ head $ head r)::Integer
306
return id
307
--return $ makeFunc id (map fromSql values)
308
1 -> do
309
let row = head selectResult
310
return $ fromSql $ head row
311
--return $ makeFunc (fromSql $ head row) (map fromSql $ tail row)
312
_ -> error $ "Multiple rows found for constraint \"" ++
313
(sqlToLocate m) ++ "\""
314
where
315
table = getTableName m
316
fieldListSql = commatize fieldNames
317
fieldNames = map columnName (getFields m)
318
values = getConstraintValues m
319
commatize list = intercalate ", " list
320
-}
321
322
findOrCreate2 :: (Model m, SqlType t) =>
323
Connection -> String -> String -> [SqlValue] -> [String] ->
324
[SqlValue] -> (Integer -> [t] -> m) -> IO m
325
findOrCreate2 c table constraintSql constraintValues fieldNames
326
values makeFunc = do
327
selectResult <- quickQuery' c
328
("select id, " ++ fieldListSql ++ " from " ++ table ++
329
" where " ++ constraintSql)
330
constraintValues
331
case length selectResult of
332
0 -> do
333
r <- quickQuery' c
334
("insert into " ++ table ++ " (" ++ fieldListSql ++ ") values (" ++
335
(commatize $ map (\_ -> "?") values) ++ ") returning id")
336
values
337
let id = (fromSql $ head $ head r)::Integer
338
return $ makeFunc id (map fromSql values)
339
1 -> do
340
let row = head selectResult
341
return $ makeFunc (fromSql $ head row) (map fromSql $ tail row)
342
_ -> error $ "Multiple rows found for constraint \"" ++
343
constraintSql ++ "\""
344
where
345
fieldListSql = commatize fieldNames
346
347
findOrCreate :: (Model m, SqlType t) =>
348
Connection -> String -> String -> [t] -> [String] ->
349
[t] -> (Integer -> [t] -> m) -> IO m
350
findOrCreate c table constraintSql constraintValues fieldNames values makeFunc = do
351
selectResult <- quickQuery' c
352
("select id, " ++ fieldListSql ++ " from " ++ table ++
353
" where " ++ constraintSql)
354
(map toSql constraintValues)
355
case length selectResult of
356
0 -> do
357
r <- quickQuery' c
358
("insert into " ++ table ++ " (" ++ fieldListSql ++ ") values (" ++
359
(questionMarks $ length values) ++ ") returning id")
360
--(commatize $ map (\_ -> "?") values) ++ ") returning id")
361
(map toSql values)
362
let id = (fromSql $ head $ head r)::Integer
363
return $ makeFunc id values
364
1 -> do
365
let row = head selectResult
366
return $ makeFunc (fromSql $ head row) (map fromSql $ tail row)
367
_ -> error $ "Multiple rows found for constraint \"" ++
368
constraintSql ++ "\""
369
where
370
fieldListSql = commatize fieldNames
371
372
commatize list = intercalate ", " list
373
questionMarks len = commatize $ replicate len "?"
374
375
class Model m where
376
getId :: m -> Integer
377
getIdOrNothing :: Maybe m -> Maybe Integer
378
getIdOrNothing (Just x) = Just $ getId x
379
getIdOrNothing Nothing = Nothing
380
381
class Model m => NewModel m where
382
getTableName :: m -> String
383
getFields :: m -> [Field]
384
--sqlToLocate :: m -> String
385
getConstraintValues :: m -> [SqlValue]
386
--getConstraintValues :: m -> [FieldValue]
387
388
data Artist = Artist { artistId :: Integer, name :: String, sortname :: String,
389
comment :: String }
390
instance Model Artist where
391
getId a = artistId a
392
makeArtist artistId [name, sortname, comment] =
393
Artist artistId name sortname comment
394
makeArtist _ _ = error "Too many or too few list items passed to makeArtist"
395
396
{- id artistId title -}
397
data Album = Album Integer (Maybe Integer) String
398
instance Model Album where
399
getId (Album i _ _) = i
400
makeAlbum albumId [artistId, title] = Album albumId (read artistId) title
401
makeAlbum _ _ = error "Too many or too few list items passed to makeAlbum"
402
403
data Release = Release Integer Integer
404
instance Model Release where
405
getId (Release i _) = i
406
makeRelease releaseId [albumId] = Release releaseId albumId
407
makeRelease _ _ = error "Too many or too few list items passed to makeRelease"
408
409
data FieldType = IntegerType | StringType Bool
410
deriving Show
411
data Field = Field { columnName :: String, fieldType :: FieldType }
412
deriving Show
413
--data FieldValue = Integer | String
414
--instance SqlType Field where
415
-- toSql a = toSql a
416
417
{- id releaseId format serverId -}
418
data Encoding = Encoding Integer Integer String Integer
419
deriving Show
420
instance Model Encoding where
421
getId (Encoding i _ _ _) = i
422
instance NewModel Encoding where
423
getTableName _ = "release_encodings"
424
getFields _ = [Field "release_id" IntegerType,
425
Field "format" (StringType False),
426
Field "server_id" IntegerType]
427
--getConstraintFields e =
428
--sqlToLocate e = "release_id = ?"
429
getConstraintValues (Encoding _ releaseId format serverId) =
430
[toSql releaseId, toSql format, toSql serverId]
431
--makeEncoding :: Integer -> [Field] -> Encoding
432
--makeEncoding encodingId [releaseId, format, serverId] =
433
-- Encoding encodingId releaseId format serverId
434
--makeEncoding _ _ = error "Too many or too few list items passed to makeEncoding"
435
436
{- id artistId releaseId title -}
437
data TrackModel = TrackModel Integer (Maybe Integer) (Maybe Integer) String
438
instance Model TrackModel where
439
getId (TrackModel i _ _ _) = i
440
441
{- id hostname -}
442
data CollectionServer = CollectionServer Integer String
443
instance Model CollectionServer where
444
getId (CollectionServer i _) = i
445
makeCollectionServer id [hostname] = CollectionServer id hostname
446
makeCollectionServer _ _ = error "Too many or too few list items passed to makeCollectionServer"
Loggerhead is a web-based interface for Breezy
Version: 2.0.1