diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/WL500gPLib.cabal b/WL500gPLib.cabal new file mode 100644 --- /dev/null +++ b/WL500gPLib.cabal @@ -0,0 +1,22 @@ +name: WL500gPLib +version: 0.3.1 +cabal-version: >= 1.2 +license: BSD3 +license-file: LICENSE +author: Vasyl Pasternak +category: Network +synopsis: A simple library to access to the WL 500gP router + from the Haskell code +build-type: Simple + +library + build-depends: base < 4, curl, tagsoup, mtl + exposed-modules: Network.Asus.WL500gP + hs-source-dirs: src + +executable test + main-is: Main.hs + build-depends: base < 4 + hs-source-dirs: src + other-modules: Network.Asus.WL500gP + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,54 @@ + +module Main where + +import qualified Network.Asus.WL500gP as R +import System.Environment (getArgs) +import Control.Monad (liftM, sequence_) +import Data.Either (either) +import Control.Concurrent (threadDelay) +import Control.Monad.Trans (liftIO) + +main :: IO () +main = do + args <- getArgs + runWith args + +defaultConnection = R.Connection { + R.user = "admin", + R.password = "admin", + R.hostname = "192.168.1.1" + } + +withConn = R.withConnection defaultConnection + +brace sb cmd sa = sequence_ [putStrLn sb, cmd, putStrLn sa] + +runWith :: [String] -> IO () +runWith args + | head args == "status" = + either putStrLn print =<< withConn R.readStatus + + | head args == "log" = + either putStrLn (putStr . unlines . reverse . take 10 . reverse) + =<< withConn R.readLog + + | head args == "disconnect" = + brace "Disconnecting from WAN..." + (withConn R.disconnectWan) + "Disconnected" + | head args == "connect" = + brace "Connecting to WAN..." + (withConn R.connectWan) + "Signal sent. Check the status" + | head args == "reconnect" = + brace "Reconnecting WAN..." + (withConn $ sequence_ [R.disconnectWan, + liftIO $ threadDelay 5000, + R.connectWan]) + "Done. Check the status" + | head args == "clear" = + brace "Clearing log..." + (withConn R.clearLog) + "Done" + | otherwise = undefined + diff --git a/src/Network/Asus/WL500gP.hs b/src/Network/Asus/WL500gP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Asus/WL500gP.hs @@ -0,0 +1,175 @@ + +module Network.Asus.WL500gP + ( + -- Structures + Connection (..) + ,ConnectionStatus (..) + ,Status (..) + ,Log + + -- monadic operations + ,Conn + ,withConnection + ,readStatus + ,readLog + ,connectWan + ,disconnectWan + ,clearLog + + ) where + +import Control.Monad.Reader +import Network.Curl +import Text.Printf (printf) +import Text.HTML.TagSoup +import Data.List (tails) +import Data.Maybe (maybe) +import Data.Either (either) +import Control.Monad (guard) + +data ConnectionStatus = Connected | Disconnected deriving (Eq, Show) + +toConnStatus :: String -> ConnectionStatus +toConnStatus s = if s == "Connected" then Connected else Disconnected + +-- |Connection - stores the connection credentials +data Connection = Connection { + user :: String -- ^ user name + , password :: String -- ^ user password + , hostname :: String -- ^ hostname (ip address) + } deriving (Show, Eq) + +-- |Status - return the complete connection information +data Status = Status { + connectionStatus :: ConnectionStatus -- ^ connection status + -- (connected, disconnected) + , ip :: String -- ^ given ip address + , subnetMask :: String -- ^ subnet mask + , defaultGateway :: String -- ^ gefault gateway + , dnsServers :: [String] -- ^ list of ip addresses of DNS servers + } deriving (Show) + +-- |Log - router log representation +type Log = [String] + +-- |Conn is the Reader monad over IO. It holds credentials to +-- sequence actions with router +type Conn a = ReaderT Connection IO a + +-- |Runs the Conn monad, logouts before exit +withConnection :: Connection -> Conn a -> IO a +withConnection con cl = runReaderT cl' con + where cl' = cl >>= \r -> logout >> return r + +-- |Reads the router status. `Left` is error +readStatus :: Conn (Either String Status) +readStatus = + liftM (either Left + (toEither "Fail to parse data" . parseStatusPage)) $ + getPage "Main_GStatus_Content.asp" + +-- |Reads the router log +readLog :: Conn (Either String Log) +readLog = + liftM (either Left + (toEither "Fail to parse data" . parseLogPage)) $ + getPage "Main_LogStatus_Content.asp" + +-- |Send disconnect signal. Doesn't wait for response and doesn't +-- checks the result. +disconnectWan :: Conn () +disconnectWan = + performAction (actionState "dhcpc_release") + +-- |Connects to the WAN. Similary to disconnecting, doesn't wait for result. +-- It is useful to check the log after some time elapsed +connectWan :: Conn () +connectWan = + performAction (actionState "dhcpc_renew") + +-- |Clears log. It seems, that it allways succeeded +clearLog :: Conn () +clearLog = + performAction (actionLog "+Clear+") + +--- +-- some helper functions +--- + +-- maybe to either conversion +toEither :: a -> Maybe b -> Either a b +toEither a = maybe (Left a) Right + +-- and action is simple call to http://hostname/apply.cgi with +-- GET request in the url +performAction :: String -> Conn () +performAction act = do + up <- getUserPassword + url <- liftM (++ act) $ getUrl "apply.cgi" + (resuln, str) <- liftIO $ curlGetString url $ CurlUserPwd up : method_GET + return () + +-- creates a GET request, valid for state page +actionState :: String -> String +actionState = printf "?action_mode=Update&action_script=%s" + +-- creates a GET request, valide for log page +actionLog :: String -> String +actionLog = printf "?action_mode=%s" + +-- simply downloads the page (note: page is not url) +getPage :: String -> Conn (Either String String) +getPage page = do + up <- getUserPassword + url <- getUrl page + (result, str) <- liftIO $ curlGetString url $ CurlUserPwd up : method_GET + return $ if result /= CurlOK + then Left $ printf "Failed to get url: '%s'" url + else Right str + +-- retrieve user and password in the format of "user:password" +getUserPassword :: Conn String +getUserPassword = do + u <- liftM (user) ask + p <- liftM (password) ask + return $ printf "%s:%s" u p + +-- retrieve the page url on the given hostname +getUrl :: String -> Conn String +getUrl page = do + h <- liftM (hostname) ask + return $ printf "http://%s/%s" h page + +-- log outs from the router +logout :: Conn () +logout = do + url <- getUrl "Logout.asp" + liftIO $ curlGetString url method_GET + return () + +parseStatusPage :: String -> Maybe Status +parseStatusPage content = + let + inputs = [(fromAttrib "name" a, fromAttrib "value" a) + | a:_ <- tails (parseTags content) + , a~== "" + , fromAttrib "name" a /= ""] + in do + (status':ip':subnet':gateway':dns':[]) <- + mapM (`lookup` inputs) ["wan_status_t", "wan_ipaddr_t", "wan_netmask_t", + "wan_gateway_t", "wan_dns_t"] + return $ Status + {connectionStatus = toConnStatus status' + ,ip = ip' + ,subnetMask = subnet' + ,defaultGateway = gateway' + ,dnsServers = words dns'} + +parseLogPage :: String -> Maybe Log +parseLogPage content = + let + logString = [fromTagText t | a:t:_ <- tails (parseTags content), + a ~== "