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 ~== "