diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -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, 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/VKQ.hs b/src/VKQ.hs --- a/src/VKQ.hs +++ b/src/VKQ.hs @@ -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 () diff --git a/src/Web/VKHS/Curl.hs b/src/Web/VKHS/Curl.hs --- a/src/Web/VKHS/Curl.hs +++ b/src/Web/VKHS/Curl.hs @@ -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;