diff options
Diffstat (limited to 'ch23/23_a_1/PodMainGUI.hs')
| -rw-r--r-- | ch23/23_a_1/PodMainGUI.hs | 214 |
1 files changed, 214 insertions, 0 deletions
diff --git a/ch23/23_a_1/PodMainGUI.hs b/ch23/23_a_1/PodMainGUI.hs new file mode 100644 index 0000000..943be01 --- /dev/null +++ b/ch23/23_a_1/PodMainGUI.hs @@ -0,0 +1,214 @@ +{-- 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 the GUI from the Glade file
+ gui <- loadGlade gladepath
+
+ -- 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 gladepath =
+ do -- Load XML from glade path.
+ -- Note: crashes with a runtime error on console if fails!
+ Just xml <- xmlNew gladepath
+
+ -- 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
+ add 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 --}
+add 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 --}
|