summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeyMironov <>2017-06-28 17:41:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-28 17:41:00 (GMT)
commit380948fb9f2cf1fb8fac8235fa1d0583a595a971 (patch)
tree0bacd366f1994a8d046193effffd9bf1b613a71b
parenta3a0c90d79eef7fa63915f8e1691ee09f9d50bf6 (diff)
version 1.8.21.8.2
-rw-r--r--VKHS.cabal5
-rw-r--r--src/Web/VKHS.hs19
-rw-r--r--src/Web/VKHS/API/Base.hs35
-rw-r--r--src/Web/VKHS/API/Simple.hs20
-rw-r--r--src/Web/VKHS/API/Types.hs17
-rw-r--r--src/Web/VKHS/Client.hs5
-rw-r--r--src/Web/VKHS/Imports.hs2
-rw-r--r--src/Web/VKHS/Monad.hs10
-rw-r--r--src/Web/VKHS/Types.hs20
9 files changed, 105 insertions, 28 deletions
diff --git a/VKHS.cabal b/VKHS.cabal
index e04c94b..4c63266 100644
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -1,6 +1,6 @@
name: VKHS
-version: 1.8.1
+version: 1.8.2
synopsis: Provides access to Vkontakte social network via public API
description:
Provides access to Vkontakte API methods. Library requires no interaction
@@ -64,7 +64,8 @@ library
vector,
filepath,
directory,
- pretty-show
+ pretty-show,
+ scientific
executable vkq
hs-source-dirs: app/vkq, app/common, src
diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs
index 91fc5f0..8648341 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -12,9 +12,7 @@ module Web.VKHS (
, module Web.VKHS.Error
, module Web.VKHS.Monad
, module Web.VKHS.Login
- , module Web.VKHS.API.Base
- , module Web.VKHS.API.Types
- , module Web.VKHS.API.Simple
+ , module Web.VKHS.API
) where
import Data.Time
@@ -33,16 +31,14 @@ import qualified Data.Text as Text
import Web.VKHS.Imports
import Web.VKHS.Error
import Web.VKHS.Types
-import Web.VKHS.Client hiding (Error, Response)
+import Web.VKHS.Client hiding (Error, Response, defaultState)
import qualified Web.VKHS.Client as Client
import Web.VKHS.Monad hiding (catch)
import qualified Web.VKHS.Monad as VKHS
import Web.VKHS.Login (MonadLogin, LoginState(..), ToLoginState(..), printForm, login)
import qualified Web.VKHS.Login as Login
-import Web.VKHS.API.Base (MonadAPI, APIState(..), ToAPIState(..), api, modifyAccessToken)
-import qualified Web.VKHS.API.Base as API
-import Web.VKHS.API.Types
-import Web.VKHS.API.Simple
+import Web.VKHS.API
+import qualified Web.VKHS.API as API
-- | Main state of the VK monad stack. Consists of lesser states plus a copy of
-- generic options provided by the caller.
@@ -145,12 +141,15 @@ defaultSuperviser = go where
Right (Response _ ErrorRecord{..}) -> do
case er_code of
- 5 -> do
+ NotLoggedIn -> do
alert $ "Attempting to re-login"
at <- defaultSuperviser (login >>= return . Fine)
modifyAccessToken at
go (k $ ReExec m args)
- ec -> do
+ TooManyRequestsPerSec -> do
+ alert $ "Too many requests per second, consider changing options"
+ go (k $ ReExec m args)
+ ErrorCode ec -> do
alert $ "Unknown error code " <> tshow ec
lift $ throwError res_desc
diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs
index 4cb6e3e..5f40d40 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -153,6 +153,41 @@ apiR m0 args0 = go (ReExec m0 args0) where
recovery <- raise (CallFailure (m0, args0, j, e))
go recovery
+-- | Invoke the request, in case of failure, escalate the probelm to the
+-- superwiser. The superwiser has a chance to change the arguments
+apiHM :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
+ => MethodName -- ^ API method name
+ -> MethodArgs -- ^ API method arguments
+ -> (ErrorRecord -> API m x (Maybe a))
+ -> API m x a
+apiHM m0 args0 handler = go (ReExec m0 args0) where
+ go action = do
+ j <- do
+ case action of
+ ReExec m args -> do
+ apiJ m args
+ ReParse j -> do
+ pure j
+ case (parseJSON j, parseJSON j) of
+ (Right (Response _ a), _) -> return a
+ (Left e, Right (Response _ err)) -> do
+ ma <- (handler err)
+ case ma of
+ Just a -> return a
+ 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
+
+apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
+ => MethodName -- ^ API method name
+ -> MethodArgs -- ^ API method arguments
+ -> (ErrorRecord -> Maybe a)
+ -> API m x a
+apiH m args handler = apiHM m args (\e -> pure (handler e) :: API m x (Maybe a))
+
-- | Invoke the request, return answer as a Haskell datatype or @ErrorRecord@
-- object
apiE :: (Aeson.FromJSON a, MonadAPI m x s)
diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs
index bb5ae30..faa7762 100644
--- a/src/Web/VKHS/API/Simple.hs
+++ b/src/Web/VKHS/API/Simple.hs
@@ -30,6 +30,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Web.VKHS.API.Simple where
import Prelude()
@@ -50,15 +51,23 @@ max_count = 1000
ver = "5.44"
apiSimple nm args = resp_data <$> 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)
groupSearch :: (MonadAPI m x s) => Text -> API m x (Sized [GroupRecord])
groupSearch q =
fmap (sortBy (compare `on` gr_members_count)) <$> do
- apiSimple "groups.search" $
+ apiSimpleH "groups.search"
[("q",q),
("fields", "can_post,members_count"),
("count", tpack (show max_count))]
+ (\ErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> (Just $ Sized 0 [])
+ _ -> Nothing
+ )
+
getCountries :: (MonadAPI m x s) => API m x (Sized [Country])
getCountries =
@@ -78,12 +87,17 @@ getCities Country{..} mq =
] ++
maybe [] (\q -> [("q",q)]) mq
-getGroupWall :: (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord])
+getGroupWall :: forall m x s . (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord])
getGroupWall GroupRecord{..} =
- apiSimple "wall.get" $
+ apiSimpleHM "wall.get"
[("owner_id", "-" <> tshow gr_id),
("count", "100")
]
+ (\ErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> return (Just $ Sized 0 [])
+ _ -> return Nothing
+ :: API m x (Maybe (Sized [WallRecord])))
-- TODO: Take User as argument for more type-safety
getAlbums :: (MonadAPI m x s) => Maybe Integer -> API m x (Sized [Album])
diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs
index d91b89d..e2e3573 100644
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -2,6 +2,7 @@
--
-- See [VK development docs](https://vk.com/dev) for the details
--
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
@@ -97,9 +98,23 @@ instance FromJSON UserRecord where
<*> (o .:? "deactivated")
<*> (o .:? "hidden")
+data ErrorCode =
+ AccessDenied
+ | NotLoggedIn
+ | TooManyRequestsPerSec
+ | ErrorCode Scientific
+ deriving(Show,Read, Eq, Ord)
+
+instance FromJSON ErrorCode where
+ parseJSON = Aeson.withScientific "ErrorCode" $ \n ->
+ case n of
+ 5 -> return NotLoggedIn
+ 6 -> return TooManyRequestsPerSec
+ 15 -> return AccessDenied
+ x -> return (ErrorCode x)
data ErrorRecord = ErrorRecord
- { er_code :: Int
+ { er_code :: ErrorCode
, er_msg :: Text
} deriving(Show)
diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs
index 01e70e2..6603eb4 100644
--- a/src/Web/VKHS/Client.hs
+++ b/src/Web/VKHS/Client.hs
@@ -11,6 +11,7 @@ import Data.List
import Data.Maybe
import Data.Time
import Data.Either
+import Data.Monoid((<>))
import Control.Applicative
import Control.Arrow ((&&&),(***))
import Control.Monad
@@ -66,6 +67,7 @@ data ClientState = ClientState {
cl_man :: Client.Manager
, cl_last_execute :: TimeSpec
, cl_minimum_interval_ns :: Integer
+ , cl_verbose :: Bool
}
defaultState :: GenericOptions -> IO ClientState
@@ -77,6 +79,7 @@ defaultState GenericOptions{..} = do
False -> Client.defaultManagerSettings))
cl_last_execute <- pure (TimeSpec 0 0)
cl_minimum_interval_ns <- pure (round (10^9 / o_max_request_rate_per_sec))
+ cl_verbose <- pure o_verbose
return ClientState{..}
class ToClientState s where
@@ -265,6 +268,8 @@ requestExecute Request{..} = do
clk <- Clock.getTime Clock.Realtime
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"
threadDelay (fromInteger $ (cl_minimum_interval_ns - interval_ns) `div` 1000); -- convert ns to us
return clk
diff --git a/src/Web/VKHS/Imports.hs b/src/Web/VKHS/Imports.hs
index c7899f3..0393ec2 100644
--- a/src/Web/VKHS/Imports.hs
+++ b/src/Web/VKHS/Imports.hs
@@ -20,6 +20,7 @@ module Web.VKHS.Imports (
, module Data.Maybe
, module Data.Typeable
, module Data.Data
+ , module Data.Scientific
, module Text.Printf
, module Prelude
, module Text.Show.Pretty
@@ -38,6 +39,7 @@ import Data.Data
import Data.Char
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Lazy (fromStrict,toChunks)
+import Data.Scientific (Scientific, FPFormat(..))
import Data.Either
import Data.Maybe
import Data.Monoid((<>))
diff --git a/src/Web/VKHS/Monad.hs b/src/Web/VKHS/Monad.hs
index f355b02..10d10ad 100644
--- a/src/Web/VKHS/Monad.hs
+++ b/src/Web/VKHS/Monad.hs
@@ -82,16 +82,6 @@ instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Erro
(Right u) -> return u
(Left e) -> raise (\k -> UnexpectedURL e k)
-debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
-debug str = do
- GenericOptions{..} <- gets toGenericOptions
- when o_verbose $ do
- liftIO $ Text.hPutStrLn stderr str
-
-alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
-alert str = do
- liftIO $ Text.hPutStrLn stderr str
-
getGenericOptions :: (MonadState s m, ToGenericOptions s) => m GenericOptions
getGenericOptions = gets toGenericOptions
diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs
index a4ec907..0e578f6 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RecordWildCards #-}
module Web.VKHS.Types where
import Data.List
@@ -10,6 +11,7 @@ import Data.Data
import Data.Typeable
import Data.Text(Text)
+import qualified Data.Text.IO as Text
import qualified Data.Text as Text
import Data.ByteString.Char8 (ByteString)
@@ -21,6 +23,10 @@ import qualified Data.Aeson.Types as Aeson
import qualified Network.Shpider.Forms as Shpider
+import Control.Monad.State (MonadState(..), gets)
+import Web.VKHS.Imports
+import System.IO (stderr)
+
-- | AccessToken is a authentication data, required by all VK API
-- functions. It is a tuple of access_token, user_id, expires_in fields,
@@ -141,14 +147,14 @@ defaultOptions = GenericOptions {
, o_port = 443
, o_verbose = False
, o_use_https = True
- , o_max_request_rate_per_sec = 3
+ , o_max_request_rate_per_sec = 2
, o_allow_interactive = True
, l_appid = AppID "3128877"
, l_username = ""
, l_password = ""
, l_access_token = ""
- , l_access_token_file = ""
+ , l_access_token_file = ".vkhs-access-token"
}
class ToGenericOptions s where
@@ -157,6 +163,16 @@ class ToGenericOptions s where
data Verbosity = Normal | Trace | Debug
deriving(Enum,Eq,Ord,Show)
+debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
+debug str = do
+ GenericOptions{..} <- gets toGenericOptions
+ when o_verbose $ do
+ liftIO $ Text.hPutStrLn stderr str
+
+alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
+alert str = do
+ liftIO $ Text.hPutStrLn stderr str
+
data MusicOptions = MusicOptions {
m_list_music :: Bool