VKHS 0.5.4 → 0.5.5
raw patch · 4 files changed
+225/−12 lines, 4 filesdep −tagsoup-parsec
Dependencies removed: tagsoup-parsec
Files
- VKHS.cabal +2/−2
- src/Text/HTML/TagSoup/Parsec.hs +209/−0
- src/VKQ.hs +5/−1
- src/Web/VKHS/Curl.hs +9/−9
VKHS.cabal view
@@ -1,6 +1,6 @@ name: VKHS-version: 0.5.4+version: 0.5.5 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction@@ -43,6 +43,7 @@ Network.Protocol.Http.Printer, Network.Protocol.Http.Parser, Network.Protocol.Http.Headers, Network.Protocol.Http.Data, Text.Namefilter, Text.PFormat,+ Text.HTML.TagSoup.Parsec, Data.Label.Abstract, Data.Label.Derive, Data.Label.Maybe,@@ -70,7 +71,6 @@ containers, mtl, bytestring,- tagsoup-parsec, tagsoup, failure, curlhs,
+ 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/VKQ.hs view
@@ -6,6 +6,7 @@ module Main where import Control.Monad+import Control.Exception (SomeException(..),catch,bracket) import Data.Aeson as A import Data.Label.Abstract import Data.List@@ -114,7 +115,7 @@ <> help "FileName format, supported tags: %i %o %a %t %d %u" ) <*> strOption (metavar "DIR" <> short 'o' <> help "Output directory" <> value "")- <*> some (argument str (metavar "RECORD_ID" <> help "Download records"))+ <*> many (argument str (metavar "RECORD_ID" <> help "Download records")) <*> flag False True (long "skip-existing" <> help "Don't download existing files") )) ( progDesc "List or download music files"))@@ -165,6 +166,9 @@ main = withlib CURL730 $ do m <- maybe (idm) (value) <$> lookupEnv "VKQ_ACCESS_TOKEN" execParser (info (helper <*> opts m) (fullDesc <> header "Vkontakte social network tool")) >>= cmd+ `catch` (\(e::SomeException) -> do+ putStrLn $ (show e)+ putStrLn $ "NOTE: make sure that libcurl.so is accessible (e.g. by setting LD_LIBRARY_PATH variable)" ) cmd :: Options -> IO ()
src/Web/VKHS/Curl.hs view
@@ -40,7 +40,7 @@ buff <- newIORef BS.empty do { bracket (curl_easy_init) (curl_easy_cleanup) $ \curl ->- let + let memwrite n = atomicModifyIORef buff (\o -> (BS.append o n, CURL_WRITEFUNC_OK)) in do@@ -61,10 +61,10 @@ scanPattern pat s = let (_,o,x,n) = BS.foldl' check (False, BS.empty, BS.empty, BS.empty) s in (BS.reverse o, x, BS.reverse n)- where + where check (False, old, st, new) b | BS.length st < BS.length pat = (False, old, st`BS.snoc`b, new)- | st == pat = (True, old, st, b`BS.cons`new) + | st == pat = (True, old, st, b`BS.cons`new) | otherwise = (False, (BS.head st)`BS.cons`old, (BS.tail st)`BS.snoc`b, new) check (True, old, st, new) b = (True, old, st, b`BS.cons`new) @@ -109,7 +109,7 @@ sr <- newIORef =<< (Pending <$> pure BS.empty) bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do {- let + let filewrite bs = do s' <- atomicModifyIORef sr (\s -> let s' = process s bs in (s',s')) case s' of@@ -117,7 +117,7 @@ Pending b -> return CURL_WRITEFUNC_OK Working t -> do cb t- return CURL_WRITEFUNC_OK + return CURL_WRITEFUNC_OK in curl_easy_setopt curl $ [ CURLOPT_HEADER True@@ -126,7 +126,7 @@ , CURLOPT_USERAGENT a , CURLOPT_VERBOSE (v == Debug) , CURLOPT_URL url- ]; + ]; curl_easy_perform curl; threadDelay (1000 * d); -- convert ms to us@@ -149,9 +149,9 @@ sr <- newIORef (BS.empty, Pending BS.empty) bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do {- let + let writer bs = do- atomicModifyIORef sr (\(buff,s) -> let s' = process s bs ; paired x =(x,x) in + atomicModifyIORef sr (\(buff,s) -> let s' = process s bs ; paired x =(x,x) in case s' of FailNoHeader -> paired (buff,s') Pending b -> paired (buff,s')@@ -165,7 +165,7 @@ , CURLOPT_SSL_VERIFYPEER False , CURLOPT_USERAGENT a , CURLOPT_VERBOSE (v == Debug)- ] ++ (execWriter w); + ] ++ (execWriter w); curl_easy_perform curl; threadDelay (1000 * d); -- convert ms to us (buff,s) <- readIORef sr;