HNM-0.1: 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.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 = assu (start =<< getArgs) warn
warn :: IO Int
warn = do
warnVisual MessageError ButtonsOk appName $
"You have to be root to run " ++ appName ++ "!"
return 1
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 [] = do
is@(i:_) ← getInterfaces
withArgs is $ start is
start [interface] = do
putStrLn interface
initGUI
windowSetDefaultIconName "gtk-network"
icn ← statusIcon
win ← mainWindowNew
mainWindow =: win
taskbarIcon =: icn
statusIconSetVisible icn True
mainGUI
return 0
start [interface,driver] = do
putStrLn driver
initHardware driver interface
start [interface]
interfaceArg :: IO Interface
interfaceArg = return . (\(i:_) → i) =<< getArgs
refresh :: IO ()
refresh = refresh2
refresh1 :: IO ()
refresh1 = do
putStrLn "refresh"
win ← readIORef mainWindow
widgetDestroy win
xxx ← mainWindowNew
mainWindow =: xxx
return ()
{-# 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", disconnect_ 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 ()
refresh2 :: IO ()
refresh2 = 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
return win
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", "status"]
[r1,r3] ← replicateM 2 cellRendererTextNew
r2 ← cellRendererProgressNew
r4 ← cellRendererToggleNew
mapM_ (\(c,pc) → pc c) $
zip cs ([pack r1,
pack r2,
pack r3,
pack r4])
treeViewColumnSetSizing c2 TreeViewColumnFixed
treeViewColumnSetFixedWidth c2 150
s ← getConnectionStatus =<< interfaceArg
cellLayoutSetAttributes c1 r1 model $ \r → [ cellText := idof r ]
cellLayoutSetAttributes c2 r2 model $ \r → [ cellProgressValue := qual r,
cellProgressText := Just "" ]
cellLayoutSetAttributes c3 r3 model $ \r → [ cellText := show (cencrypt r) ]
cellLayoutSetAttributes c4 r4 model $ \r → [ cellToggleActive := conn s r,
cellToggleRadio := True ]
on r4 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 (Encrypted sid _ _) = id == sid
settingEq _ _ = False
settingsFile :: String
settingsFile = "settings.conf"
readSettings :: IO [ConnectionSetting]
readSettings = return . read =<< readFile settingsFile
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)]) []
wlanTableNew :: IO Table
wlanTableNew = do
it ← interfaceArg
ws ← getWLANs it
ln ← (return . length) ws
tb ← tableNew 5 (ln + 2) False
attach ws ln tb it
where
attach ws ln tb it = do
att 0 =<< markup "<b>essid</b>" =<< label
att 1 =<< markup "<b>quality</b>" =<< label
att 2 =<< markup "<b>encryption</b>" =<< label
att 3 =<< markup "<b>password</b>" =<< label
att 4 =<< markup "<b>action</b>" =<< label
populate tb ws =<< getConnectionStatus it
return tb
where
att = \c w → tableAttach tb w c (c+1) 0 (0+1) exfi [] padd padd
label = labelNew Nothing
markup = \m l → labelSetMarkup l m >> return l
settext = \t l → labelSetText l t >> return l
c f a l = f l a >> return l
populate :: Table → [WLAN] → ConnectionStatus → IO ()
populate tb [] _ = return ()
populate tb ws cs = adr tb 1 (compact ws)
where
adr tb i [] = return ()
adr tb i (w:ws) = do
-- ad0 0 =<< labelNew (Just id)
ad0 0 =<< c labelSetAngle (0 ? 25) =<< settext id =<< label
ad1 1 =<< pbar ql
ad0 2 =<< labelNew (Just (show en))
get ← pb
doif (any (en ==) [None, WEP]) (ad4 4 =<< cbt get id)
adr tb (i+1) ws
where
(?) = \a b → case cs of NotConnected → a; Connected _ ci → if (ci == id) then b else a
cnc = case cs of Connected _ _ → True; _ → False
cid = case cs of Connected _ cid → cid; _ → []
bd = ("<b>" ++ ) . ( ++ "</b>")
id = cessid w
en = cencrypt w
us = ccell w
ln = length us
qs = map snd us
ql = mean $ map (fromInteger . toInteger) qs
ad0 = \c w → tableAttach tb w c (c+1) i (i+1) ox oy px py
ad1 = \c w → tableAttach tb w c (c+1) i (i+1) ox oy px py
ad3 = \c w → tableAttach tb w c (c+1) i (i+1) ox oy px py
ad4 = \c w → tableAttach tb w c (c+1) i (i+1) ox oy px py
ox = exfi
oy = []
px = padd
py = padd
pb = do
if any (en ==) [WEP] && (cid /= id)
then do
entry ← entryNew
-- entrySetVisibility entry False
ad3 3 entry
return $ Just (entryGetText entry)
else do
return $ Nothing
cbt = \get ssid → do
btn ← buttonNew
buttonSetRelief btn ReliefNone
buttonSetUseStock btn True
buttonSetLabel btn ("gtk-connect" ? "gtk-disconnect")
int ← interfaceArg
onClicked btn $ (connectOBS int ssid en get) ? (disconnect_ int)
return btn
exfi = [Expand,Fill]
padd = 4
disconnect_ :: Interface → IO ()
disconnect_ interface = do
disconnect interface
ifconfig [interface, "up"]
refresh
connectOBS :: Interface → SSID → Encryption → Maybe (IO String) → IO ()
connectOBS interface ssid None Nothing = connectFree interface ssid >> refresh
connectOBS interface ssid WEP (Just getKey) = (connectWEP interface ssid =<< getKey) >> refresh
pbar :: Double → IO ProgressBar
pbar val = do
bar ← progressBarNew
progressBarSetFraction bar (val / 100)
-- progressBarSetText bar $ show val
return bar
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
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"
showAbout :: IO ()
showAbout = do
dlg ← aboutDialogNew
lcs ← readFile "LICENSE" -- tryReadFile
set dlg [
aboutDialogName := "Happy Network Manager",
aboutDialogVersion := "0.1",
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 ()