diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ========= diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -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 diff --git a/app/vkq/Main.hs b/app/vkq/Main.hs --- a/app/vkq/Main.hs +++ b/app/vkq/Main.hs @@ -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" diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs --- a/src/Web/VKHS.hs +++ b/src/Web/VKHS.hs @@ -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' 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 @@ -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 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 @@ -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 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 @@ -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 +