summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeyMironov <>2017-06-28 21:11:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-28 21:11:00 (GMT)
commit8406389cdd7af068ef92281cae91cd0d68e76acd (patch)
treef1bd2d7d320805089098a5f27edfe9f40499a7c8
parent380948fb9f2cf1fb8fac8235fa1d0583a595a971 (diff)
version 1.8.31.8.3
-rw-r--r--README.md70
-rw-r--r--VKHS.cabal2
-rw-r--r--app/vkq/Main.hs4
-rw-r--r--src/Web/VKHS.hs5
-rw-r--r--src/Web/VKHS/API/Base.hs34
-rw-r--r--src/Web/VKHS/API/Simple.hs5
-rw-r--r--src/Web/VKHS/API/Types.hs3
-rw-r--r--src/Web/VKHS/Client.hs17
-rw-r--r--src/Web/VKHS/Imports.hs4
-rw-r--r--src/Web/VKHS/Types.hs6
10 files changed, 106 insertions, 44 deletions
diff --git a/README.md b/README.md
index 4ea8859..3979b13 100644
--- a/README.md
+++ b/README.md
@@ -12,13 +12,21 @@ Features
* 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 @@ Installing from source
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 @@ which should be installed from Hackage.
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 @@ Here is an example session: Login first
$ 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,6 +112,9 @@ VKQ may cache the access tokein into a state file:
$ 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 @@ For example, lets call ausio.search method to get some Beatles records:
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 @@ following example:
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
index 4c63266..6cfb689 100644
--- 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
index a0fd539..8a1421e 100644
--- a/app/vkq/Main.hs
+++ b/app/vkq/Main.hs
@@ -202,9 +202,9 @@ cmd (API go APIOptions{..}) = do
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
index 8648341..04680cb 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -150,7 +150,10 @@ defaultSuperviser = go where
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
index 5f40d40..94de399 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -19,6 +19,7 @@ import Control.Monad.Cont
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 @@ apiR m0 args0 = go (ReExec m0 args0) where
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 @@ apiHM m0 args0 handler = go (ReExec m0 args0) where
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 @@ apiHM m0 args0 handler = go (ReExec m0 args0) where
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 :: (Aeson.FromJSON a, MonadAPI m x s)
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
+
+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 -> ByteString
-jsonEncodePretty 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
index faa7762..d1e0be9 100644
--- 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 @@ import Web.VKHS.API.Types
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 @@ getCities Country{..} mq =
] ++
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
index e2e3573..e9dae6a 100644
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -124,6 +124,9 @@ instance FromJSON ErrorRecord where
<$> (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
index 6603eb4..ff6e6f9 100644
--- 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 @@ urlFromString s =
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 @@ splitFragments sep eqs =
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 @@ data Request = Request {
, 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 @@ requestCreateGet URL{..} Cookies{..} = do
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 @@ requestCreatePost (FilledForm tit Shpider.Form{..}) c = do
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 :: Response -> Bool
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 @@ requestExecute Request{..} = do
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 @@ requestExecute Request{..} = do
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
index 0393ec2..e3e8666 100644
--- a/src/Web/VKHS/Imports.hs
+++ b/src/Web/VKHS/Imports.hs
@@ -47,7 +47,9 @@ import Data.Function (on)
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
index 0e578f6..65e3990 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -98,9 +98,15 @@ newtype AppID = AppID { aid_string :: String }
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)