VKHS 1.7.3 → 1.8
raw patch · 13 files changed
+382/−246 lines, 13 filesdep −taglib
Dependencies removed: taglib
Files
- README.md +67/−43
- VKHS.cabal +1/−2
- app/vkq/Main.hs +12/−91
- src/Web/VKHS.hs +69/−28
- src/Web/VKHS/API/Base.hs +49/−19
- src/Web/VKHS/API/Simple.hs +45/−22
- src/Web/VKHS/API/Types.hs +8/−17
- src/Web/VKHS/Client.hs +4/−3
- src/Web/VKHS/Error.hs +24/−6
- src/Web/VKHS/Imports.hs +48/−3
- src/Web/VKHS/Login.hs +1/−0
- src/Web/VKHS/Monad.hs +34/−1
- src/Web/VKHS/Types.hs +20/−11
README.md view
@@ -1,36 +1,83 @@ VKHS ==== -VKHS provides access to [Vkontakte][1] social network, popular mainly in Russia.-Library can be used to login into the network as a standalone application (OAuth-implicit flow as they call it). Having the access token, it is possible to call-various API methods to query audio files or retrieve wall messages. For now,-vkhs offers limited error detection and no captcha support.+VKHS provides access to [Vkontakte](http://vk.com) social network, popular+mainly in Russia. Library can be used to login into the network as a standalone+application (OAuth implicit flow as they call it). Having the access token, it+is possible to call various API methods to query audio files or retrieve wall+messages. For now, vkhs offers limited error detection and no captcha support. +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.+ Installing ========== -In order to install VKHS, type:+Installing from Cabal+--------------------- +In order to install VKHS, one typically should do the following+ $ cabal update $ cabal install VKHS Note, that VKHS uses curlhs and should be linked with libcurl.so. Normally, cabal handles it without problems. -VKQ-=== +Installing from source+----------------------++ $ git clone https://github.com/grwlf/vkhs+ $ cd vkhs+ $ cabal install++Developing using Nix+--------------------++We use [Nix](http://nixos.org) as a main development platform. In order to open+development environment, do the following:++ $ git clone https://github.com/grwlf/vkhs+ $ cd vkhs+ $ nix-shell+ $ ...+ $ ghci -isrc:app/vkq:app/common+ $ cabal build++Building ctags file+-------------------++./mktags.sh script may be used to build ctags file. It used `haskdogs` tool,+which should be installed from Hackage.++ $ haskdogs++++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. -Log in-------+Log in to VK+------------ Here is an example session: Login first - ]$ vkq login user@mail.org pass123+ $ vkq login user@mail.org pass123 d8a41221616ef5ba19537125dc0349bad9d529fa15314ad765911726fe98b15185ac41a7ca2c62f3bf4b9 VKQ returns three values. First is a access token which is required to execute@@ -39,38 +86,17 @@ $ export VKQ_ACCESS_TOKEN=d785932b871f096bd73aac6a35d7a7c469dd788d796463a871e5beb5c61bc6c96788ec2 -Download audio---------------+VKQ may save the access tokein into state file: -Now, lets list first 10 audio files I have:+ $ vkq login --access-token-file=.access-token - $ vkq music -l | head -n 10- 910727_456939044 http://cs1-29v4.vk-cdn.net/p36/d36d0fac4baf0d.mp3 Алёнушка 1989 муз Никиты Богословского - ст Александра Коваленкова- 910727_456939043 http://cs1-35v4.vk-cdn.net/p7/2629cc1c9e82d7.mp3 Первое апреля- 910727_456939042 http://cs5078.vk.me/u39450508/audios/b65093a7caea.mp3 Травы травы травы не успели от росы серебрянной согнуться и такие нежные напевы почему-то прямо в сердце льются- 910727_456939041 http://cs1-35v4.vk-cdn.net/p12/423bca91340edc.mp3 Moving On- 910727_456939038 http://cs1-37v4.vk-cdn.net/p5/23c658ff1d9a43.mp3 Не для меня придёт весна- 910727_456939037 http://cs1-17v4.vk-cdn.net/p4/e67571789b026e.mp3 Каждый выбирает для себя- 910727_456939034 http://cs536114.vk.me/u262757964/audios/8b0e36ee4ad5.mp3 Black Fortress Kings Bounty Dark Side OST- 910727_456939031 http://cs613118.vk.me/u911727/audios/7bd0a650905e.mp3 Вокализ минус пример- 910727_456939040 http://cs611628.vk.me/u911727/audios/d5a8eff365aa.mp3 Без названия- 910727_456939028 http://cs536217.vk.me/u64604046/audios/a4ab2075af94.mp3 The Extasy of Gold+ .. VKQ will ask for email/password and cache the access token -Ok, the link can be used to download the file using wget, but vkq offers-some renaming options, so lets use the latter instead:+ $ vkq call groups.search q=Beatles --pretty --access-token-file=.access-token - $ vkq music -o . 910727_456939043 910727_456939031- 910727_456939043- Polite Dance Song- ./The Bird And The Bee - Polite Dance Song.mp3- 910727_456939031- L'estasi Dell'oro (The Ecstasy Of Gold)- ./Ennio Morricone - Lestasi Delloro The Ecstasy Of Gold.mp3 -Polite dance song and Ecstasy of gold mp3s will appear in the current folder.--Custom API calls-----------------+Performing custom API calls+--------------------------- vkq allows user to call arbitrary API method. The format is as follows: @@ -97,7 +123,7 @@ ... -VKHS library/Runhaskell mode+VKHS library/runhaskell mode ============================ Starting from 1.7.2 there are initial support for RunHaskell-mode. Consider the@@ -129,8 +155,8 @@ data, but the form appears again. Typically, that means that the password wa invalid or captcha is required. -Limitations-===========+References+========== * Implicit-flow authentication, see [documentation in Russian](http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений) for details@@ -142,6 +168,4 @@ BSD3 license Copyright (c) 2014, Sergey Mironov <grrwlf@gmail.com>--[1]: http://vk.com
VKHS.cabal view
@@ -1,6 +1,6 @@ name: VKHS-version: 1.7.3+version: 1.8 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction@@ -64,7 +64,6 @@ vector, filepath, directory,- taglib, pretty-show executable vkq
app/vkq/Main.hs view
@@ -4,31 +4,19 @@ module Main where -import Control.Exception (SomeException(..),catch,bracket)-import Control.Monad+import Prelude hiding(putStrLn) import Control.Monad.Except-import Control.Monad.Trans-import Control.Arrow ((***))-import Data.Maybe-import Data.List-import Data.Char-import Data.Text(Text(..),pack, unpack)-import qualified Data.Text as Text-import Data.Text.IO(putStrLn, hPutStrLn)-import qualified Data.Text.IO as Text-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as BS-import Data.Monoid((<>))-import Options.Applicative-import qualified Sound.TagLib as TagLib import System.Environment import System.Exit import System.IO(stderr)+import Options.Applicative import Text.RegexPR-import Text.Printf-import Text.Show.Pretty-import Prelude hiding(putStrLn) +import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import qualified Data.ByteString.Char8 as BS++import Web.VKHS.Imports import Web.VKHS import Web.VKHS.Types import Web.VKHS.Client as Client@@ -39,6 +27,7 @@ env_access_token = "VKQ_ACCESS_TOKEN" +-- | Options to query VK database data DBOptions = DBOptions { db_countries :: Bool , db_cities :: Bool@@ -91,6 +80,8 @@ <*> 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" <>+ help ("Filename to store actual access token, should be used to pass its value between sessions")) genericOptions = genericOptions_ (strOption (value "" <> long "user" <> metavar "USER" <> help "User name or email"))@@ -216,78 +207,8 @@ liftIO $ BS.putStrLn $ jsonEncode x return () -cmd (Music go@GenericOptions{..} mo@MusicOptions{..})-- -- Query music files- |not (null m_search_string) = do- runAPI go $ do- API.Response _ (SizedList len ms) <- api_S "audio.search" [("q",m_search_string), ("count", "1000")]- forM_ ms $ \m -> do- io $ printf "%s\n" (mr_format m_output_format m)- io $ printf "total %d\n" len-- -- List music files- |m_list_music = do- runAPI go $ do- (API.Response _ (ms :: [MusicRecord])) <- api_S "audio.get" [("q",m_search_string)]- forM_ ms $ \m -> do- io $ printf "%s\n" (mr_format m_name_format m)-- -- Download music files- |not (null m_records_id) = do- let out_dir = fromMaybe "." m_out_dir- runAPI go $ do- forM_ m_records_id $ \ mrid -> do- (API.Response _ (ms :: [MusicRecord])) <- api_S "audio.getById" [("audios", mrid)]- forM_ ms $ \mr@MusicRecord{..} -> do- (f, mh) <- liftIO $ openFileMR mo mr- case mh of- Just h -> do- u <- ensure (pure $ Client.urlFromString mr_url_str)- Client.downloadFileWith u (BS.hPut h)- io $ printf "%d_%d\n" mr_owner_id mr_id- io $ printf "%s\n" mr_title- io $ printf "%s\n" f- liftIO $ do- tagfile <- TagLib.open f- case tagfile of- Just tagfile -> do- tag <- TagLib.tag tagfile- case tag of- Just it -> do- it `TagLib.setArtist` ensureUnicode mr_artist- it `TagLib.setTitle` ensureUnicode mr_title- it `TagLib.setComment` ""- it `TagLib.setAlbum` ""- it `TagLib.setGenre` ""- it `TagLib.setTrack` 0- it `TagLib.setYear` 0- TagLib.save tagfile- return ()- where- ensureUnicode = unpack . pack-- Nothing -> do- io $ hPutStrLn stderr ("File " <> Text.pack f <> " already exist, skipping")- return ()---- Download audio files--- cmd (Options v (Music (MO act False [] _ ofmt odir rid sk))) = do--- let e = (envcall act) { verbose = v }--- Response (ms :: [MusicRecord]) <- api_ e "audio.getById" [("audios", concat $ intersperse "," rid)]--- forM_ ms $ \m -> do--- (fp, mh) <- openFileMR odir sk ofmt m--- case mh of--- Just h -> do--- r <- vk_curl_file e (url m) $ \ bs -> do--- BS.hPut h bs--- checkRight r--- printf "%d_%d\n" (owner_id m) (aid m)--- printf "%s\n" (title m)--- printf "%s\n" fp--- Nothing -> do--- hPutStrLn stderr (printf "File %s already exist, skipping" fp)--- return ()+cmd (Music go@GenericOptions{..} mo@MusicOptions{..}) = do+ error "VK disabled audio API since 2016/11." -- Query groups files cmd (GroupQ go (GroupOptions{..}))
src/Web/VKHS.hs view
@@ -17,25 +17,20 @@ , module Web.VKHS.API.Simple ) where -import Data.List-import Data.Maybe import Data.Time-import Data.Either-import Data.Monoid((<>))-import Data.Text(Text)-import qualified Data.Text as Text import Control.Applicative import Control.Monad import Control.Monad.Except import Control.Monad.State (MonadState, execState, evalStateT, StateT(..), get, modify) import Control.Monad.Cont import Control.Monad.Reader+import Debug.Trace+import System.IO -import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS--import System.IO+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)@@ -44,13 +39,13 @@ 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)+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 Debug.Trace-+-- | Main state of the VK monad stack. Consists of lesser states plus a copy of+-- generic options provided by the caller. data State = State { cs :: ClientState , ls :: LoginState@@ -77,25 +72,37 @@ <*> pure (API.defaultState) <*> pure go ---- Intermediate alias type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a --- | Main VK monad able to track errors, track full state @State@, set--- early exit by the means of continuation monad. See @runVK@+-- | Main VK monad able to track errors, track full state 'State', set+-- early exit by the means of continuation monad. VK encodes a coroutine which+-- has entry points defined by 'Result' datatype.+--+-- See also 'runVK' and 'defaultSuperwiser`.+--+-- * FIXME Re-write using modern 'Monad.Free' newtype VK r a = VK { unVK :: Guts VK (StateT State (ExceptT Text IO)) r a } deriving(MonadIO, Functor, Applicative, Monad, MonadState State, MonadReader (r -> VK r r) , MonadCont) instance MonadClient (VK r) State instance MonadVK (VK r) r instance MonadLogin (VK r) r State--- instance MonadAPI (VK r) r State instance MonadAPI VK r State --- | Run the VK script, return final state and error status+-- | Run the VK coroutine till next return. Consider using 'runVK' for full+-- spinup. stepVK :: VK r r -> StateT State (ExceptT Text IO) r stepVK m = runContT (runReaderT (unVK (VKHS.catch m)) undefined) return +-- | Run VK monad @m@ and handle continuation requests using default+-- algorithm. @defaultSuperwiser@ would relogin on invalid access token+-- condition, ask for missing form fields (typically - an email/password)+--+-- See also 'runVK'+--+-- * FIXME Store known answers in external DB (in file?) instead of LoginState+-- FIXME dictionary+-- * FIXME Handle capthas (offer running standalone apps) defaultSuperviser :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT Text IO) a defaultSuperviser = go where go m = do@@ -103,49 +110,83 @@ res <- stepVK m res_desc <- pure (describeResult res) case res of- Fine a -> return a+ Fine a -> do+ return a+ UnexpectedInt e k -> do alert "UnexpectedInt (ignoring)" go (k 0)+ UnexpectedFormField (Form tit f) i k -> do alert $ "While filling form " <> (printForm "" f) case o_allow_interactive of True -> do v <- do- alert $ "Please, enter the correct value for input " <> tpack i <> " : "+ alert $ "Please, enter the value for input " <> tpack i <> " : " liftIO $ getLine go (k v) False -> do alert $ "Unable to query value for " <> tpack i <> " since interactive mode is disabled" lift $ throwError res_desc+ LogError text k -> do alert text go (k ())++ CallFailure (m, args, j, err) k -> do+ alert $ "Error calling API:\n\n\t" <> tshow m <> " " <> tshow args <> "\n"+ <> "\nResponse object:\n\n\t" <> tpack (ppShow j) <> "\n"+ <> "\nParser error was:" <> tshow err <> "\n"++ case parseJSON j of+ Left err -> do+ alert $ "Failed to parse JSON error object, message: " <> tshow err+ lift $ throwError res_desc++ Right (Response _ ErrorRecord{..}) -> do+ case er_code of+ 5 -> do+ alert $ "Attempting to re-login"+ at <- defaultSuperviser (login >>= return . Fine)+ modifyAccessToken at+ go (k $ ReExec m args)+ ec -> do+ alert $ "Unknown error code " <> tshow ec+ lift $ throwError res_desc+ _ -> do alert $ "Unsupervised error: " <> res_desc lift $ throwError res_desc +-- | Run login procedure using 'defaultSuperwiser'. Return 'AccessToken' on+-- success runLogin :: GenericOptions -> ExceptT Text IO AccessToken runLogin go = do s <- initialState go evalStateT (defaultSuperviser (login >>= return . Fine)) s -+-- | Run the VK monad @m@ using generic options @go@ and 'defaultSuperwiser'.+-- Perform login procedure if needed. This is an mid-layer runner, consider+-- using 'runVK' instead. runAPI :: Show b => GenericOptions -> VK (R VK b) b -> ExceptT Text IO b runAPI go@GenericOptions{..} m = do s <- initialState go flip evalStateT s $ do- case (null l_access_token) of- True -> do- AccessToken{..} <- defaultSuperviser (login >>= return . Fine)- modify $ modifyAPIState (\as -> as{api_access_token = at_access_token})- False -> do- modify $ modifyAPIState (\as -> as{api_access_token = l_access_token})- defaultSuperviser (m >>= return . Fine) + at <- readInitialAccessToken >>= \case+ Nothing ->+ defaultSuperviser (login >>= return . Fine)+ Just at ->+ pure at++ modifyAccessToken at+ defaultSuperviser (m >>= return . Fine)++-- | Run the VK monad @m@ using generic options @go@ and 'defaultSuperwiser' runVK :: Show a => GenericOptions -> VK (R VK a) a -> IO (Either Text a) runVK go = runExceptT . runAPI go +-- | A version of 'runVK' with unit return. runVK_ :: Show a => GenericOptions -> VK (R VK a) a -> IO () runVK_ go = do runVK go >=> \case
src/Web/VKHS/API/Base.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}@@ -9,22 +10,15 @@ module Web.VKHS.API.Base where -import Data.List-import Data.Maybe import Data.Time-import Data.Either-import Control.Arrow ((***),(&&&))-import Control.Category ((>>>)) import Control.Applicative import Control.Monad import Control.Monad.State import Control.Monad.Writer import Control.Monad.Cont+import Control.Exception (catch, SomeException) -import Data.Text(Text) import qualified Data.Text as Text--import Data.ByteString.Char8 (ByteString) import Data.ByteString.Lazy (fromStrict,toChunks) import qualified Data.ByteString.Char8 as BS @@ -34,7 +28,9 @@ import qualified Data.Aeson.Encode.Pretty as Aeson import Text.Printf+import Text.Read (readMaybe) +import Web.VKHS.Imports import Web.VKHS.Types import Web.VKHS.Client hiding (Response(..)) import Web.VKHS.Monad@@ -55,6 +51,19 @@ toAPIState :: s -> APIState modifyAPIState :: (APIState -> APIState) -> (s -> s) +-- | Modifies VK access token in the internal state as well as in the external+-- storage, if enabled.+--+-- See also 'readInitialAccessToken'+modifyAccessToken :: (MonadIO m, MonadState s m, ToAPIState s) => AccessToken -> m ()+modifyAccessToken at@AccessToken{..} = do+ modify $ modifyAPIState (\as -> as{api_access_token = at_access_token})+ GenericOptions{..} <- getGenericOptions+ case l_access_token_file of+ [] -> return ()+ fl -> liftIO $ writeFile l_access_token_file (show at)+ return ()+ -- | Class of monads able to run VK API calls. @m@ - the monad itself, @x@ - -- type of early error, @s@ - type of state (see alse @ToAPIState@) class (MonadIO (m (R m x)), MonadClient (m (R m x)) s, ToAPIState s, MonadVK (m (R m x)) (R m x)) =>@@ -63,10 +72,12 @@ type API m x a = m (R m x) a -- | Utility function to parse JSON object-parseJSON :: (MonadAPI m x s)+--+-- * FIXME Don't raise exception, simply return `Left err`+decodeJSON :: (MonadAPI m x s) => ByteString -> API m x JSON-parseJSON bs = do+decodeJSON bs = do case Aeson.decode (fromStrict bs) of Just js -> return (JSON js) Nothing -> raise (JSONParseFailure bs)@@ -77,9 +88,9 @@ -- <https://vk.com/dev/methods> -- <https://vk.com/dev/json_schema> ----- FIXME: We currentyl use Text.unpack to encode text into strings. Use encodeUtf8--- instead.--- FIXME: Split into request builder and request executer+-- * FIXME We currentyl use Text.unpack to encode text into strings. Use encodeUtf8+-- FIXME instead.+-- * FIXME Split into request builder and request executer apiJ :: (MonadAPI m x s) => String -- ^ API method name@@ -104,7 +115,7 @@ req <- ensure (requestCreateGet url (cookiesCreate ())) (res, jar') <- requestExecute req- parseJSON (responseBody res)+ decodeJSON (responseBody res) -- | Invoke the request, return answer as a Haskell datatype. On error fall out@@ -117,11 +128,30 @@ -- ^ API method arguments -> API m x a api m args = do- j@JSON{..} <- apiJ m args- case Aeson.parseEither Aeson.parseJSON js_aeson of+ j <- apiJ m args+ case parseJSON j of Right a -> return a Left e -> terminate (JSONParseFailure' j e) +-- | Invoke the request, in case of failure, escalate the probelm to the+-- superwiser. 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 = 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 of+ (Right a) -> return a+ (Left e) -> do+ recovery <- raise (CallFailure (m0, args0, j, e))+ go recovery -- | Invoke the request, return answer as a Haskell datatype or @ErrorRecord@ -- object@@ -130,9 +160,9 @@ -> [(String, Text)] -- ^ API method arguments -> API m x (Either (Response ErrorRecord) a) apiE m args = apiJ m args >>= convert where- convert j@JSON{..} = do- err <- pure $ Aeson.parseEither Aeson.parseJSON js_aeson- ans <- pure $ Aeson.parseEither Aeson.parseJSON js_aeson+ convert j = do+ err <- pure $ parseJSON j+ ans <- pure $ parseJSON j case (ans, err) of (Right a, _) -> return (Right a) (Left a, Right e) -> return (Left e)
src/Web/VKHS/API/Simple.hs view
@@ -1,22 +1,47 @@+-- | This module contains definitions of VK various API bindings. I tried to+-- keep it as simple as possible. More, the user is expected to copy any+-- function from this module into their 'runhaskell' script and customize+-- as required.+--+-- Runhaskell script may look like the following:+-- @+-- #!/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 "--------------"+-- Sized wc ws <- getGroupWall gr+-- forM_ ws $ \WallRecord{..} -> do+-- liftIO $ putStrLn wr_text+-- liftIO $ putStrLn "--------------"+-- @+--+-- See more scripts under @./app/runhaskell@ folder+-- {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} module Web.VKHS.API.Simple where -import Control.Monad.Trans (liftIO)-import Data.List-import Data.Text (Text)-import Data.Monoid((<>))+import Prelude() import qualified Data.Text as Text-import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson-import Data.Function++import Web.VKHS.Imports import Web.VKHS.Types import Web.VKHS.Monad import Web.VKHS.Error-import Web.VKHS.Types(tshow) import Web.VKHS.Client(requestUploadPhoto, requestExecute, responseBody, responseBodyS) import Web.VKHS.API.Base import Web.VKHS.API.Types@@ -24,14 +49,13 @@ max_count = 1000 ver = "5.44" -apiSimple def nm args = apiD def nm (("v",ver):args)+apiSimple nm args = resp_data <$> apiR nm (("v",ver):args) 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)) <$>- resp_data <$> do- apiSimple emptyResponse "groups.search" $+ fmap (sortBy (compare `on` gr_members_count)) <$> do+ apiSimple "groups.search" $ [("q",q), ("fields", "can_post,members_count"), ("count", tpack (show max_count))]@@ -40,15 +64,15 @@ getCountries = fmap (sortBy (compare `on` co_title)) <$> do resp_data <$> do- apiSimple emptyResponse "database.getCountries" $- [("need_all", "1"),+ apiR "database.getCountries" $+ [("v",ver),+ ("need_all", "1"), ("count", tpack (show max_count)) ] getCities :: (MonadAPI m x s) => Country -> Maybe Text -> API m x (Sized [City]) getCities Country{..} mq =- resp_data <$> do- apiSimple emptyResponse "database.getCities" $+ apiSimple "database.getCities" $ [("country_id", tpack (show co_int)), ("count", tpack (show max_count)) ] ++@@ -56,8 +80,7 @@ getGroupWall :: (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord]) getGroupWall GroupRecord{..} =- resp_data <$> do- apiSimple emptyResponse "wall.get" $+ apiSimple "wall.get" $ [("owner_id", "-" <> tshow gr_id), ("count", "100") ]@@ -65,8 +88,7 @@ -- TODO: Take User as argument for more type-safety getAlbums :: (MonadAPI m x s) => Maybe Integer -> API m x (Sized [Album]) getAlbums muid =- resp_data <$> do- apiSimple emptyResponse "photos.getAlbums" $+ apiSimple "photos.getAlbums" $ (case muid of Just uid -> [("owner_id", tshow uid)] Nothing -> [])@@ -91,7 +113,8 @@ True -> return (head users) --- FIXME: move low-level upload code to API.Base+-- * FIXME fix setUserPhoto, it is not actually working+-- * FIXME move low-level upload code to API.Base setUserPhoto :: (MonadAPI m x s) => UserRecord -> FilePath -> API m x () setUserPhoto UserRecord{..} photo_path = do photo <- liftIO $ BS.readFile photo_path@@ -100,8 +123,8 @@ [("owner_id", tshow ur_id)] req <- ensure $ requestUploadPhoto ous_upload_url photo (res, _) <- requestExecute req- j@JSON{..} <- parseJSON (responseBody res)- liftIO $ putStrLn $ (responseBodyS res)+ j@JSON{..} <- decodeJSON (responseBody res)+ liftIO $ BS.putStrLn $ (responseBody res) UploadRecord{..} <- case Aeson.parseEither Aeson.parseJSON js_aeson of Right a -> return a
src/Web/VKHS/API/Types.hs view
@@ -1,3 +1,7 @@+-- | This module contains base VK API types+--+-- See [VK development docs](https://vk.com/dev) for the details+-- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -7,34 +11,21 @@ module Web.VKHS.API.Types where -import Data.Typeable-import Data.Data import Data.Time.Clock import Data.Time.Clock.POSIX-import Data.Monoid ((<>), Monoid(..))-import Control.Applicative ((<|>)) -import Data.Aeson ((.=), (.:), (.:?), (.!=), FromJSON(..)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson--import Data.Vector as Vector (head, tail)-import Data.Text--import Text.Printf+import qualified Data.Vector as Vector (head, tail) +import Web.VKHS.Imports import Web.VKHS.Error import Web.VKHS.Types--- import Web.VKHS.API.Base --- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений--- (in Russian) for more details- data Response a = Response { resp_json :: JSON , resp_data :: a- }- deriving (Show, Data, Typeable)+ } deriving (Show, Functor, Data, Typeable) emptyResponse :: (Monoid a) => Response a emptyResponse = Response (JSON $ Aeson.object []) mempty@@ -45,7 +36,7 @@ instance (FromJSON a) => FromJSON (Response a) where parseJSON j = Aeson.withObject "Response" (\o ->- Response <$> pure (JSON j) <*> (o .: "response" <|> o.: "error")) j+ Response <$> pure (JSON j) <*> (o .: "error" <|> o .: "response")) j -- | DEPRECATED, use @Sized@ instead data SizedList a = SizedList Int [a]
src/Web/VKHS/Client.hs view
@@ -117,7 +117,7 @@ newtype URL = URL { uri :: Client.URI } deriving(Show, Eq) --- FIXME: Pack Text to ByteStrings, not to String+-- * FIXME Pack Text to ByteStrings, not to String buildQuery :: [(String,String)] -> URL_Query buildQuery qis = URL_Query ("?" ++ intercalate "&" (map (\(a,b) -> (esc a) ++ "=" ++ (esc b)) qis)) where esc x = Client.escapeURIString Client.isAllowedInURI x@@ -132,7 +132,7 @@ Nothing -> Left (ErrorParseURL s "Client.parseURI failed") Just u -> Right (URL u) --- | FIXME: Convert to BS+-- | * FIXME Convert to BS splitFragments :: String -> String -> String -> [(String,String)] splitFragments sep eqs = filter (\(a, b) -> not (null a))@@ -147,7 +147,7 @@ trim = rev (dropWhile (`elem` (" \t\n\r" :: String))) where rev f = reverse . f . reverse . f --- | FIXME: Convert to BS+-- | * FIXME Convert to BS urlFragments :: URL -> [(String,String)] urlFragments URL{..} = splitFragments "&" "=" $ unsharp $ Client.uriFragment uri where unsharp ('#':x) = x@@ -185,6 +185,7 @@ case setUri Client.defaultRequest uri of Left exc -> do return $ Left $ ErrorSetURL (URL uri) (show exc)+ Right r -> do now <- liftIO getCurrentTime (r',_) <- pure $ Client.insertCookiesIntoRequest r jar now
src/Web/VKHS/Error.hs view
@@ -7,18 +7,32 @@ import Web.VKHS.Client (Response, Request, URL) import qualified Web.VKHS.Client as Client import Data.ByteString.Char8 (ByteString, unpack)-import Data.Text (Text)-import Data.Monoid ((<>)) +import Web.VKHS.Imports+ data Error = ETimeout | EClient Client.Error deriving(Show, Eq) --- | Alias for Result+-- | Message type used by the Superwiser to comminicatre with 'VK' coroutine.+--+-- See 'apiR' for usage example.+data CallRecovery =+ ReExec MethodName MethodArgs+ -- ^ VK program is to re-execute the method with the given parameters+ | ReParse JSON+ -- ^ VK program is to re-parse the JSON as if it was the result of API call in+ -- question+ deriving(Show)++-- | Alias for 'Result' type R t a = Result t a --- | Result with continuation. @t@ represents the continuation monad, which--- needs to track two types: the 'early break' type and the 'current result'--- type. In the end both types are the same.+-- | Result of 'VK' monad execution. @t@ represents the continuation monad, which+-- needs to track two types: the early break @t@ and the current result @a@.+-- In order to be runnable (e.g. by 'runVK') both types are need to be the same.+--+-- * FIXME re-implement the concept using `Monad.Free` library+-- * FIMXE clean out of test/unused constructors data Result t a = Fine a -- ^ The normal exit of a computation@@ -41,12 +55,15 @@ -- ^ Failed to convert JSON into Haskell object, Text describes an error. -- Superwiser may wish to replace the JSON with the correct one | LogError Text (() -> t (R t a) (R t a))+ | CallFailure (MethodName, MethodArgs, JSON, String) (CallRecovery -> t (R t a) (R t a)) data ResultDescription a = DescFine a | DescError String deriving(Show) +-- | A partial @Show@ for 'Result' class. Continuation parameters prevent it from be+-- instance of standard Show. describeResult :: (Show a) => Result t a -> Text describeResult (Fine a) = "Fine " <> tshow a describeResult (UnexpectedInt e k) = "UnexpectedInt " <> (tshow e)@@ -59,4 +76,5 @@ describeResult (JSONParseFailure' JSON{..} s) = "JSONParseFailure' " <> (tshow s) <> " JSON: " <> (tpack $ take 1000 $ show js_aeson) describeResult (LogError t k) = "LogError " <> (tshow t) describeResult (JSONCovertionFailure j k) = "JSONConvertionFailure " <> (tshow j)+describeResult (CallFailure (n,args,j,err) k) = "CallFailure " <> tshow n <> " " <> tshow args
src/Web/VKHS/Imports.hs view
@@ -1,14 +1,59 @@+-- | This module re-imports common declarations used across the VKHS module Web.VKHS.Imports ( module Web.VKHS.Imports+ , module Control.Arrow+ , module Control.Category+ , module Control.Applicative , module Control.Monad , module Control.Monad.Trans+ , module Control.Exception+ , module Data.Aeson+ , module Data.ByteString.Char8+ , module Data.ByteString.Lazy+ , module Data.Monoid+ , module Data.Char , module Data.Text , module Data.Text.IO+ , module Data.List+ , module Data.Function+ , module Data.Either+ , module Data.Maybe+ , module Data.Typeable+ , module Data.Data+ , module Text.Printf , module Prelude+ , module Text.Show.Pretty+ , module Text.Read ) where +import Control.Arrow ((***),(&&&))+import Control.Category ((>>>))+import Control.Applicative ((<$>), (<*>), (<|>), pure) import Control.Monad import Control.Monad.Trans-import Data.Text-import Data.Text.IO-import Prelude (($), IO(..), Bool(..))+import Control.Exception (SomeException(..),try,catch,bracket)+import Data.Aeson ((.=), (.:), (.:?), (.!=), FromJSON)+import Data.Typeable+import Data.Data+import Data.Char+import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (fromStrict,toChunks)+import Data.Either+import Data.Maybe+import Data.Monoid((<>))+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 Text.Printf+import Text.Show.Pretty+import Text.Read (readMaybe)++tpack :: String -> Text+tpack = pack+tunpack :: Text -> String+tunpack = unpack++tshow :: (Show a) => a -> Text+tshow = tpack . show
src/Web/VKHS/Login.hs view
@@ -34,6 +34,7 @@ import Web.VKHS.Client import Web.VKHS.Monad import Web.VKHS.Error+import Web.VKHS.Imports import Debug.Trace import System.IO
src/Web/VKHS/Monad.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}@@ -30,6 +31,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text +import Web.VKHS.Imports import Web.VKHS.Error import Web.VKHS.Types import Web.VKHS.Client hiding(Error)@@ -61,7 +63,7 @@ err r undefined --- | Request to the Superviser to log certain @text@+-- | Request the superviser to log @text@ log_error :: MonadVK (t (R t a)) (Result t a) => Text -> t (R t a) () log_error text = raise (LogError text) @@ -89,5 +91,36 @@ 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++-- | Read the access token according with respect to user-defined parameters+--+-- See also 'modifyAccessToken'+readInitialAccessToken :: (MonadIO m, MonadState s m, ToGenericOptions s) => m (Maybe AccessToken)+readInitialAccessToken =+ let+ str2at s = Just (AccessToken s "<unknown>" "<unknown>")++ safeReadFile fn = do+ liftIO $ Web.VKHS.Imports.catch (Just <$> readFile fn) (\(e :: SomeException) -> return Nothing)++ in do+ GenericOptions{..} <- getGenericOptions+ case l_access_token of+ [] -> do+ case l_access_token_file of+ [] -> return Nothing+ fl -> do+ safeReadFile l_access_token_file >>= \case+ Just txt -> do+ case readMaybe txt of+ Just at -> return (Just at)+ Nothing -> return (str2at txt)+ Nothing -> do+ return Nothing+ _ -> do+ return (str2at l_access_token)
src/Web/VKHS/Types.hs view
@@ -22,23 +22,19 @@ import qualified Network.Shpider.Forms as Shpider -bunpack = ByteString.unpack-tpack = Text.pack-tunpack = Text.unpack-tshow :: (Show a) => a -> Text-tshow = tpack . show- -- | 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. -- -- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений -- (in Russian) for more details+--+-- See also 'modifyAccessToken' and 'readInitialAccessToken' data AccessToken = AccessToken { at_access_token :: String , at_user_id :: String , at_expires_in :: String- } deriving(Show, Eq, Ord)+ } deriving(Read, Show, Eq, Ord) -- | Access rigth to request from VK. -- See API docs http://vk.com/developers.php?oid=-1&p=Права_доступа_приложений (in@@ -99,6 +95,9 @@ data JSON = JSON { js_aeson :: Aeson.Value } deriving(Show, Data, Typeable) +parseJSON :: (Aeson.FromJSON a) => JSON -> Either String a+parseJSON j = Aeson.parseEither Aeson.parseJSON (js_aeson j)+ data Form = Form { form_title :: String , form :: Shpider.Form@@ -110,6 +109,8 @@ } deriving(Show) +-- | Generic parameters of the VK execution. For accessing from VK runtime, use+-- `getGenericOptions` function data GenericOptions = GenericOptions { o_login_host :: String , o_api_host :: String@@ -122,10 +123,16 @@ , l_appid :: AppID , l_username :: String- -- ^ Empty string means no value is given+ -- ^ VK user name, (typically, an email). Empty string means no value is given , l_password :: String- -- ^ Empty string means no value is given+ -- ^ VK password. Empty string means no value is given+ -- * FIXME Hide plain-text passwords , l_access_token :: String+ -- ^ Initial access token, empty means 'not set'. Has higher precedence than+ -- l_access_token_file+ , l_access_token_file :: FilePath+ -- ^ Filename to store actual access token, should be used to pass its value+ -- between sessions } deriving(Show) defaultOptions = GenericOptions {@@ -139,10 +146,9 @@ , l_appid = AppID "3128877" , l_username = ""- -- ^ Empty string means no value is given , l_password = ""- -- ^ Empty string means no value is given , l_access_token = ""+ , l_access_token_file = "" } class ToGenericOptions s where@@ -174,4 +180,7 @@ g_search_string :: String , g_output_format :: String } deriving(Show)++type MethodName = String+type MethodArgs = [(String, Text)]