1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
{-- snippet imports --}
module PodMainGUI where
import PodDownload
import PodDB
import PodTypes
import System.Environment
import Database.HDBC
import Network.Socket(withSocketsDo)
-- GUI libraries
import Graphics.UI.Gtk hiding (disconnect)
import Graphics.UI.Gtk.Glade
-- Threading
import Control.Concurrent
{-- /snippet imports --}
{-- snippet type --}
-- | Our main GUI type
data GUI = GUI {
mainWin :: Window,
mwAddBt :: Button,
mwUpdateBt :: Button,
mwDownloadBt :: Button,
mwFetchBt :: Button,
mwExitBt :: Button,
statusWin :: Dialog,
swOKBt :: Button,
swCancelBt :: Button,
swLabel :: Label,
addWin :: Dialog,
awOKBt :: Button,
awCancelBt :: Button,
awEntry :: Entry}
{-- /snippet type --}
{-- snippet main --}
main :: FilePath -> IO ()
main gladepath = withSocketsDo $ handleSqlError $
do initGUI -- Initialize GTK+ engine
-- Every so often, we try to run other threads.
timeoutAddFull (yield >> return True)
priorityDefaultIdle 100
-- Load XML from glade path
xmlGlade <- xmlNew gladepath
case xmlGlade of
Nothing -> do
let errorMsg = "Cannot load glade file " ++ gladepath
d <- messageDialogNew Nothing -- No parent window
[] -- No dialog flags
MessageError
ButtonsClose
errorMsg
windowSetTitle d "Error"
dialogRun d
return ()
Just xml -> do
-- Load the GUI from the Glade file
gui <- loadGlade xml
-- Connect to the database
dbh <- connect "pod.db"
-- Set up our events
connectGui gui dbh
-- Run the GTK+ main loop; exits after GUI is done
mainGUI
-- Disconnect from the database at the end
disconnect dbh
{-- /snippet main --}
{-- snippet loadGlade --}
loadGlade xml =
do
-- Load main window
mw <- xmlGetWidget xml castToWindow "mainWindow"
-- Load all buttons
[mwAdd, mwUpdate, mwDownload, mwFetch, mwExit, swOK, swCancel,
auOK, auCancel] <-
mapM (xmlGetWidget xml castToButton)
["addButton", "updateButton", "downloadButton",
"fetchButton", "exitButton", "okButton", "cancelButton",
"auOK", "auCancel"]
sw <- xmlGetWidget xml castToDialog "statusDialog"
swl <- xmlGetWidget xml castToLabel "statusLabel"
au <- xmlGetWidget xml castToDialog "addDialog"
aue <- xmlGetWidget xml castToEntry "auEntry"
return $ GUI mw mwAdd mwUpdate mwDownload mwFetch mwExit
sw swOK swCancel swl au auOK auCancel aue
{-- /snippet loadGlade --}
{-- snippet connectGui --}
connectGui gui dbh =
do -- When the close button is clicked, terminate GUI loop
-- by calling GTK mainQuit function
onDestroy (mainWin gui) mainQuit
-- Main window buttons
onClicked (mwAddBt gui) (guiAdd gui dbh)
onClicked (mwUpdateBt gui) (guiUpdate gui dbh)
onClicked (mwDownloadBt gui) (guiDownload gui dbh)
onClicked (mwFetchBt gui) (guiFetch gui dbh)
onClicked (mwExitBt gui) mainQuit
-- We leave the status window buttons for later
{-- /snippet connectGui --}
{-- snippet guiAdd --}
guiAdd gui dbh =
do -- Initialize the add URL window
entrySetText (awEntry gui) ""
onClicked (awCancelBt gui) (widgetHide (addWin gui))
onClicked (awOKBt gui) procOK
-- Show the add URL window
windowPresent (addWin gui)
where procOK =
do url <- entryGetText (awEntry gui)
widgetHide (addWin gui) -- Remove the dialog
addUrl dbh url -- Add to the DB
{-- /snippet guiAdd --}
{-- snippet statusWindow --}
statusWindow :: IConnection conn =>
GUI
-> conn
-> String
-> ((String -> IO ()) -> IO ())
-> IO ()
statusWindow gui dbh title func =
do -- Clear the status text
labelSetText (swLabel gui) ""
-- Disable the OK button, enable Cancel button
widgetSetSensitivity (swOKBt gui) False
widgetSetSensitivity (swCancelBt gui) True
-- Set the title
windowSetTitle (statusWin gui) title
-- Start the operation
childThread <- forkIO childTasks
-- Define what happens when clicking on Cancel
onClicked (swCancelBt gui) (cancelChild childThread)
-- Show the window
windowPresent (statusWin gui)
where childTasks =
do updateLabel "Starting thread..."
func updateLabel
-- After the child task finishes, enable OK
-- and disable Cancel
enableOK
enableOK =
do widgetSetSensitivity (swCancelBt gui) False
widgetSetSensitivity (swOKBt gui) True
onClicked (swOKBt gui) (widgetHide (statusWin gui))
return ()
updateLabel text =
labelSetText (swLabel gui) text
cancelChild childThread =
do killThread childThread
yield
updateLabel "Action has been cancelled."
enableOK
{-- /snippet statusWindow --}
{-- snippet statusWindowFuncs --}
guiUpdate :: IConnection conn => GUI -> conn -> IO ()
guiUpdate gui dbh =
statusWindow gui dbh "Pod: Update" (update dbh)
guiDownload gui dbh =
statusWindow gui dbh "Pod: Download" (download dbh)
guiFetch gui dbh =
statusWindow gui dbh "Pod: Fetch"
(\logf -> update dbh logf >> download dbh logf)
{-- /snippet statusWindowFuncs --}
{-- snippet workerFuncs --}
addUrl dbh url =
do addPodcast dbh pc
commit dbh
where pc = Podcast {castId = 0, castURL = url}
update :: IConnection conn => conn -> (String -> IO ()) -> IO ()
update dbh logf =
do pclist <- getPodcasts dbh
mapM_ procPodcast pclist
logf "Update complete."
where procPodcast pc =
do logf $ "Updating from " ++ (castURL pc)
updatePodcastFromFeed dbh pc
download dbh logf =
do pclist <- getPodcasts dbh
mapM_ procPodcast pclist
logf "Download complete."
where procPodcast pc =
do logf $ "Considering " ++ (castURL pc)
episodelist <- getPodcastEpisodes dbh pc
let dleps = filter (\ep -> epDone ep == False)
episodelist
mapM_ procEpisode dleps
procEpisode ep =
do logf $ "Downloading " ++ (epURL ep)
getEpisode dbh ep
{-- /snippet workerFuncs --}
|
