module Network.Shpider.Forms
( module Network.Shpider.Pairs
, Form (..)
, Method (..)
, gatherForms
, fillOutForm
, allForms
, toForm
, mkForm
)
where
import Data.Maybe
import qualified Data.Map as M
import Text.HTML.TagSoup.Parsec
import Network.Shpider.TextUtils
import Network.Shpider.Pairs
data Method =
GET | POST
deriving Show
data Form =
Form { method :: Method
, action :: String
, inputs :: M.Map String String
}
deriving Show
fillOutForm :: Form -> [ ( String , String ) ] -> Form
fillOutForm f is =
foldl ( \ form ( n , v ) -> form { inputs = M.insert n v $ inputs form } )
f
is
mkForm :: String -> Method -> [ ( String , String ) ] -> Form
mkForm a m ps =
Form { action = a
, method = m
, inputs = M.fromList ps
}
gatherForms :: [ Tag ] -> [ Form ]
gatherForms =
tParse allForms
allForms :: TagParser [ Form ]
allForms = do
fs <- allWholeTags "form"
return $ mapMaybe toForm fs
toForm :: WholeTag -> Maybe Form
toForm ( TagOpen _ attrs , innerTags , _ ) = do
m <- methodLookup attrs
a <- attrLookup "action" attrs
let is = tParse ( allOpenTags "input" ) innerTags
tas = tParse ( allWholeTags "textarea" ) innerTags
Just $ Form { inputs = M.fromList $ mapMaybe inputNameValue is ++ mapMaybe textAreaNameValue tas
, action = a
, method = m
}
methodLookup attrs = do
m <- attrLookup "method" attrs
case lowercase m of
"get" ->
Just GET
"post" ->
Just POST
otherwise ->
Nothing
inputNameValue ( TagOpen _ attrs ) = do
v <- case attrLookup "value" attrs of
Nothing ->
Just ""
j@(Just _ ) ->
j
n <- attrLookup "name" attrs
Just ( n , v )
textAreaNameValue ( TagOpen _ attrs , inner , _ ) = do
let v = innerText inner
n <- attrLookup "name" attrs
Just ( n , v )