HNM-0.1.2: Main.hs
{-# OPTIONS -fglasgow-exts #-}
module Main where
import IO
import HNM.WLAN
import Data.List
import Data.Tree
import System.IO
import Data.IORef
import GHC.IOBase
import Data.Maybe
import System.Exit
import System.Process
import Graphics.UI.Gtk hiding (disconnect)
import System.Directory
import System.IO.Unsafe
import Text.Regex.Posix
import System.Posix.User
import System.Environment
import Control.Concurrent
import Control.Monad.State
import System.Glib.Signals (on)
import Graphics.UI.Gtk.ModelView
import Graphics.UI.Gtk.ModelView.TreeStore
import qualified Graphics.UI.Gtk.Display.StatusIcon as I
--import HNM.Settings
main :: IO Int
main = start =<< getArgs --assu (start =<< getArgs) warn
errorVisual :: String → IO Int
errorVisual msg = do
warnVisual MessageError ButtonsOk appName msg
return 1
warn :: IO Int
warn = errorVisual $ "You have to be root to run " ++ appName ++ "!"
warnVisual :: MessageType → ButtonsType → String → String → IO ResponseId
warnVisual mt bt tt msg = do
putStrLn msg
initGUI
windowSetDefaultIconName "gtk-network"
dlg ← messageDialogNewWithMarkup Nothing [] mt bt msg
windowSetTitle dlg tt
onResponse dlg (\_ → widgetDestroy dlg)
dialogRun dlg
start :: [String] → IO Int
start ["--version"] = do
printVersion
start ["-V"] = do
printVersion
start ["--license"] = do
printLicense
start [] = do
is ← getInterfaces
case is of
[] → errorVisual "No wireless network interfaces."
_ → withArgs is $ start is
start [interface] = assu (do
putStrLn interface
initGUI
windowSetDefaultIconName "gtk-network"
icn ← statusIcon
win ← mainWindowNew
mainWindow =: win
taskbarIcon =: icn
statusIconSetVisible icn True
mainGUI
return 0) warn
start [interface,driver] = assu (do
putStrLn driver
initHardware driver interface
start [interface]) warn
interfaceArg :: IO Interface
interfaceArg = return . (\(i:_) → i) =<< getArgs
{-# NOINLINE mainWindow #-}
mainWindow :: IORef Window
mainWindow = unsafePerformIO $ newIORef $ unsafePerformIO mainWindowNew
{-# NOINLINE mainBox #-}
mainBox :: IORef VBox
mainBox = unsafePerformIO $ newIORef undefined
{-# NOINLINE mainView #-}
mainView :: IORef TreeView
mainView = unsafePerformIO $ newIORef undefined
{-# NOINLINE taskbarIcon #-}
taskbarIcon :: IORef StatusIcon
taskbarIcon = unsafePerformIO $ newIORef undefined
{-# NOINLINE mainWindowVisibility #-}
mainWindowVisibility :: IORef Bool
mainWindowVisibility = unsafePerformIO $ newIORef True
(=:) :: IORef a → a → IO a
r =: v = writeIORef r v >> return v
alternateMainWindowVisibility :: IO ()
alternateMainWindowVisibility = do
vis ← mutateUsing not mainWindowVisibility
(if vis then widgetShow
else widgetHide) =<< readIORef mainWindow
mutateUsing :: (a → a) → IORef a → IO a
mutateUsing f r = (r =:) . f =<< x r
where x = readIORef
(⇆) :: a → a → IO a
c ⇆ d = do
it ← interfaceArg
cs ← getConnectionStatus it
case cs of
Connected _ _ → return d
_ → return c
statusIcon :: IO StatusIcon
statusIcon = do
stc ← stockConnect ⇆ stockDisconnect
icn ← statusIconNewFromStock stc
statusIconSetVisible icn True
statusIconSetTooltip icn appName
mnu ← mkmenu icn
I.onPopupMenu icn $ \b a → do
widgetShowAll mnu
print (b,a)
menuPopup mnu $ maybe Nothing (\b' -> Just (b',a)) b
I.onActivate icn $
alternateMainWindowVisibility
return icn
where
mkmenu s = do
m ← menuNew
i ← interfaceArg
mapM_ (mkitem m) [("gtk-refresh", refresh) ,
("gtk-disconnect", disconnectHandler i),
("---", undefined) ,
("gtk-about", showAbout) ,
("---", undefined) ,
("gtk-quit", mainQuit) ]
return m
where
mkitem menu ("---",_) = do
menuShellAppend menu =<< separatorMenuItemNew
mkitem menu (label,act) = do
i ← imageMenuItemNewFromStock label
menuShellAppend menu i
onActivateLeaf i act
return ()
refresh :: IO ()
refresh = do
vbx ← readIORef mainBox
vio ← readIORef mainView
containerRemove vbx vio
vin ← wlanTreeViewNew
mainView =: vin
containerAdd vbx vin
mainWindowNew :: IO Window
mainWindowNew = do
win ← windowNew
vbx ← vBoxNew False 0
mnu ← createMenu
boxPackStart vbx mnu PackNatural 0
view ← wlanTreeViewNew
containerAdd vbx view
sbr ← statusbarNew
boxPackEnd vbx sbr PackNatural 0
{-txt ← textViewNew
textViewSetEditable txt False
widgetSetSizeRequest txt 0 160
boxPackEnd vbx txt PackGrow 0-}
containerAdd win vbx
mainBox =: vbx
mainView =: view
windowSetTitle win appName
onDestroy win mainQuit
widgetShowAll win
-- forkIO autorefresh
return win
autorefresh :: IO ()
autorefresh = do
refresh
putStrLn "refreshed"
system "sleep 1"
autorefresh
wlanTreeViewNew :: IO TreeView
wlanTreeViewNew = do
model ← wlanTreeModelNew
view ← treeViewNewWithModel model
cs@[c1,c2,c3,c4] ← replicateM 4 treeViewColumnNew
mapM_ (\(c,t) → treeViewColumnSetTitle c t) $ zip cs
["", "essid", "quality", "encryption"]
[r2,r4] ← replicateM 2 cellRendererTextNew
r3 ← cellRendererProgressNew
r1 ← cellRendererToggleNew
mapM_ (\(c,pc) → pc c) $
zip cs ([pack r1,
pack r2,
pack r3,
pack r4])
treeViewColumnSetSizing c3 TreeViewColumnFixed
treeViewColumnSetFixedWidth c3 150
s ← getConnectionStatus =<< interfaceArg
cellLayoutSetAttributes c2 r2 model $ \r → [ cellText := idof r ]
cellLayoutSetAttributes c3 r3 model $ \r → [ cellProgressValue := qual r,
cellProgressText := Just "" ]
cellLayoutSetAttributes c4 r4 model $ \r → [ cellText := show (cencrypt r) ]
cellLayoutSetAttributes c1 r1 model $ \r → [ cellToggleActive := conn s r,
cellToggleRadio := True ]
on r1 cellToggled (connect model)
mapM_ (treeViewAppendColumn view) cs
widgetShowAll view
return view
where
idof r = if id == "" && ln == 1 then mac else id
where
id = cessid r
cs@((mac,_):_) = ccell r
ln = length cs
qual = meanQuality . map snd . ccell
pack r c = cellLayoutPackStart c r True -- continuation
conn NotConnected _ = False
conn (Connected _ cid) r = cid == cessid r
connect model pathStr = do
r ← treeStoreGetValue model path
case cencrypt r of
None → ((flip connectFree) (cessid r) =<< interfaceArg) >> refresh
_ → connectUsingSettings (cessid r)
where
path = stringToTreePath pathStr
connectUsingSettings :: SSID → IO ()
connectUsingSettings id = do
it ← interfaceArg
ms ← return . find (settingEq id) =<< readSettings
case ms of
Just s → connect it s >> refresh
_ → (warnVisual MessageError ButtonsOk appName $
"No configuration for encrypted network " ++ id ++
" found in: " ++ settingsFile) >> return ()
where
settingEq id (Wireless sid _) = id == sid
settingsFile :: FilePath
settingsFile = "/etc/hnm.conf"
readSettings :: IO [ConnectionSetting]
readSettings = do
mc ← tryReadFile settingsFile
case mc of
Just contents → return . read $ contents
_ → create settingsFile >> return []
where
create f = writeFile f "[]"
tryReadFile :: FilePath → IO (Maybe String)
tryReadFile file = do
exists ← doesFileExist file
case exists of
True → return . Just =<< readFile file
False → return Nothing
wlanTreeModelNew :: IO (TreeStore CWLAN)
wlanTreeModelNew = do
treeStoreNew . (map cwlanToNode) . compact =<< getWLANs =<< interfaceArg
cwlanToNode :: CWLAN → Tree CWLAN
cwlanToNode w = Node w s
where
s = if ln > 1 then map (c2w w) cs else []
where
cs = ccell w
ln = length cs
c2w w c = Node (CWLAN (fst c) (cencrypt w) [([],snd c)]) []
disconnectHandler :: Interface → IO ()
disconnectHandler interface = do
disconnect interface
ifconfig [interface, "up"]
refresh
doif :: Monad m ⇒ Bool → m () → m ()
doif True act = act
doif False _ = return ()
createMenu :: IO Widget
createMenu = do
fma ← actionNew "FMA" "_File" Nothing Nothing
hma ← actionNew "HMA" "_Help" Nothing Nothing
refa ← actionNew "REFA" "_Refresh" (Just "stub") (Just stockRefresh)
exia ← actionNew "EXIA" "_Quit" (Just "stub") (Just stockQuit)
aboa ← actionNew "ABOA" "_About" (Just "stub") (Just stockAbout)
agr ← actionGroupNew "AGR"
mapM_ (actionGroupAddAction agr) [fma,hma]
mapM_ (\act → actionGroupAddActionWithAccel agr act Nothing) [refa,exia,aboa]
onActionActivate refa refresh
onActionActivate exia mainQuit
onActionActivate aboa showAbout
ui ← uiManagerNew
uiManagerAddUiFromString ui menuDecl
uiManagerInsertActionGroup ui agr 0
maybeMenubar ← uiManagerGetWidget ui "/ui/menubar"
return $ fromJust maybeMenubar
where
menuDecl = "<ui>\
\ <menubar>\
\ <menu action=\"FMA\">\
\ <menuitem action=\"REFA\" />\
\ <menuitem action=\"EXIA\" />\
\ </menu>\
\ <menu action=\"HMA\">\
\ <menuitem action=\"ABOA\" />\
\ </menu>\
\ </menubar>\
\ </ui>"
appName :: String
appName = "Happy Network Manager"
appNameShort :: String
appNameShort = "HNM"
appVersion :: String
appVersion = "0.1.2"
showAbout :: IO ()
showAbout = do
dlg ← aboutDialogNew
lcs ← return license
set dlg [
aboutDialogName := appName,
aboutDialogVersion := appVersion,
aboutDialogComments := "A quick and dirty applet to help you connect to wireless networks.",
aboutDialogCopyright := "Copyright © 2008 Cetin Sert",
aboutDialogWebsite := "http://sert.homedns.org/hs/hnm/",
aboutDialogLicense := (Just lcs),
aboutDialogAuthors := ["cs ^.^", "CS *^o^*"],
aboutDialogLogoIconName := (Just "gtk-network")
]
onResponse dlg (\_ → widgetDestroy dlg)
dialogRun dlg
return ()
printVersion :: IO Int
printVersion = do
putStrLn $ appName ++ " " ++ appVersion
putStrLn ""
return 0
printLicense :: IO Int
printLicense = do
printVersion
putStrLn license
putStrLn ""
return 0
license :: String
license = "Copyright (c) 2008, Cetin Sert\n\
\\n\
\All rights reserved.\n\
\\n\
\Redistribution and use in source and binary forms, with or without\n\
\modification, are permitted provided that the following conditions are\n\
\met:\n\
\\n\
\ 1. Redistributions of source code must retain the above copyright\n\
\ notice, this list of conditions and the following disclaimer.\n\
\\n\
\ 2. Redistributions in binary form must reproduce the above\n\
\ copyright notice, this list of conditions and the following\n\
\ disclaimer in the documentation and/or other materials provided\n\
\ with the distribution.\n\
\\n\
\ 3. The names of contributors may not be used to endorse or promote\n\
\ products derived from this software without specific prior\n\
\ written permission.\n\
\\n\
\THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS\n\
\\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT\n\
\LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR\n\
\A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT\n\
\OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\n\
\SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT\n\
\LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,\n\
\DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY\n\
\THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT\n\
\(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\n\
\OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."