summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeyMironov <>2017-06-28 15:55:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-28 15:55:00 (GMT)
commit33b556fabf38edd87c992e896ed44980c4d1d437 (patch)
tree857ba6c832922fa62595cd46846de3a51f2dc661
parent12e70f69e9336d01cfdda9bd0cd5ccebd08faf6b (diff)
version 1.81.8
-rw-r--r--README.md110
-rw-r--r--VKHS.cabal3
-rw-r--r--app/vkq/Main.hs103
-rw-r--r--src/Web/VKHS.hs97
-rw-r--r--src/Web/VKHS/API/Base.hs68
-rw-r--r--src/Web/VKHS/API/Simple.hs67
-rw-r--r--src/Web/VKHS/API/Types.hs25
-rw-r--r--src/Web/VKHS/Client.hs7
-rw-r--r--src/Web/VKHS/Error.hs30
-rw-r--r--src/Web/VKHS/Imports.hs51
-rw-r--r--src/Web/VKHS/Login.hs1
-rw-r--r--src/Web/VKHS/Monad.hs35
-rw-r--r--src/Web/VKHS/Types.hs31
13 files changed, 382 insertions, 246 deletions
diff --git a/README.md b/README.md
index a460ff3..daa53ee 100644
--- a/README.md
+++ b/README.md
@@ -1,16 +1,32 @@
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
@@ -18,19 +34,50 @@ In order to install VKHS, type:
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 @@ we have to set it up
$ export VKQ_ACCESS_TOKEN=d785932b871f096bd73aac6a35d7a7c469dd788d796463a871e5beb5c61bc6c96788ec2
-Download audio
---------------
-
-Now, lets list first 10 audio files I have:
+VKQ may save the access tokein into state file:
- $ 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 login --access-token-file=.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 will ask for email/password and cache the 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
+ $ vkq call groups.search q=Beatles --pretty --access-token-file=.access-token
-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 @@ For example, lets call ausio.search method to get some Beatles records:
...
-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 @@ Debugging
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
@@ -143,5 +169,3 @@ BSD3 license
Copyright (c) 2014, Sergey Mironov <grrwlf@gmail.com>
-[1]: http://vk.com
-
diff --git a/VKHS.cabal b/VKHS.cabal
index 69e232f..169f5ad 100644
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -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 @@ library
vector,
filepath,
directory,
- taglib,
pretty-show
executable vkq
diff --git a/app/vkq/Main.hs b/app/vkq/Main.hs
index 6795c53..3af6d15 100644
--- a/app/vkq/Main.hs
+++ b/app/vkq/Main.hs
@@ -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 @@ import Util
env_access_token = "VKQ_ACCESS_TOKEN"
+-- | Options to query VK database
data DBOptions = DBOptions {
db_countries :: Bool
, db_cities :: Bool
@@ -91,6 +80,8 @@ opts m =
<*> 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 @@ cmd (API go APIOptions{..}) = do
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{..}))
diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs
index adcb5c2..91fc5f0 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -17,25 +17,20 @@ module Web.VKHS (
, 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 qualified Data.Text as Text
-import System.IO
-
+import Web.VKHS.Imports
import Web.VKHS.Error
import Web.VKHS.Types
import Web.VKHS.Client hiding (Error, Response)
@@ -44,13 +39,13 @@ 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)
+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 @@ initialState go = State
<*> 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 @@ defaultSuperviser = go where
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
diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs
index 7cfeda6..4cb6e3e 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -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.Types as Aeson
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 @@ class ToGenericOptions s => ToAPIState s where
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 @@ class (MonadIO (m (R m x)), MonadClient (m (R m x)) s, ToAPIState s, MonadVK (m
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 @@ parseJSON bs = do
-- <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 @@ apiJ mname (map (id *** tunpack) -> margs) = do
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 :: (Aeson.FromJSON a, MonadAPI m x s)
-- ^ 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 @@ apiE :: (Aeson.FromJSON a, MonadAPI m x s)
-> [(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)
diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs
index 0a56187..bb5ae30 100644
--- a/src/Web/VKHS/API/Simple.hs
+++ b/src/Web/VKHS/API/Simple.hs
@@ -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 @@ import Web.VKHS.API.Types
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 :: (MonadAPI m x s) => API m x (Sized [Country])
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 @@ getCities Country{..} mq =
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 @@ getGroupWall GroupRecord{..} =
-- 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 @@ getCurrentUser = do
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 @@ setUserPhoto UserRecord{..} photo_path = do
[("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
diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs
index 4c0a599..d91b89d 100644
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -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 qualified Data.Vector as Vector (head, tail)
-import Data.Vector as Vector (head, tail)
-import Data.Text
-
-import Text.Printf
-
+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 @@ parseJSON_obj_error name o = fail $
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]
diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs
index 0f9ebb9..01e70e2 100644
--- a/src/Web/VKHS/Client.hs
+++ b/src/Web/VKHS/Client.hs
@@ -117,7 +117,7 @@ newtype URL_Path = URL_Path { urlpath :: String }
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 @@ urlFromString s =
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 @@ splitFragments sep eqs =
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 @@ requestCreateGet URL{..} Cookies{..} = do
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
diff --git a/src/Web/VKHS/Error.hs b/src/Web/VKHS/Error.hs
index fb93c54..d0966db 100644
--- a/src/Web/VKHS/Error.hs
+++ b/src/Web/VKHS/Error.hs
@@ -7,18 +7,32 @@ import Web.VKHS.Types
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 @@ data Result t a =
-- ^ 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 bs _) = "JSONParseFailure " <> (tshow bs)
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
diff --git a/src/Web/VKHS/Imports.hs b/src/Web/VKHS/Imports.hs
index d489476..c7899f3 100644
--- a/src/Web/VKHS/Imports.hs
+++ b/src/Web/VKHS/Imports.hs
@@ -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
diff --git a/src/Web/VKHS/Login.hs b/src/Web/VKHS/Login.hs
index f7e2811..b33a782 100644
--- a/src/Web/VKHS/Login.hs
+++ b/src/Web/VKHS/Login.hs
@@ -34,6 +34,7 @@ import Web.VKHS.Types
import Web.VKHS.Client
import Web.VKHS.Monad
import Web.VKHS.Error
+import Web.VKHS.Imports
import Debug.Trace
import System.IO
diff --git a/src/Web/VKHS/Monad.hs b/src/Web/VKHS/Monad.hs
index 06e6a44..f355b02 100644
--- a/src/Web/VKHS/Monad.hs
+++ b/src/Web/VKHS/Monad.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -30,6 +31,7 @@ import Data.Text (Text)
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 @@ terminate r = do
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)
@@ -90,4 +92,35 @@ 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)
+
diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs
index 2fe8a16..a4ec907 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -22,23 +22,19 @@ import qualified Data.Aeson.Types as Aeson
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 @@ newtype AppID = AppID { aid_string :: String }
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 @@ data FilledForm = FilledForm {
} 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 @@ data GenericOptions = GenericOptions {
, 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 @@ defaultOptions = GenericOptions {
, 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
@@ -175,3 +181,6 @@ data GroupOptions = GroupOptions {
, g_output_format :: String
} deriving(Show)
+type MethodName = String
+type MethodArgs = [(String, Text)]
+