VKHS 1.8.1 → 1.8.2

raw patch · 9 files changed

+105/−28 lines, 9 filesdep +scientificPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: scientific

API changes (from Hackage documentation)

Files

• VKHS.cabal +3/−2
• src/Web/VKHS.hs +9/−10
• src/Web/VKHS/API/Base.hs +35/−0
• src/Web/VKHS/API/Simple.hs +17/−3
• src/Web/VKHS/API/Types.hs +16/−1
• src/Web/VKHS/Client.hs +5/−0
• src/Web/VKHS/Imports.hs +2/−0
• src/Web/VKHS/Monad.hs +0/−10
• src/Web/VKHS/Types.hs +18/−2

@@ -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 @@                      vector,                      filepath,                      directory,-                     pretty-show+                     pretty-show,+                     scientific  executable vkq   hs-source-dirs:    app/vkq, app/common, src

@@ -12,9 +12,7 @@   , 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 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 @@            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 

@@ -153,6 +153,41 @@         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)

@@ -30,6 +30,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Web.VKHS.API.Simple where  import Prelude()@@ -50,16 +51,24 @@ 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 =   fmap (sortBy (compare `on` co_title)) <$> do@@ -78,12 +87,17 @@     ] ++     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])

@@ -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 @@       <*> (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) 

@@ -11,6 +11,7 @@ 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 @@     cl_man :: Client.Manager   , cl_last_execute :: TimeSpec   , cl_minimum_interval_ns :: Integer+  , cl_verbose :: Bool   }  defaultState :: GenericOptions -> IO ClientState@@ -77,6 +79,7 @@                   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 @@     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 

@@ -20,6 +20,7 @@   , 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.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((<>))

@@ -82,16 +82,6 @@       (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 

@@ -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.Typeable  import Data.Text(Text)+import qualified Data.Text.IO as Text import qualified Data.Text as Text  import Data.ByteString.Char8 (ByteString)@@ -21,7 +23,11 @@  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, -- returned by login procedure.@@ -141,14 +147,14 @@   , 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@@ -156,6 +162,16 @@  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 {