diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +Cetin Sert diff --git a/HNM.cabal b/HNM.cabal new file mode 100644 --- /dev/null +++ b/HNM.cabal @@ -0,0 +1,52 @@ +name: HNM +version: 0.1 +copyright: (c) 2008 Cetin Sert +cabal-version: >= 1.2 +description: A quick and dirty applet to help you connect + to wireless networks. +license: BSD3 +license-file: LICENSE +author: Cetin Sert +maintainer: Cetin Sert +category: Network, System +homepage: http://sert.homedns.org/hs/hnm/ +synopsis: Happy Network Manager +stability: experimental + +build-type: Simple + +data-files: settings.conf, + Makefile + +extra-source-files: AUTHORS, + README + +Library + buildable: True + exposed-modules: HNM.WLAN + extensions: NoMonomorphismRestriction + ghc-options: -O2 -fglasgow-exts + build-depends: base, + gtk >= 0.9.13, + glib, + mtl, + unix, + regex-posix, + process, + containers, + haskell98 + +Executable HNM + buildable: True + main-is: Main.hs + extensions: NoMonomorphismRestriction + ghc-options: -O2 -fglasgow-exts + build-depends: base, + gtk >= 0.9.13, + glib, + mtl, + unix, + regex-posix, + process, + containers, + haskell98 diff --git a/HNM/WLAN.hs b/HNM/WLAN.hs new file mode 100644 --- /dev/null +++ b/HNM/WLAN.hs @@ -0,0 +1,208 @@ +{-# OPTIONS -fglasgow-exts #-} + +module HNM.WLAN where + +import IO +import Data.List +import System.IO +import System.Exit +import System.Process +import System.IO.Unsafe +import Text.Regex.Posix +import System.Posix.User +import System.Environment +import Control.Concurrent +import Control.Monad.State + +ignore :: Monad m ⇒ m a → m () +ignore _ = return () + +assu :: IO a → IO a → IO a +assu a b = do + root ← userIsRoot + case root of + True → a + False → b + +userIsRoot :: IO Bool +userIsRoot = return . (0 ==) =<< getRealUserID + +run :: String → IO String +run cmd = do + (i,o,e,h) ← runInteractiveCommand cmd + hGetContents o >>= \s → waitForProcess h >> return s + +type Key = String +type SSID = String +type MAC = String +type Interface = String +type Cell = String +type IP = String +type AP = String + +getDefaultInterface :: IO Interface +getDefaultInterface = return . head =<< getInterfaces + +getInterfaces :: IO [Interface] +getInterfaces = do + cat ← run "cat /proc/net/wireless" + return $ filter (/= "") $ map (matching " *(.*[0-9]+):") $ lines cat + +scan :: Interface → IO [Cell] +scan interface = return . drop 1 . getCells =<< run ("iwlist " ++ interface ++ " scan") + +getCells :: String → [Cell] +getCells block = map unwords $ groupBy (const $ (/=) "Cell") $ words block + +data Encryption = None | WEP | WPA Version + deriving (Show, Read, Eq, Ord) + +data Version = One | Two + deriving (Show, Read, Eq, Ord) + +type Quality = Int +type Unit = (MAC,Quality) + +data CWLAN = CWLAN + { + cessid :: SSID, + cencrypt :: Encryption, + ccell :: [Unit] + } + deriving (Show, Read, Eq, Ord) + +meanQuality :: [Quality] → Quality +meanQuality = round . mean . (map (fromInteger . toInteger)) + +mean :: Fractional a ⇒ [a] → a +mean [] = 0 +mean (x:xs) = mean' (x:xs) 0 0 + where + mean' [] s c = s / c + mean' (x:xs) s c = mean' xs (s+x) (c+1) + +data WLAN = WLAN + { + essid :: SSID, + quality :: Quality, + encryption :: Encryption, + mac :: MAC + } + deriving (Show, Read, Eq, Ord) + +compact :: [WLAN] → [CWLAN] +compact [] = [] +compact (w:ws) = CWLAN cid cen ceq_us : compact cne + where + cid = essid w + cen = encryption w + (ceq,cne) = partition ((cid ==) . essid) ws + ceq_us = macqual w : map macqual ceq + macqual = \ew → (mac ew, quality ew) + +cellToWLAN :: Cell → WLAN +cellToWLAN c = WLAN (getEssid c) (getQuality c) (getEncrypt c) (getMac c) + where + getEssid = matching "ESSID:\"(.*)\"" + getMac = matching "Address: (.{17})" + getQuality = \c → case matching "Quality=(.*)/100" c of { "" → 0; q → read q :: Int} + getEncrypt = \c → case matching "Encryption key:(on|off)" c of + "on" → case matching "WPA Version (.)" c of + "1" → WPA One + "2" → WPA Two + _ → WEP + "off" → None + +getWLANs :: Interface → IO [WLAN] +getWLANs interface = return . {-debug . -}map cellToWLAN =<< scan interface + +getLocalIP :: Interface → IO IP +getLocalIP interface = return . matching "inet addr:(.+) ." =<< run ("ifconfig " ++ interface) + +getESSID :: Interface → IO SSID +getESSID interface = return . matching "ESSID:\"(.+)\"" =<< run ("iwconfig " ++ interface) + +getAP :: Interface → IO AP +getAP interface = return . matching "Access Point: (.+)\n" =<< run ("iwconfig " ++ interface) + +data ConnectionStatus = NotConnected | Connected IP SSID + deriving (Show, Read, Eq, Ord) + +getConnectionStatus :: Interface → IO ConnectionStatus +getConnectionStatus interface = do + ip ← getLocalIP interface + case ip of + [] → return NotConnected + ip → do + ap ← getAP interface + case (debug ap) of + "Not-Associated " → return NotConnected + ap → return . Connected ip =<< getESSID interface + +matching :: String → String → String +matching = \pattern info → case info =~ pattern of { [[a,b]] → b; _ → "" } + +debug :: Show a ⇒ a → a +debug a = unsafePerformIO (print a >> return a) + +exec :: String → IO () +exec cmd = runCommand cmd >>= waitForProcess >> return () + +pcom :: String → [String] → IO () +pcom c = exec . unwords . (c:) + +modprobe :: [String] → IO () +modprobe = pcom "modprobe" + +iwconfig :: [String] → IO () +iwconfig = pcom "iwconfig" + +ifconfig :: [String] → IO () +ifconfig = pcom "ifconfig" + +dhclient :: [String] → IO () +dhclient = pcom "dhclient" + +wpa_supplicant :: [String] → IO () +wpa_supplicant = pcom "wpa_supplicant" + +initHardware :: String → Interface → IO () +initHardware driver interface = do + disconnect interface + modprobe ["-r", driver] + modprobe [driver] + ifconfig [interface, "up"] + threadDelay 2000000 + exec $ "iwlist " ++ interface ++ " scan" + return () + +disconnect :: Interface → IO () +disconnect interface = do + exec $ "killall dhclient" + exec $ "killall wpa_supplicant" + ifconfig [interface, "down"] + +connectFree :: Interface → SSID → IO () +connectFree interface ssid = do + disconnect interface + ifconfig [interface, "up"] + iwconfig [interface, "essid", ssid] + dhclient [interface] + +connectWEP :: Interface → SSID → Key → IO () +connectWEP interface ssid key = do + disconnect interface + ifconfig [interface, "up"] + iwconfig [interface, "essid", ssid, "key", "s:" ++ key] + dhclient [interface] + +----- +data ConnectionSetting = Free SSID + | Encrypted SSID Encryption Key + deriving (Show, Read, Eq, Ord) + +connect :: Interface → ConnectionSetting → IO () +connect it (Free id ) = connectFree it id +connect it (Encrypted id WEP ky) = connectWEP it id ky +connect _ _ = do + putStrLn "Only non- or WEP-encrypted networks can be connected to." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2008 Cetin Sert. All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE FREEBSD PROJECT ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT +SHALL THE FREEBSD PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,457 @@ +{-# 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 "essid" =<< label + att 1 =<< markup "quality" =<< label + att 2 =<< markup "encryption" =<< label + att 3 =<< markup "password" =<< label + att 4 =<< markup "action" =<< 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 = ("" ++ ) . ( ++ "") + 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 = "\ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ " + + +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 () diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,29 @@ +DIST_PRE = HNM +TODAY = $(shell date +%Y%m%d) +VERSION = $(./version) +DIST_NAME = $(DIST_PRE)-$(VERSION) + + +.PHONY: all configure build install dist clean + +default all: configure build + +configure: + runhaskell Setup.hs configure + +build: + runhaskell Setup.hs build + +install: + runhaskell Setup.hs install + +dist: + cabal sdist + +clean: + -runhaskell Setup.hs clean + -rm -rf dist + $(MAKE) -C test clean + +setup: Setup.lhs + ghc --make -package Cabal -o setup Setup.hs diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,1 @@ +Happy Network Manager diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/settings.conf b/settings.conf new file mode 100644 --- /dev/null +++ b/settings.conf @@ -0,0 +1,3 @@ +[ +Encrypted "o2DSL" (WEP ) "gLcfefcJcYnSU" +]