VKHS 1.8.4 → 1.9

raw patch · 8 files changed

+182/−126 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−7
• README.md +70/−38
• VKHS.cabal +1/−1
• app/vkq/Main.hs +42/−46
• src/Web/VKHS.hs +12/−5
• src/Web/VKHS/API/Base.hs +17/−3
• src/Web/VKHS/API/Simple.hs +22/−22
• src/Web/VKHS/Imports.hs +7/−4

@@ -1,13 +1,17 @@-TODO------* Decrypt 'RepeatedForm' errors-* Show capchas to users if required-* Re-implement VK monad as a Free monad special case-* Runhaskell: handle some standard command line arguments-* Support storing access-tokens in a temp file+Version 1.9+----------- +* Disable Audio API due to upstream changes+* Handle re-login conditions+* Handle too-many-requests condition+* Stop re-exporting `Prelude`, `Imports` provides aliases for popular+  `Data.Text` functions+* Cache access token in file+* Minor fixes+ Version 1.7.2 -------------+ * Initial support for runhaskell mode  Version 1.7.1

@@ -8,7 +8,7 @@ (disabled by VK) or retrieve wall messages.  Features-========+--------  * Provides access to VK API. Interface options include: VK monad and `vkq` command   line tool.@@ -20,15 +20,20 @@   copied into `runhaskell` scripts and tweaked according to ones need. * No more dependencies on curlhs/taglib. -Issues-======+ToDo+---- +* ~~Decrypt 'RepeatedForm' errors~~+* ~~Support storing access-tokens in a temp file~~ * Still no support for captchas, one probably should hack `defaultSupervisor`   and add them.-* Network connection timeout is not handled by the coroutine supervisor.+* Re-implement VK monad as a Free monad special case+* Runhaskell: handle some standard command line arguments * Minor issues here and there. Use `git grep FIXME` to find them * File uploading still not functioning.-* Lots grammatical mistakes. Any corrections will be kindly accepted.+* Network connection timeout is not handled by the coroutine supervisor.+* Enhance the way `vkq` accepts arguments, support multy-line messages.+* Grammatical mistakes. Any corrections will be kindly accepted.  Installing ==========@@ -90,8 +95,7 @@  `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.-+`vkq command --help` to read online help.  Logging in to VK ----------------@@ -107,58 +111,85 @@     d8a41221616ef5ba19537125dc0349bad9d529fa15314ad765911726fe98b15185ac41a7ca2c62f3bf4b9     $ export VKQ_ACCESS_TOKEN=d785932b871f096bd73aac6a35d7a7c469dd788d796463a871e5beb5c61bc6c96788ec2 -Alternatively, using `--eval` option+Alternatively, result may be achieved using `--eval` option      $ eval `vkq login user@mail.org pass123 --eval`  #### Saving access token to file -    $ vkq login --access-token-file=.access-token+VKQ will cache the access token into a file. Newer versions of VKHS have+`--access-token-flag` option enabled by default. Set it to empty value to+disable the caching. -VKQ will ask for email/password and cache the access token into a file.  Newer-versions of VKHS have `--access-token-flag` option enabled by default. Set it-to empty value to disable the caching feature. +Performing API calls+-------------------- -Performing custom API calls----------------------------+`vkq` allows user to call arbitrary API method. The generic interface is as follows: -vkq allows user to call arbitrary API method. The format is as follows:+    $ vkq api --help+    Usage: vkq api [--verbose] [--req-per-sec N] [--interactive] [--appid APPID]+                   [--user USER] [--pass PASS] [-a ACCESS_TOKEN]+                   [--access-token-file FILE] METHOD PARAMS [--pretty]+      Call VK API method -    Usage: vkq call [--verbose] [--req-per-sec N] [--interactive] [--appid APPID]-                    [--user USER] [--pass PASS] [-a ACCESS_TOKEN] METHOD PARAMS+    Available options:+      --verbose                Be verbose+      --req-per-sec N          Max number of requests per second+      --interactive            Allow interactive queries+      --appid APPID            Application ID, defaults to VKHS+      --user USER              User name or email+      --pass PASS              User password+      -a ACCESS_TOKEN          Access token. Honores VKQ_ACCESS_TOKEN environment+                               variable+      --access-token-file FILE Filename to store actual access token, should be used+                               to pass its value between sessions+      METHOD                   Method name+      PARAMS                   Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]+      --pretty                 Pretty print resulting JSON+      -h,--help                Show this help text  -For example, lets call ausio.search method to get some Beatles records:+The session may look like the following: -    $ vkq call group.search q=Beatles --pretty+    $ vkq api "messages.send" "user_id=111111,message=\"test\""  --pretty+    bd7da7e9cfb4cc12c0a49093173ca8785c7d6c918f00edb7315bb8526f5f372f1174b643e50e1a47d35da -      { "response": [-        614751,-        {-            "lyrics_id": "6604412",-            "url": "http://cs1-36v4.vk-cdn.net/p16/59674dd8717db2.mp3?extra=k0s2ja3l6pq6aIDOEW5y5XUCs2--JLX9wZpzOT3iuSnZPR-DNhJSF075NUhICB_szMOKKlVJFFlqLlg691q6cKhwiGZgTRU1oAimXzXY396cfNAHnotc8--7w-0xnvoPK6qVoI8",-            "aid": 85031440,-            "title": "Twist and Shout  ",-            "genre": 1,-            "owner_id": 9559206,-            "duration": 156,-            "artist": "The Beatles"-        },-    ...+    $ vkq api "users.get" ""+    {"response":[{"first_name":"Сергей","uid":222222,"last_name":"Миронов"}]} +    $ vkq api "messages.send" "user_id=333333,message=Hi theree!"+    {"response":57505} +    $ vkq api "groups.search" "q=Haskell"+		$ vkq api "groups.search" "q=Haskell" --pretty+    {+        "response": [+            30,+            {+                "screen_name": "ml_mat_asm",+                "photo": "https://pp.userapi.com/c638217/v638217626/54113/v5Ib71-dDzo.jpg",+                "is_closed": 0,+                "photo_medium": "https://pp.userapi.com/c638217/v638217626/54112/Nu_si987vOc.jpg",+                "name": "Matlab | Assembler | MathCAD | Haskell | Prolog",+                "photo_big": "https://pp.userapi.com/c638217/v638217626/54111/HGnUbgUorVU.jpg",+                "gid": 78651325,+                "is_admin": 0,+                "is_member": 0,+                "type": "page"+            },+            ...+    }+ VKHS library/runhaskell mode ============================ -Starting from 1.7.2 the library supports RunHaskell-mode. Consider the-following example:+Starting from 1.7.2 the library supports runhaskell-mode.       #!/usr/bin/env runhaskell     {-# LANGUAGE RecordWildCards #-} -    import Prelude ()     import Web.VKHS     import Web.VKHS.Imports @@ -166,12 +197,13 @@     main = runVK_ defaultOptions $ do       Sized cnt cs <- getCountries       forM_ cs $ \Country{..} -> do-        liftIO $ putStrLn co_title+        liftIO $ tputStrLn co_title  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.+`Web.VKHS.API.Simple`.++The distribuption contains `./app/runhaskell` folder with a couple of examples.  Debugging =========

@@ -1,6 +1,6 @@  name:                VKHS-version:             1.8.4+version:             1.9 synopsis:            Provides access to Vkontakte social network via public API description:     Provides access to Vkontakte API methods. Library requires no interaction

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -49,20 +50,21 @@   } deriving(Show)  data Options-  = Login GenericOptions LoginOptions-  | API GenericOptions APIOptions-  | Music GenericOptions MusicOptions-  | UserQ GenericOptions UserOptions-  | WallQ GenericOptions WallOptions-  | GroupQ GenericOptions GroupOptions-  | DBQ GenericOptions DBOptions-  | Photo GenericOptions PhotoOptions+  = Login { genOpts :: GenericOptions, loginOpts :: LoginOptions }+  | API { genOpts :: GenericOptions, apiOpts :: APIOptions }+  | Music { genOpts :: GenericOptions, musicOpts :: MusicOptions }+  | UserQ { genOpts :: GenericOptions, userOpts :: UserOptions }+  | WallQ { genOpts :: GenericOptions, wallOpts :: WallOptions }+  | GroupQ { genOpts :: GenericOptions, groupOpts :: GroupOptions }+  | DBQ { genOpts :: GenericOptions, dbOpts :: DBOptions }+  | Photo { genOpts :: GenericOptions, photoOpts :: PhotoOptions }   deriving(Show)  toMaybe :: (Functor f) => f String -> f (Maybe String) toMaybe = fmap (\s -> if s == "" then Nothing else Just s) -opts m =+-- FIXME support --version flag+optdesc m =   let        -- genericOptions_ :: Parser GenericOptions@@ -80,7 +82,7 @@         <*> ppass         <*> strOption (short 'a' <> m <> metavar "ACCESS_TOKEN" <>               help ("Access token. Honores " ++ env_access_token ++ " environment variable"))-        <*> strOption (long "access-token-file" <> value "" <> metavar "FILE" <>+        <*> strOption (long "access-token-file" <> value (l_access_token_file defaultOptions) <> metavar "FILE" <>               help ("Filename to store actual access token, should be used to pass its value between sessions"))        genericOptions = genericOptions_@@ -165,8 +167,8 @@ main :: IO () main = ( do   m <- maybe (value "") (value) <$> lookupEnv env_access_token-  o <- execParser (info (helper <*> opts m) (fullDesc <> header "VKontakte social network tool"))-  r <- runExceptT (cmd o)+  o <- execParser (info (helper <*> optdesc m) (fullDesc <> header "VKontakte social network tool"))+  r <- runVK (genOpts o) (cmd o)   case r of     Left err -> do       hPutStrLn stderr err@@ -187,25 +189,25 @@   -} -cmd :: Options -> ExceptT Text IO ()+cmd :: (MonadLogin (m (R m x)) (R m x) s, MonadAPI m x s) => Options -> m (R m x) ()  -- Login cmd (Login go LoginOptions{..}) = do-  AccessToken{..} <- runLogin go+  at@AccessToken{..} <- login   case l_eval of     True -> liftIO $ putStrLn $ Text.pack $ printf "export %s=%s\n" env_access_token at_access_token-    False -> liftIO $ putStrLn $ Text.pack at_access_token+    False -> do+      modifyAccessToken at+      liftIO $ putStrLn $ Text.pack at_access_token  -- API / CALL cmd (API go APIOptions{..}) = do-  runAPI go $ do-    x <- apiJ a_method (map (id *** tpack) $ splitFragments "," "=" a_args)-    if a_pretty-      then do-        liftIO $ putStrLn $ jsonEncodePretty x-      else-        liftIO $ putStrLn $ jsonEncode x-  return ()+  x <- apiJ a_method (map (id *** tpack) $ splitFragments "," "=" a_args)+  if a_pretty+    then do+      liftIO $ putStrLn $ jsonEncodePretty x+    else+      liftIO $ putStrLn $ jsonEncode x  cmd (Music go@GenericOptions{..} mo@MusicOptions{..}) = do   error "VK disabled audio API since 2016/11."@@ -215,23 +217,19 @@    |not (null g_search_string) = do -    runAPI go $ do--      (Sized cnt grs) <- groupSearch (tpack g_search_string)+    (Sized cnt grs) <- groupSearch (tpack g_search_string) -      forM_ grs $ \gr -> do-        liftIO $ printf "%s\n" (gr_format g_output_format gr)+    forM_ grs $ \gr -> do+      liftIO $ printf "%s\n" (gr_format g_output_format gr)  cmd (DBQ go (DBOptions{..}))    |db_countries = do -    runAPI go $ do--      (Sized cnt cs) <- getCountries+    (Sized cnt cs) <- getCountries -      forM_ cs $ \Country{..} -> do-        liftIO $ Text.putStrLn $ Text.concat [ tshow co_int, "\t",  co_title]+    forM_ cs $ \Country{..} -> do+      liftIO $ Text.putStrLn $ Text.concat [ tshow co_int, "\t",  co_title]    |db_cities = do     error "not implemented"@@ -239,21 +237,19 @@ cmd (Photo go PhotoOptions{..})    |p_listAlbums = do-    runAPI go $ do-      (Sized cnt als) <- getAlbums Nothing-      forM_ als $ \Album{..} -> do-        liftIO $ Text.putStrLn $ Text.concat [ tshow al_id, "\t",  al_title]+    (Sized cnt als) <- getAlbums Nothing+    forM_ als $ \Album{..} -> do+      liftIO $ Text.putStrLn $ Text.concat [ tshow al_id, "\t",  al_title]    |p_uploadServer = do-    runAPI go $ do-      (Sized cnt als) <- getAlbums Nothing-      let album = [a | a <- als, al_id a == -7]-      case album of-        [a] -> do-          PhotoUploadServer{..} <- getPhotoUploadServer a-          liftIO $ Text.putStrLn pus_upload_url-        _ ->-          error "Ivalid album"+    (Sized cnt als) <- getAlbums Nothing+    let album = [a | a <- als, al_id a == -7]+    case album of+      [a] -> do+        PhotoUploadServer{..} <- getPhotoUploadServer a+        liftIO $ Text.putStrLn pus_upload_url+      _ ->+        error "Ivalid album"    |otherwise = do     error "invalid command line arguments"

@@ -156,6 +156,14 @@                       <> "high-level wrappers `apiSimpleH` / `apiSimpleHM`"                 lift $ throwError res_desc +      RepeatedForm Form{..} k -> do+        alert  $ "Failed to complete login procedure. Last seen form is\n"+              <> "\n"+              <> printForm "\t" form+              <> "\n"+              <> "You may try to obtain more details by setting --verbose flag and/or checking the 'latest.html' file"+        lift $ throwError res_desc+       _ -> do         alert $ "Unsupervised error: " <> res_desc         lift $ throwError res_desc@@ -175,13 +183,12 @@   s <- initialState go   flip evalStateT s $ do -    at <- readInitialAccessToken >>= \case+    readInitialAccessToken >>= \case       Nothing ->-        defaultSupervisor (login >>= return . Fine)-      Just at ->-        pure at+        return ()+      Just at -> do+        modifyAccessToken at -    modifyAccessToken at     defaultSupervisor (m >>= return . Fine)  -- | Run the VK monad @m@ using generic options @go@ and 'defaultSupervisor'

@@ -136,11 +136,12 @@  -- | Invoke the request, in case of failure, escalate the probelm to the -- supervisor. The superwiser has a chance to change the arguments-apiR :: (Aeson.FromJSON a, MonadAPI m x s)+apiRf :: (Aeson.FromJSON b, MonadAPI m x s)     => MethodName -- ^ API method name     -> MethodArgs -- ^ API method arguments+    -> (b -> Either String a)     -> API m x a-apiR m0 args0 = go (ReExec m0 args0) where+apiRf m0 args0 flt = go (ReExec m0 args0) where   go action = do     j <- do       case action of@@ -149,10 +150,23 @@         ReParse j -> do           pure j     case parseJSON j of-      (Right (Response _ a)) -> return a+      (Right (Response _ b)) -> do+        case flt b of+          Right a -> return a+          Left e -> do+            recovery <- raise (CallFailure (m0, args0, j, e))+            go recovery       (Left e) -> do         recovery <- raise (CallFailure (m0, args0, j, e))         go recovery++-- | Invoke the request, in case of failure, escalate the probelm to the+-- supervisor. The superwiser has a chance to change the arguments+apiR :: (Aeson.FromJSON a, MonadAPI m x s)+    => MethodName -- ^ API method name+    -> MethodArgs -- ^ API method arguments+    -> API m x a+apiR m0 args0 = apiRf m0 args0 Right  -- | Invoke the request, in case of failure, escalate the probelm to the -- supervisor. The superwiser has a chance to change the arguments

@@ -8,21 +8,20 @@ --     #!/usr/bin/env runhaskell --     {-# LANGUAGE RecordWildCards #-} --     {-# LANGUAGE OverloadedStrings #-}----     import Prelude ()+-- --     import Web.VKHS --     import Web.VKHS.Imports-+-- --     main :: IO () --     main = runVK_ defaultOptions $ do --       Sized cnt gs <- groupSearch "Котики" --       forM_ gs $ \gr@GroupRecord{..} -> do---         liftIO $ putStrLn gr_name---         liftIO $ putStrLn "--------------"+--         liftIO $ tputStrLn gr_name+--         liftIO $ tputStrLn "--------------" --         Sized wc ws <- getGroupWall gr --         forM_ ws $ \WallRecord{..} -> do---           liftIO $ putStrLn wr_text---           liftIO $ putStrLn "--------------"+--           liftIO $ tputStrLn wr_text+--           liftIO $ tputStrLn "--------------" -- @ -- -- See more scripts under @./app/runhaskell@ folder@@ -33,7 +32,6 @@ {-# LANGUAGE ScopedTypeVariables #-} module Web.VKHS.API.Simple where -import Prelude() import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BS import qualified Data.Aeson as Aeson@@ -48,13 +46,17 @@ import Web.VKHS.API.Types  max_count = 1000++-- | We are using API v5.44 by default ver = "5.44" +apiSimpleF nm args f = apiRf nm (("v",ver):args) f 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) +-- | This function demonstrates pure-functional error handling groupSearch :: (MonadAPI m x s) => Text -> API m x (Sized [GroupRecord]) groupSearch q =   fmap (sortBy (compare `on` gr_members_count)) <$> do@@ -68,12 +70,10 @@         _ -> Nothing     ) - getCountries :: (MonadAPI m x s) => API m x (Sized [Country]) getCountries =   fmap (sortBy (compare `on` co_title)) <$> do-  resp_data <$> do-  apiR "database.getCountries" $+  apiSimple "database.getCountries"     [("v",ver),      ("need_all", "1"),      ("count", tpack (show max_count))@@ -88,6 +88,8 @@     maybe [] (\q -> [("q",q)]) mq  -- | See [https://vk.com/dev/wall.get]+--+-- This function demonstrates monadic error handling getGroupWall :: forall m x s . (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord]) getGroupWall GroupRecord{..} =   apiSimpleHM "wall.get"@@ -96,8 +98,10 @@     ]     (\ErrorRecord{..} ->       case er_code of-        AccessDenied -> return (Just $ Sized 0 [])-        _ -> return Nothing+        AccessDenied -> do+          return (Just $ Sized 0 [])+        _ -> do+          return Nothing         :: API m x (Maybe (Sized [WallRecord])))  -- TODO: Take User as argument for more type-safety@@ -113,19 +117,15 @@  getPhotoUploadServer :: (MonadAPI m x s) => Album -> API m x PhotoUploadServer getPhotoUploadServer Album{..} =-  resp_data <$> do-  api "photos.getUploadServer" $-    [("album_id", tshow al_id)-    ]+  apiSimple "photos.getUploadServer" [("album_id", tshow al_id)]   getCurrentUser :: (MonadAPI m x s) => API m x UserRecord getCurrentUser = do-  Response{..} <- apiVer "users.get" []-  users <- pure resp_data-  case (length users == 1) of-    False -> terminate (JSONParseFailure' resp_json "getCurrentUser: expecting single UserRecord")-    True -> return (head users)+  apiSimpleF "users.get" [] $ \users ->+    case (length users == 1) of+      False -> Left "getCurrentUser: array with one user record"+      True -> Right (head users)   -- * FIXME fix setUserPhoto, it is not actually working

@@ -22,7 +22,6 @@   , module Data.Data   , module Data.Scientific   , module Text.Printf-  , module Prelude   , module Text.Show.Pretty   , module Text.Read   ) where@@ -47,9 +46,9 @@ import Data.Text (Text(..), pack, unpack) import Data.Text.IO (putStrLn, hPutStrLn) import Data.List (head, length, sortBy, (++))-import Prelude (error, Integer, FilePath, (==), (.), Show(..), String,-                ($), IO(..), Bool(..), compare, Ordering(..),-                Read(..))+-- import Prelude (error, Integer, FilePath, (==), (.), Show(..), String,+--                 ($), IO(..), Bool(..), compare, Ordering(..),+--                 Read(..), error, undefined) import Text.Printf import Text.Show.Pretty import Text.Read (readMaybe)@@ -61,3 +60,7 @@  tshow :: (Show a) => a -> Text tshow = tpack . show++tputStrLn = Data.Text.IO.putStrLn+thPutStrLn = Data.Text.IO.hPutStrLn+