diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -1,6 +1,6 @@ name: VKHS -version: 1.6.2 +version: 1.6.3 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction @@ -19,6 +19,12 @@ library hs-source-dirs: src other-modules: + Network.Shpider.Forms + Network.Shpider.Pairs + Network.Shpider.TextUtils + Text.HTML.TagSoup.Parsec + Text.Namefilter + Text.PFormat exposed-modules: Web.VKHS diff --git a/src/Network/Shpider/Forms.hs b/src/Network/Shpider/Forms.hs new file mode 100644 --- /dev/null +++ b/src/Network/Shpider/Forms.hs @@ -0,0 +1,154 @@ +{- + - + - Copyright (c) 2009-2010 Johnny Morrice + - + - Permission is hereby granted, free of charge, to any person + - obtaining a copy of this software and associated documentation + - files (the "Software"), to deal in the Software without + - restriction, including without limitation the rights to use, copy, + - modify, merge, publish, distribute, sublicense, and/or sell copies + - of the Software, and to permit persons to whom the Software is + - furnished to do so, subject to the following conditions: + - + - The above copyright notice and this permission notice shall be + - included in all copies or substantial portions of the Software. + - + - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + - SOFTWARE. + - +-} +module Network.Shpider.Forms + ( module Network.Shpider.Pairs + , Form (..) + , Method (..) + , gatherForms + , fillOutForm + , allForms + , toForm + , mkForm + , gatherTitle + , emptyInputs + ) + where + +import Data.Maybe + + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + +import Data.String.UTF8 as U (UTF8(..)) +import qualified Data.String.UTF8 as U + +import qualified Data.Map as M + +import Text.HTML.TagSoup.Parsec + +import Network.Shpider.TextUtils +import Network.Shpider.Pairs + +-- | Either GET or POST. +data Method = + GET | POST + deriving Show + +-- | Plain old form: Method, action and inputs. +data Form = + Form { method :: Method + , action :: String + , inputs :: M.Map String String + } + deriving Show + +emptyInputs :: Form -> [String] +emptyInputs = fst . unzip . filter ( not . null . snd ) . M.toList . inputs + +-- | Takes a form and fills out the inputs with the given [ ( String , String ) ]. +-- It is convienent to use the `pairs` syntax here. +-- +-- @ +-- f : _ <- `getFormsByAction` \"http:\/\/whatever.com\" +-- `sendForm` $ `fillOutForm` f $ `pairs` $ do +-- \"author\" =: \"Johnny\" +-- \"message\" =: \"Nice syntax dewd.\" +-- @ +fillOutForm :: Form -> [ ( String , String ) ] -> Form +fillOutForm f is = + foldl ( \ form ( n , v ) -> form { inputs = M.insert n v $ inputs form } ) + f + is + +-- | The first argument is the action attribute of the form, the second is the method attribute, and the third are the inputs. +mkForm :: String -> Method -> [ ( String , String ) ] -> Form +mkForm a m ps = + Form { action = a + , method = m + , inputs = M.fromList ps + } + +-- | Gets all forms from a list of tags. +gatherForms :: [ Tag String ] -> [ Form ] +gatherForms = + tParse allForms + +gatherTitle :: [Tag String] -> String +gatherTitle ts = case tParse allTitles ts of { [] -> "" ; x:_ -> x } + +allTitles :: TagParser String [String] +allTitles = do + fs <- allWholeTags "title" + return $ mapMaybe ( + \(TagOpen "title" _ , innerTags , _ ) -> + return $ concat $ map (\t -> case t of + TagText t -> t + _ -> [] + ) innerTags + ) fs + +-- | The `TagParser` which parses all forms. +allForms :: TagParser String [ Form ] +allForms = do + fs <- allWholeTags "form" + return $ mapMaybe toForm fs + +toForm :: WholeTag String -> 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 ) + diff --git a/src/Network/Shpider/Pairs.hs b/src/Network/Shpider/Pairs.hs new file mode 100644 --- /dev/null +++ b/src/Network/Shpider/Pairs.hs @@ -0,0 +1,56 @@ +{- + - + - Copyright (c) 2009-2010 Johnny Morrice + - + - Permission is hereby granted, free of charge, to any person + - obtaining a copy of this software and associated documentation + - files (the "Software"), to deal in the Software without + - restriction, including without limitation the rights to use, copy, + - modify, merge, publish, distribute, sublicense, and/or sell copies + - of the Software, and to permit persons to whom the Software is + - furnished to do so, subject to the following conditions: + - + - The above copyright notice and this permission notice shall be + - included in all copies or substantial portions of the Software. + - + - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + - SOFTWARE. + - +-} + +-- | This module provides a nice syntax for defining a list of pairs. +{-# OPTIONS -XFlexibleInstances -XRankNTypes #-} +module Network.Shpider.Pairs + ( PairsWriter + , (=:) + , pairs + ) where + +import Control.Monad.State + +-- | The abstract type describing the monadic state of a list of pairs. +type PairsWriter a b = + State [ ( a , b ) ] + +-- | Take a monadic PairsWriter and return a list of pairs. +pairs :: forall a b c. PairsWriter a b c -> [ ( a , b ) ] +pairs = + reverse . snd . flip runState [ ] + +-- | Make a list of pairs of pairs like +-- +-- @ +-- pairs $ do $ 3 =: ( \" is my favourite number or \" , 5 ) +-- 10 =: ( \" pints have I drunk or was it \" , 11 ) +-- @ +(=:) :: forall a b. a -> b -> PairsWriter a b ( ) +(=:) k v = do + st <- get + put $ ( k , v ) : st + diff --git a/src/Network/Shpider/TextUtils.hs b/src/Network/Shpider/TextUtils.hs new file mode 100644 --- /dev/null +++ b/src/Network/Shpider/TextUtils.hs @@ -0,0 +1,54 @@ +{- + - + - Copyright (c) 2009-2010 Johnny Morrice + - + - Permission is hereby granted, free of charge, to any person + - obtaining a copy of this software and associated documentation + - files (the "Software"), to deal in the Software without + - restriction, including without limitation the rights to use, copy, + - modify, merge, publish, distribute, sublicense, and/or sell copies + - of the Software, and to permit persons to whom the Software is + - furnished to do so, subject to the following conditions: + - + - The above copyright notice and this permission notice shall be + - included in all copies or substantial portions of the Software. + - + - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS + - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN + - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN + - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + - SOFTWARE. + - +-} + +module Network.Shpider.TextUtils where + +import Data.Char + +-- import Network.URI + +import Control.Arrow ( first ) + +-- | A case insensitive lookup for html attributes. +attrLookup :: String -> [ ( String , String ) ] -> Maybe String +attrLookup attr = + lookup ( lowercase attr ) . map ( first lowercase ) + +-- | Drops whitespace from the beginning and end of strings. +trim :: String -> String +trim = + dropWhile isSpace . reverse . dropWhile isSpace . reverse + +-- | Turns a String lowercase. In my humble opinion, and considering that a few different packages implement this meager code, this should be in the prelude. +lowercase :: String -> String +lowercase = + map toLower + +-- | Encode spaces in a URL +-- escapeSpaces :: String -> String +-- escapeSpaces = +-- encString True ( \ _ -> True ) + diff --git a/src/Text/HTML/TagSoup/Parsec.hs b/src/Text/HTML/TagSoup/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/TagSoup/Parsec.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE FlexibleContexts #-} +module Text.HTML.TagSoup.Parsec + ( module Text.HTML.TagSoup + , TagParser + , TagParserSt + , WholeTag + , tParse + , tStParse + , openTag + , maybeOpenTag + , eitherOpenTag + , notOpenTag + , allOpenTags + , wholeTag + , maybeWholeTag + , eitherWholeTag + , allWholeTags + , closeTag + , maybeCloseTag + , eitherCloseTag + , notCloseTag + , allCloseTags + , maybeP + , allP + , eitherP + ) + where + +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Pos +import Text.HTML.TagSoup + +import Text.StringLike + +import Data.Maybe +import Data.Char + +-- | A type represent the TagOpen, any inner tags , and the TagClose. +type WholeTag str = (Tag str, [Tag str] , Tag str) + +-- | The Tag parser, using Tag as the token. +type TagParser str = GenParser (Tag str) () + +-- | A stateful tag parser +-- This is a new type alias to allow backwards compatibility with old code. +type TagParserSt str u = GenParser (Tag str) u + +-- | Used to invoke parsing of Tags. +tParse :: (StringLike str, Show str) => TagParser str a -> [ Tag str ] -> a +tParse p ts = + either ( error . show ) id $ parse p "tagsoup" ts + +-- | Simply run a stateful tag parser +tStParse :: (StringLike str, Show str) => TagParserSt str st a -> st -> [ Tag str ] -> a +tStParse p state tos = + either ( error . show ) id $ runParser p state "tagsoup" tos + + +-- Tag eater is the basic tag matcher, it increments the line number for each tag parsed. +tagEater matcher = + tokenPrim show + ( \ oldSp _ _ -> do + setSourceLine oldSp ( 1 + sourceLine oldSp ) + ) + matcher + +-- make a string lowercase +lowercase :: StringLike s => s -> s +lowercase = + fromString . map toLower . toString + + +-- | openTag matches a TagOpen with the given name. It is not case sensitive. +openTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str) +openTag soughtName = + openTagMatch soughtName ( Just ) $ \ _ -> Nothing + +-- | notOpenTag will match any tag which is not a TagOpen with the given name. It is not case sensitive. +notOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str) +notOpenTag avoidName = + openTagMatch avoidName ( \ _ -> Nothing ) Just + +-- openTagMatch is the higher order function which will receive a TagOpen, and call match if it matches the soughtName, and noMatch if it doesn't +openTagMatch soughtName match noMatch = + tagEater $ \ tag -> + case tag of + t@( TagOpen tname atrs ) -> + if lowercase tname == lowercase soughtName + then + match t + else + noMatch t + t -> + noMatch t + +-- closeTagMatch is the higher order function which will receive a TagClose, and call match if it matches the soughtName and noMatch if it doesn't. +closeTagMatch soughtName match noMatch = + tagEater $ \ tag -> + case tag of + t@( TagClose tname ) -> + if lowercase tname == lowercase soughtName + then + match t + else + noMatch t + t -> + noMatch t + +-- | wholeTag matches a TagOpen with the given name, +-- then all intervening tags, +-- until it reaches a TagClose with the given name. +-- It is not case sensitive. +wholeTag :: (StringLike str, Show str) => str -> TagParserSt str st (WholeTag str) +wholeTag soughtName = do + open <- openTag soughtName + ts <- many $ notCloseTag soughtName + close <- closeTag soughtName + return ( open , ts , close ) + +-- | closeTag matches a TagClose with the given name. It is not case sensitive. +closeTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str) +closeTag soughtName = + closeTagMatch soughtName ( Just ) $ \ _ -> Nothing + +-- | notCloseTag will match any tag which is not a TagClose with the given name. It is not case sensitive. +notCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str) +notCloseTag avoidName = + closeTagMatch avoidName ( \ _ -> Nothing ) Just + +-- | maybeOpenTag will return `Just` the tag if it gets a TagOpen with he given name, +-- It will return `Nothing` otherwise. +-- It is not case sensitive. +maybeOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) ) +maybeOpenTag = + maybeP . openTag + +-- | maybeCloseTag will return `Just` the tag if it gets a TagClose with he given name, +-- It will return `Nothing` otherwise. +-- It is not case sensitive. +maybeCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) ) +maybeCloseTag = + maybeP . closeTag + +-- | maybeWholeTag will return `Just` the tag if it gets a WholeTag with he given name, +-- It will return `Nothing` otherwise. +-- It is not case sensitive. +maybeWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (WholeTag str) ) +maybeWholeTag = + maybeP . wholeTag + +-- | allOpenTags will return all TagOpen with the given name. +-- It is not case sensitive. +allOpenTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ] +allOpenTags = + allP . maybeOpenTag + +-- | allCloseTags will return all TagClose with the given name. +-- It is not case sensitive. +allCloseTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ] +allCloseTags = + allP . maybeCloseTag + +-- | allWholeTags will return all WholeTag with the given name. +-- It is not case sensitive. +allWholeTags :: (StringLike str, Show str) => str -> TagParserSt str st [ WholeTag str ] +allWholeTags = + allP . maybeWholeTag + +-- | eitherP takes a parser, and becomes its `Either` equivalent -- returning `Right` if it matches, and `Left` of anyToken if it doesn't. +eitherP :: Show tok => GenParser tok st a -> GenParser tok st ( Either tok a ) +eitherP p = do + try ( do t <- p + return $ Right t + ) <|> ( do t <- anyToken + return $ Left t + ) +-- | either a Right TagOpen or a Left arbitary tag. +eitherOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) ) +eitherOpenTag = + eitherP . openTag + +-- | either a Right TagClose or a Left arbitary tag. +eitherCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) ) +eitherCloseTag = + eitherP . closeTag + +-- | either a Right WholeTag or a Left arbitary tag. +eitherWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (WholeTag str) ) +eitherWholeTag = + eitherP . wholeTag + +-- | allP takes a parser which returns a `Maybe` value, and returns a list of matching tokens. +allP :: GenParser tok st ( Maybe a ) -> GenParser tok st [ a ] +allP p = do + ts <- many p + let ls = + catMaybes ts + return ls + +-- | maybeP takes a parser, and becomes its `Maybe` equivalent -- returning `Just` if it matches, and `Nothing` if it doesn't. +maybeP :: Show tok => GenParser tok st a -> GenParser tok st ( Maybe a ) +maybeP p = + try ( do t <- p + return $ Just t + ) <|> ( do anyToken + return Nothing + ) + + diff --git a/src/Text/Namefilter.hs b/src/Text/Namefilter.hs new file mode 100644 --- /dev/null +++ b/src/Text/Namefilter.hs @@ -0,0 +1,17 @@ +module Text.Namefilter + ( namefilter + ) where + +import Data.Char +import Data.List +import Text.RegexPR + +trim_space = gsubRegexPR "^ +| +$" "" +one_space = gsubRegexPR " +" " " +normal_letters = filter (\c -> or [ isAlphaNum c , c=='-', c=='_', c==' ', c=='&']) +html_amp = gsubRegexPR "&" "&" +no_html = gsubRegexPR re "" where + re = concat $ intersperse "|" [ "&[a-z]+;" , "&#[0-9]+;" ] + +namefilter :: String -> String +namefilter = trim_space . one_space . normal_letters . no_html . html_amp diff --git a/src/Text/PFormat.hs b/src/Text/PFormat.hs new file mode 100644 --- /dev/null +++ b/src/Text/PFormat.hs @@ -0,0 +1,24 @@ +module Text.PFormat + ( pformat + ) where + +import Data.List +import Data.Maybe + +-- | Example: pformat '%' [('%',"%"), ('w',"world")] "hello %% %x %w" +-- pformat' :: Char -> [(Char,String)] -> String -> String +-- pformat' x d s = reverse $ scan [] s where +-- scan h (c:m:cs) +-- | c == x = scan ((reverse $ fromMaybe (c:m:[]) (lookup m d))++h) cs +-- | otherwise = scan (c:h) (m:cs) +-- scan h (c:[]) = c:h +-- scan h [] = h + +pformat :: Char -> [(Char,a->String)] -> String -> a -> String +pformat x d s a = reverse $ scan [] s where + scan h (c:m:cs) + | c == x = scan ((reverse $ fromMaybe (const $ c:m:[]) (lookup m d) $ a)++h) cs + | otherwise = scan (c:h) (m:cs) + scan h (c:[]) = c:h + scan h [] = h +