WL500gPLib (empty) → 0.3.1
raw patch · 5 files changed
+255/−0 lines, 5 filesdep +basedep +curldep +mtlsetup-changed
Dependencies added: base, curl, mtl, tagsoup
Files
- LICENSE +0/−0
- Setup.lhs +4/−0
- WL500gPLib.cabal +22/−0
- src/Main.hs +54/−0
- src/Network/Asus/WL500gP.hs +175/−0
+ LICENSE view
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ WL500gPLib.cabal view
@@ -0,0 +1,22 @@+name: WL500gPLib+version: 0.3.1+cabal-version: >= 1.2+license: BSD3+license-file: LICENSE+author: Vasyl Pasternak <vasyl.pasternak@gmail.com>+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+
+ src/Main.hs view
@@ -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+
+ src/Network/Asus/WL500gP.hs view
@@ -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~== "<input>"+ , 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 ~== "<textarea class=content_log_td>"]+ in do+ guard (not $ null logString)+ return $ filter (/= "") $ lines $ head logString