packages feed

VKHS 1.6.2 → 1.6.3

raw patch · 7 files changed

+521/−1 lines, 7 files

Files

VKHS.cabal view
@@ -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
+ src/Network/Shpider/Forms.hs view
@@ -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 )+
+ src/Network/Shpider/Pairs.hs view
@@ -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+
+ src/Network/Shpider/TextUtils.hs view
@@ -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.  <rant>In my humble opinion, and considering that a few different packages implement this meager code, this should be in the prelude.</rant>+lowercase :: String -> String +lowercase =+   map toLower++-- | Encode spaces in a URL+-- escapeSpaces :: String -> String+-- escapeSpaces =+--    encString True ( \ _ -> True )+
+ src/Text/HTML/TagSoup/Parsec.hs view
@@ -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+             )++
+ src/Text/Namefilter.hs view
@@ -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 "&amp;" "&"+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
+ src/Text/PFormat.hs view
@@ -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+