diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,14 +12,22 @@ * Provide access to VK API. Interface options include: VK monad and `vkq` command line tool. -* Connection uses HTTPS protocol -* Automatic login form solving, may be used to operate on new/disposable - accounts. -* The VK monad is designed as an interruptable coroutine. Default superwiser - supports ondemand re-login and may be used for long-running tasks. -* Project includes a set of simplified API wrappers which are designed to be - copied into `runhaskell` script and tweaked according to user needs. +* Use HTTPS protocol. +* Solve login form interaction, may be used to operate new/disposable VK accounts. +* VK monad is an interruptable coroutine. The superwiser supports ondemand + re-login, and may be used for long-running tasks. +* Project includes a set of `Web.VKHS.API.Simple` wrappers designed to be + copied into `runhaskell` scripts and tweaked according to ones need. +Issues +====== + +* Still no support for captchas, one probably should hack `defaultSuperwiser` + and add them +* Network connection timeout is not handled by superwiser +* Minor issues here and there. Use `git grep FIXME` to find them +* File uploading still not functioning + Installing ========== @@ -45,20 +53,29 @@ Developing using Nix -------------------- -We use [Nix](http://nixos.org) as a main development platform. In order to open -development environment, do the following: +The author of this project uses [Nix](http://nixos.org) as a main development +platform. Typical development procedure includes the following steps: $ git clone https://github.com/grwlf/vkhs $ cd vkhs + $ $ nix-shell - $ ... + + .. Entering Nix shell environment + $ ghci -isrc:app/vkq:app/common - $ cabal build + $ exit + .. Now exiting from the Nix shell + + $ nix-build + +The `default.nix` file contain Nix expression describing the environment + Building ctags file ------------------- -./mktags.sh script may be used to build ctags file. It used `haskdogs` tool, +`./mktags.sh` script may be used to build ctags file. It used `haskdogs` tool, which should be installed from Hackage. $ haskdogs @@ -68,8 +85,9 @@ VKQ command line application ============================ -VKQ is a command line tool which demonstrates API usage. It can be used for -logging in, downloading music and reading wall messages. +`vkq` is a command line tool which demonstrates API usage. It can be used for +logging in, downloading music and reading wall messages. Call `vkq --help` or +`vkq --help [command]` to read online help. Log in to VK @@ -80,9 +98,9 @@ $ vkq login user@mail.org pass123 d8a41221616ef5ba19537125dc0349bad9d529fa15314ad765911726fe98b15185ac41a7ca2c62f3bf4b9 -VKQ returns three values. First is a access token which is required to execute -future API requests. VKQ reads it from VKQ\_ACCESS\_TOKEN environment variable so -we have to set it up +VKQ returns three values. First one is an access token required to execute all +API requests. `vkq` tries to reads it from `VKQ_ACCESS_TOKEN` environment variable or +from `.vkhs-access-token` file (may be changed using options). $ export VKQ_ACCESS_TOKEN=d785932b871f096bd73aac6a35d7a7c469dd788d796463a871e5beb5c61bc6c96788ec2 @@ -94,7 +112,10 @@ $ vkq call groups.search q=Beatles --pretty --access-token-file=.access-token +Latest versions of the library have `--access-token-flag` option enabled by +default. Set it to empty value to disable the caching feature. + Performing custom API calls --------------------------- @@ -126,7 +147,7 @@ VKHS library/runhaskell mode ============================ -Starting from 1.7.2 there are initial support for RunHaskell-mode. Consider the +Starting from 1.7.2 the library supports RunHaskell-mode. Consider the following example: @@ -143,17 +164,16 @@ forM_ cs $ \Country{..} -> do liftIO $ putStrLn co_title -When executed, the program should ask for login and password and output list of -countries known to VK. Consider reviewing Web.VKHS.API.Simple where -`getCountries` and several other methods are defined. Also, check the source -code of the `vkq` application for more elaborated usage example. +When executed, the program asks for login/password and outputs list of countries +known to VK. `getCountries` and several other methods are defined in +`Web.VKHS.API.Simple`. `vkq` application may be used as a more elaborated +example. Debugging ========= -`RepatedForm` message means that VKHS tries to fill the web form with available -data, but the form appears again. Typically, that means that the password wa -invalid or captcha is required. +Verbosity may be increased using `--verbose` flag or `o_verbose` field of +`GenericOptions`. Login automata saves `latest.html` file during operation. References ========== diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -1,6 +1,6 @@ name: VKHS -version: 1.8.2 +version: 1.8.3 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction diff --git a/app/vkq/Main.hs b/app/vkq/Main.hs --- a/app/vkq/Main.hs +++ b/app/vkq/Main.hs @@ -202,9 +202,9 @@ x <- apiJ a_method (map (id *** tpack) $ splitFragments "," "=" a_args) if a_pretty then do - liftIO $ BS.putStrLn $ jsonEncodePretty x + liftIO $ putStrLn $ jsonEncodePretty x else - liftIO $ BS.putStrLn $ jsonEncode x + liftIO $ putStrLn $ jsonEncode x return () cmd (Music go@GenericOptions{..} mo@MusicOptions{..}) = do diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs --- a/src/Web/VKHS.hs +++ b/src/Web/VKHS.hs @@ -150,7 +150,10 @@ alert $ "Too many requests per second, consider changing options" go (k $ ReExec m args) ErrorCode ec -> do - alert $ "Unknown error code " <> tshow ec + alert $ "Unhandled error code " <> tshow ec <> "\n" + <> "Consider improving 'defaultSuperwiser' or applying \n" + <> "custom error filters using `apiH` ,`apiHS` or their \n" + <> "high-level wrappers `apiSimpleH` / `apiSimpleHM`" lift $ throwError res_desc _ -> do diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs --- a/src/Web/VKHS/API/Base.hs +++ b/src/Web/VKHS/API/Base.hs @@ -19,6 +19,7 @@ import Control.Exception (catch, SomeException) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.ByteString.Lazy (fromStrict,toChunks) import qualified Data.ByteString.Char8 as BS @@ -148,7 +149,7 @@ ReParse j -> do pure j case parseJSON j of - (Right a) -> return a + (Right (Response _ a)) -> return a (Left e) -> do recovery <- raise (CallFailure (m0, args0, j, e)) go recovery @@ -169,7 +170,9 @@ ReParse j -> do pure j case (parseJSON j, parseJSON j) of - (Right (Response _ a), _) -> return a + (Left e1, Left e2) -> do + recovery <- raise (CallFailure (m0, args0, j, e1 <> ";" <> e2)) + go recovery (Left e, Right (Response _ err)) -> do ma <- (handler err) case ma of @@ -177,9 +180,16 @@ Nothing -> do recovery <- raise (CallFailure (m0, args0, j, e)) go recovery - (Left e1, Left e2) -> do - recovery <- raise (CallFailure (m0, args0, j, e1 <> ";" <> e2)) - go recovery + (Right _, Right (Response _ err)) -> do + ma <- (handler err) + case ma of + Just a -> return a + Nothing -> do + recovery <- raise (CallFailure (m0, args0, j, + "Response matches both error and result object")) + go recovery + (Right (Response _ a), _) -> do + return a apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s) => MethodName -- ^ API method name @@ -224,9 +234,15 @@ api_S m args = api m (map (id *** tpack) args) -- Encode JSON back to string -jsonEncode :: JSON -> ByteString -jsonEncode JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson +jsonEncodeBS :: JSON -> ByteString +jsonEncodeBS JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson -jsonEncodePretty :: JSON -> ByteString -jsonEncodePretty JSON{..} = BS.concat $ toChunks $ Aeson.encodePretty js_aeson +jsonEncode :: JSON -> Text +jsonEncode JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encode js_aeson + +jsonEncodePrettyBS :: JSON -> ByteString +jsonEncodePrettyBS JSON{..} = BS.concat $ toChunks $ Aeson.encodePretty js_aeson + +jsonEncodePretty :: JSON -> Text +jsonEncodePretty JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encodePretty js_aeson diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs --- a/src/Web/VKHS/API/Simple.hs +++ b/src/Web/VKHS/API/Simple.hs @@ -3,7 +3,7 @@ -- function from this module into their 'runhaskell' script and customize -- as required. -- --- Runhaskell script may look like the following: +-- Runhaskell script may looks like the following: -- @ -- #!/usr/bin/env runhaskell -- {-# LANGUAGE RecordWildCards #-} @@ -50,7 +50,7 @@ max_count = 1000 ver = "5.44" -apiSimple nm args = resp_data <$> apiR nm (("v",ver):args) +apiSimple nm args = apiR nm (("v",ver):args) apiSimpleH nm args handler = apiH nm (("v",ver):args) handler apiSimpleHM nm args handler = apiHM nm (("v",ver):args) handler apiVer nm args = api nm (("v",ver):args) @@ -87,6 +87,7 @@ ] ++ maybe [] (\q -> [("q",q)]) mq +-- | See [https://vk.com/dev/wall.get] getGroupWall :: forall m x s . (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord]) getGroupWall GroupRecord{..} = apiSimpleHM "wall.get" diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs --- a/src/Web/VKHS/API/Types.hs +++ b/src/Web/VKHS/API/Types.hs @@ -124,6 +124,9 @@ <$> (o .: "error_code") <*> (o .: "error_msg") +-- | Wall post representation (partial) +-- +-- See also https://vk.com/dev/objects/post data WallRecord = WallRecord { wr_id :: Int , wr_from_id :: Int diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs --- a/src/Web/VKHS/Client.hs +++ b/src/Web/VKHS/Client.hs @@ -1,3 +1,4 @@ +-- | This module mainly contains HTTP wrappers required to operate VK monad {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} @@ -135,7 +136,7 @@ Nothing -> Left (ErrorParseURL s "Client.parseURI failed") Just u -> Right (URL u) --- | * FIXME Convert to BS +-- | * FIXME Convert to ByteString / Text splitFragments :: String -> String -> String -> [(String,String)] splitFragments sep eqs = filter (\(a, b) -> not (null a)) @@ -150,7 +151,7 @@ trim = rev (dropWhile (`elem` (" \t\n\r" :: String))) where rev f = reverse . f . reverse . f --- | * FIXME Convert to BS +-- | * FIXME Convert to ByteString / Text urlFragments :: URL -> [(String,String)] urlFragments URL{..} = splitFragments "&" "=" $ unsharp $ Client.uriFragment uri where unsharp ('#':x) = x @@ -183,6 +184,7 @@ , req_jar :: Client.CookieJar } +-- | Create HTTP(S) GET request requestCreateGet :: (MonadClient m s) => URL -> Cookies -> m (Either Error Request) requestCreateGet URL{..} Cookies{..} = do case setUri Client.defaultRequest uri of @@ -199,6 +201,7 @@ req_jar = jar } +-- | Create HTTP(S) POST request requestCreatePost :: (MonadClient m s) => FilledForm -> Cookies -> m (Either Error Request) requestCreatePost (FilledForm tit Shpider.Form{..}) c = do case Client.parseURI (Client.escapeURIString Client.isAllowedInURI action) of @@ -211,6 +214,11 @@ Right Request{..} -> do return $ Right $ Request (Client.urlEncodedBody (map (BS.pack *** BS.pack) $ Map.toList inputs) req) req_jar +-- | Upload the bytestring data @bs@ to the server @text_url@ +-- +-- * FIXME This function is not working. Looks like VK requires some other +-- FIXME method rather than urlEncodedBody. +-- * FIXME Use 'URL' rather than Text requestUploadPhoto :: (MonadClient m s) => Text -> ByteString -> m (Either Error Request) requestUploadPhoto text_url bs = do case Client.parseURI (Text.unpack text_url) of @@ -260,6 +268,7 @@ responseOK r = c == 200 where c = responseCode r +-- | Execute the 'Request' created by 'requestCreatePost' or 'requestCreateGet' requestExecute :: (MonadClient m s) => Request -> m (Response, Cookies) requestExecute Request{..} = do jar <- pure req_jar @@ -269,7 +278,8 @@ let interval_ns = toNanoSecs (clk `diffTimeSpec` cl_last_execute) when (interval_ns < cl_minimum_interval_ns) $ do when cl_verbose $ do - hPutStrLn stderr $ "Delaying execution to match the request threshold limit of " <> show cl_minimum_interval_ns <> " ns" + hPutStrLn stderr $ "Delaying execution to match the request threshold limit of " + <> show cl_minimum_interval_ns <> " ns" threadDelay (fromInteger $ (cl_minimum_interval_ns - interval_ns) `div` 1000); -- convert ns to us return clk @@ -282,6 +292,7 @@ let (jar', resp') = Client.updateCookieJar resp req now jar return (Response resp resp_body, Cookies jar') +-- | Download helper downloadFileWith :: (MonadClient m s) => URL -> (ByteString -> IO ()) -> m () downloadFileWith url h = do (ClientState{..}) <- toClientState <$> get diff --git a/src/Web/VKHS/Imports.hs b/src/Web/VKHS/Imports.hs --- a/src/Web/VKHS/Imports.hs +++ b/src/Web/VKHS/Imports.hs @@ -47,7 +47,9 @@ import Data.Text (Text(..), pack, unpack) import Data.Text.IO (putStrLn, hPutStrLn) import Data.List (head, length, sortBy, (++)) -import Prelude (Integer, FilePath, (==), (.), Show(..), String, ($), IO(..), Bool(..), compare, Ordering(..)) +import Prelude (error, Integer, FilePath, (==), (.), Show(..), String, + ($), IO(..), Bool(..), compare, Ordering(..), + Read(..)) import Text.Printf import Text.Show.Pretty import Text.Read (readMaybe) diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs --- a/src/Web/VKHS/Types.hs +++ b/src/Web/VKHS/Types.hs @@ -98,8 +98,14 @@ deriving(Show, Eq, Ord) +-- | JSON wrapper. +-- +-- * FIXME Implement full set of helper functions data JSON = JSON { js_aeson :: Aeson.Value } deriving(Show, Data, Typeable) + +instance FromJSON JSON where + parseJSON v = return $ JSON v parseJSON :: (Aeson.FromJSON a) => JSON -> Either String a parseJSON j = Aeson.parseEither Aeson.parseJSON (js_aeson j)