summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE2
-rw-r--r--README.md79
-rw-r--r--VKHS.cabal29
-rw-r--r--app/common/Util.hs32
-rw-r--r--app/vkq/Main.hs126
-rw-r--r--src/Network/Shpider/Forms.hs36
-rw-r--r--src/Text/HTML/TagSoup/Parsec.hs3
-rw-r--r--src/Text/Namefilter.hs4
-rw-r--r--src/Web/VKHS.hs196
-rw-r--r--src/Web/VKHS/API.hs1
-rw-r--r--src/Web/VKHS/API/Base.hs300
-rw-r--r--src/Web/VKHS/API/Simple.hs282
-rw-r--r--src/Web/VKHS/API/Types.hs215
-rw-r--r--src/Web/VKHS/Client.hs144
-rw-r--r--src/Web/VKHS/Coroutine.hs438
-rw-r--r--src/Web/VKHS/Error.hs80
-rw-r--r--src/Web/VKHS/Imports.hs62
-rw-r--r--src/Web/VKHS/Login.hs183
-rw-r--r--src/Web/VKHS/Monad.hs116
-rw-r--r--src/Web/VKHS/Types.hs210
20 files changed, 1494 insertions, 1044 deletions
diff --git a/LICENSE b/LICENSE
index 8c2556f..f689a3c 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2012, Sergey Mironov
+Copyright (c) 2018, Sergey Mironov
All rights reserved.
diff --git a/README.md b/README.md
index 0f6fc56..429ba57 100644
--- a/README.md
+++ b/README.md
@@ -4,40 +4,45 @@ VKHS
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-
-(disabled by VK) or retrieve wall messages.
+token, it is possible to call VK API methods.
Features
--------
-* Provides access to VK API. Interface options include: VK monad and `vkq` command
- line tool.
-* Uses HTTPS protocol.
-* Solves login form interaction, may be used to operate new/disposable VK accounts.
-* VK monad is designed as an interruptable coroutine. The supervisor supports
- ondemand re-login, and may be used for long-running tasks.
-* Project includes a set of `Web.VKHS.API.Simple` wrappers designed to be
- copied into `runhaskell` scripts and tweaked according to ones need.
-* No more dependencies on curlhs/taglib.
-
-ToDo
+* Provides access to VK API via `VKT` monad and `vkq` command line tool.
+* Supports HTTPS protocol.
+* Supports `http_proxy` variables.
+* Handles interaction with VK Login form.
+* `VKT` monad is designed to handle long-running tasks and allows programs to recover
+ from errors like network errors or token expirations.
+* [Web.VKHS.API.Simple](./src/Web/VKHS/API/Simple.hs) module defines handy API wrappers.
+ See example [`runhaskell` scripts](./app/runhaskell).
+
+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.
-* 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
+* ~~Still no support for captchas, one probably should hack `defaultSupervisor`
+ and add them.~~
* ~~File uploading still not functioning.~~
+* Preserve cookies between sessions
+* Make user-friendly multy-platform captcha display.
+* Fix login automata behaviour regarding captcha failures.
+* Re-test existing captcha-related functionality
+* Re-implement VK monad as a Free monad special case.
+* Runhaskell: handle some standard command line arguments.
* 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.
+* Fix grammatical mistakes here and there. Any corrections will be kindly accepted.
+* Minor issues here and there. Use `git grep FIXME` to find them.
+* Write simple RSS-feeder server, see [specs](./app/rss/README.md)
Installing
==========
+TODO: Drop a note about Stack
+
Installing from Hackage
-----------------------
@@ -60,24 +65,26 @@ Developing using Nix
The author of this project uses [Nix](http://nixos.org) as a main development
platform. The `default.nix` file contain Nix expression describing the environment
-#### Entering Nix shell environment
+#### Developing via Nix shell environment
+
+TODO: Check and document the usage of `cabal repl` with this package
$ git clone https://github.com/grwlf/vkhs
$ cd vkhs
- $ nix-shell
+ $ nix-shell # Entering NIX development shell
+ # ./ghci.sh # GHCI wrapper script
+ > :lo Main # Usual development
+ > ^D
+ # cabal install # Shell provides access to cabal
+ # cabal sdist
+ # ^D
+ $ ...
#### Usual development
$ ghci -isrc:app/vkq:app/common
- $ cabal install
$ ^D
-
-#### Returning to the system shell
-
- $ ^D
- $ nix-build
- $ ls ./result
-
+ $ cabal install
Building ctags file
-------------------
@@ -89,7 +96,6 @@ Hackage.
$ haskdogs
-
VKQ command line application
============================
@@ -130,7 +136,7 @@ Performing API calls
$ 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]
+ [--access-token-file FILE] METHOD [PARAMS] [--pretty]
Call VK API method
Available options:
@@ -152,16 +158,13 @@ Performing API calls
The session may look like the following:
- $ vkq api "messages.send" "user_id=111111,message=\"test\"" --pretty
- bd7da7e9cfb4cc12c0a49093173ca8785c7d6c918f00edb7315bb8526f5f372f1174b643e50e1a47d35da
-
- $ vkq api "users.get" ""
+ $ vkq api 'users.get'
{"response":[{"first_name":"Сергей","uid":222222,"last_name":"Миронов"}]}
- $ vkq api "messages.send" "user_id=333333,message=Hi theree!"
+ $ vkq api 'messages.send' 'user_id=333333' 'message="Hi there!!!"'
{"response":57505}
- $ vkq api "groups.search" "q=Haskell"
+ $ vkq api 'groups.search' 'q=Haskell'
{
"response": [
30,
@@ -222,5 +225,5 @@ License
BSD3 license
-Copyright (c) 2014, Sergey Mironov <grrwlf@gmail.com>
+Copyright (c) 2018, Sergey Mironov <grrwlf@gmail.com>
diff --git a/VKHS.cabal b/VKHS.cabal
index b9288bf..da25afc 100644
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -1,6 +1,6 @@
name: VKHS
-version: 1.9.1
+version: 1.9.2
synopsis: Provides access to Vkontakte social network via public API
description:
Provides access to Vkontakte API methods. Library requires no interaction
@@ -13,7 +13,7 @@ maintainer: grrwlf@gmail.com
copyright: Copyright (c) 2012, Sergey Mironov
category: Web
build-type: Simple
-cabal-version: >=1.6
+cabal-version: >=1.8
homepage: http://github.com/grwlf/vkhs
extra-source-files: CHANGELOG.md README.md
@@ -30,10 +30,9 @@ library
exposed-modules:
Web.VKHS
Web.VKHS.Types
- Web.VKHS.Monad
Web.VKHS.Client
Web.VKHS.Login
- Web.VKHS.Error
+ Web.VKHS.Coroutine
Web.VKHS.Imports
Web.VKHS.API
Web.VKHS.API.Types
@@ -49,6 +48,7 @@ library
network-uri,
pipes,
pipes-http,
+ process,
time,
data-default-class,
parsec,
@@ -65,12 +65,25 @@ library
filepath,
directory,
pretty-show,
- scientific
+ scientific,
+ text,
+ hashable,
+ flippers,
+ regexpr
+ ghc-options: -Wall -Wno-unused-imports -Wno-unused-matches
executable vkq
- hs-source-dirs: app/vkq, app/common, src
+ hs-source-dirs: app/vkq, app/common
main-is: Main.hs
other-modules:
Util
- build-depends: regexpr,
- text
+ build-depends: base>=4.6 && < 5,
+ regexpr,
+ text,
+ VKHS,
+ directory,
+ filepath,
+ mtl,
+ optparse-applicative,
+ parsec,
+ bytestring
diff --git a/app/common/Util.hs b/app/common/Util.hs
index 0b207fb..0c5935c 100644
--- a/app/common/Util.hs
+++ b/app/common/Util.hs
@@ -44,11 +44,11 @@ pshow = Text.pack . show
listTags = intercalate " " . map (\t -> '%' : t : []) . map fst
gr_tags = [
- ('i', show . gr_id)
+ ('i', show . gid_id . gr_gid)
, ('m', maybe "?" show . gr_members_count)
, ('n', namefilter . Text.unpack . gr_name)
, ('s', namefilter . Text.unpack . gr_screen_name)
- , ('u', groupURL)
+ , ('u', Text.unpack . aurl_str . groupURL)
]
gr_format :: String -> GroupRecord -> String
@@ -90,34 +90,6 @@ cutextra = gsubRegexPR "\\?extra=.*" ""
namefilter :: String -> String
namefilter = trim_space . one_space . normal_letters . no_html . html_amp
-
-
--- Open file. Return filename and handle. Don't open file if it exists
-openFileMR :: MusicOptions -> MusicRecord -> IO (FilePath, Maybe Handle)
-openFileMR mo@MusicOptions{..} mr@MusicRecord{..} =
- case m_out_dir of
- Nothing -> do
- let (_,ext) = splitExtension (mr_url_str)
- temp <- getTemporaryDirectory
- (fp,h) <- openBinaryTempFile temp ("vkqmusic"++ext)
- return (fp, Just h)
- Just odir -> do
- let (_,ext) = splitExtension mr_url_str
- let name = mr_format m_output_format mr
- let name' = replaceExtension name (takeWhile (/='?') ext)
- let fp = (odir </> name')
- e <- doesFileExist fp
- case (e && m_skip_existing) of
- True -> do
- return (fp,Nothing)
- False -> do
- handle (\(_::SomeException) -> do
- hPutStrLn stderr ("Failed to open file " <> fp)
- return (fp, Nothing)
- ) $ do
- h <- openBinaryFile fp WriteMode
- return (fp,Just h)
-
io :: (MonadIO m) => IO a -> m a
io = liftIO
diff --git a/app/vkq/Main.hs b/app/vkq/Main.hs
index d62a958..af9082e 100644
--- a/app/vkq/Main.hs
+++ b/app/vkq/Main.hs
@@ -7,27 +7,85 @@ module Main where
import Prelude hiding(putStrLn)
import Control.Monad.Except
+import Control.Exception(SomeException(..),handle)
import System.Environment
+import System.FilePath(splitExtension,replaceExtension,(</>))
+import System.Directory(getTemporaryDirectory,doesFileExist)
import System.Exit
-import System.IO(stderr)
+import System.IO(stderr,Handle,openBinaryFile,openBinaryTempFile,IOMode(..))
import Options.Applicative
import Text.RegexPR
+import Text.Parsec ((<|>),(<?>))
+import qualified Text.Parsec as Parsec
+import qualified Text.Parsec.String as Parsec
+
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.ByteString.Char8 as BS
+-- import Web.VKHS.Types
+-- import Web.VKHS.Error
+-- import Web.VKHS.Client as Client
+-- import Web.VKHS.Monad hiding (catch)
+-- import Web.VKHS.API as API
import Web.VKHS.Imports
import Web.VKHS
-import Web.VKHS.Types
-import Web.VKHS.Client as Client
-import Web.VKHS.Monad hiding (catch)
-import Web.VKHS.API as API
import Util
env_access_token = "VKQ_ACCESS_TOKEN"
+data MusicOptions = MusicOptions {
+ m_list_music :: Bool
+ , m_search_string :: String
+ , m_name_format :: String
+ , m_output_format :: String
+ , m_out_dir :: Maybe String
+ , m_records_id :: [String]
+ , m_skip_existing :: Bool
+ } deriving(Show)
+
+-- Open file. Return filename and handle. Don't open file if it exists
+openFileMR :: MusicOptions -> MusicRecord -> IO (FilePath, Maybe Handle)
+openFileMR mo@MusicOptions{..} mr@MusicRecord{..} =
+ case m_out_dir of
+ Nothing -> do
+ let (_,ext) = splitExtension (mr_url_str)
+ temp <- getTemporaryDirectory
+ (fp,h) <- openBinaryTempFile temp ("vkqmusic"++ext)
+ return (fp, Just h)
+ Just odir -> do
+ let (_,ext) = splitExtension mr_url_str
+ let name = mr_format m_output_format mr
+ let name' = replaceExtension name (takeWhile (/='?') ext)
+ let fp = (odir </> name')
+ e <- doesFileExist fp
+ case (e && m_skip_existing) of
+ True -> do
+ return (fp,Nothing)
+ False -> do
+ handle (\(_::SomeException) -> do
+ Text.hPutStrLn stderr ("Failed to open file " <> tpack fp)
+ return (fp, Nothing)
+ ) $ do
+ h <- openBinaryFile fp WriteMode
+ return (fp,Just h)
+
+
+data UserOptions = UserOptions {
+ u_queryString :: String
+ } deriving(Show)
+
+data WallOptions = WallOptions {
+ w_woid :: String
+ } deriving(Show)
+
+data GroupOptions = GroupOptions {
+ g_search_string :: String
+ , g_output_format :: String
+ } deriving(Show)
+
-- | Options to query VK database
data DBOptions = DBOptions {
db_countries :: Bool
@@ -36,7 +94,7 @@ data DBOptions = DBOptions {
data APIOptions = APIOptions {
a_method :: String
- , a_args :: String
+ , a_args :: [String]
, a_pretty :: Bool
} deriving(Show)
@@ -74,7 +132,7 @@ optdesc m =
<$> (pure $ o_login_host defaultOptions)
<*> (pure $ o_api_host defaultOptions)
<*> (pure $ o_port defaultOptions)
- <*> flag False True (long "verbose" <> help "Be verbose")
+ <*> flag Normal Debug (long "verbose" <> help "Be verbose")
<*> (pure $ o_use_https defaultOptions)
<*> fmap (read . tunpack) (tpack <$> strOption (value (show $ o_max_request_rate_per_sec defaultOptions) <> long "req-per-sec" <> metavar "N" <> help "Max number of requests per second"))
<*> flag True False (long "interactive" <> help "Allow interactive queries")
@@ -86,19 +144,21 @@ optdesc m =
help ("Access token. Honores " ++ env_access_token ++ " environment variable"))
<*> 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"))
+ <*> strOption (long "cookies-file" <> value (l_cookies_file defaultOptions) <> metavar "FILE" <>
+ help "Filename to stote cookies, should be used to store cookies between sessions")
genericOptions = genericOptions_
(strOption (value "" <> long "user" <> metavar "USER" <> help "User name or email"))
(strOption (value "" <> long "pass" <> metavar "PASS" <> help "User password"))
genericOptions_login = genericOptions_
- (argument str (metavar "USER" <> help "User name or email"))
- (argument str (metavar "PASS" <> help "User password"))
+ (argument str (metavar "USER" <> help "User name or email" <> value ""))
+ (argument str (metavar "PASS" <> help "User password" <> value ""))
api_cmd = (info (API <$> genericOptions <*> (APIOptions
<$> argument str (metavar "METHOD" <> help "Method name")
- <*> argument str (metavar "PARAMS" <> help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]")
+ <*> many (argument str (metavar "PARAMS" <> help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]"))
<*> switch (long "pretty" <> help "Pretty print resulting JSON")))
( progDesc "Call VK API method" ))
@@ -175,7 +235,7 @@ main = ( do
r <- runVK (genOpts o) (cmd o)
case r of
Left err -> do
- hPutStrLn stderr err
+ hPutStrLn stderr (printVKError err)
exitFailure
Right _ -> do
return ()
@@ -193,7 +253,7 @@ main = ( do
-}
-cmd :: (MonadLogin (m (R m x)) (R m x) s, MonadAPI m x s) => Options -> m (R m x) ()
+cmd :: (MonadAPI m x s) => Options -> m (R m x) ()
-- Login
cmd (Login go LoginOptions{..}) = do
@@ -201,17 +261,37 @@ cmd (Login go LoginOptions{..}) = do
case l_eval of
True -> liftIO $ putStrLn $ Text.pack $ printf "export %s=%s\n" env_access_token at_access_token
False -> do
- modifyAccessToken at
liftIO $ putStrLn $ Text.pack at_access_token
-- API / CALL
-cmd (API go APIOptions{..}) = 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
+cmd (API go APIOptions{..}) =
+ let
+ word :: Parsec.Parser String
+ word = Parsec.try (do
+ c <- Parsec.oneOf "\"'"
+ ret <- Parsec.many $ Parsec.satisfy (/=c)
+ Parsec.char c
+ return ret)
+ Parsec.<|>
+ Parsec.many (Parsec.satisfy (not . flip elem (" \"=" :: String)))
+
+ term :: Parsec.Parser (String,String)
+ term = (,) <$> word <*> ((Parsec.char '=') *> word) <?> "term"
+
+ res :: Either Parsec.ParseError [(String,String)]
+ res = foldr (liftA2 (:)) (pure [])
+ $ flip map a_args
+ $ Parsec.runParser term () "<cmdline>"
+ in do
+ case res of
+ Left err -> error $ "error parsing command line arguments: " <> show err
+ Right pairs -> do
+ x <- api a_method (map (id *** tpack) pairs)
+ 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."
@@ -221,7 +301,7 @@ cmd (GroupQ go (GroupOptions{..}))
|not (null g_search_string) = do
- (Sized cnt grs) <- groupSearch (tpack g_search_string)
+ grs <- groupSearch (tpack g_search_string)
forM_ grs $ \gr -> do
liftIO $ printf "%s\n" (gr_format g_output_format gr)
@@ -230,10 +310,10 @@ cmd (DBQ go (DBOptions{..}))
|db_countries = do
- (Sized cnt cs) <- getCountries
+ cs <- getCountries
forM_ cs $ \Country{..} -> do
- liftIO $ Text.putStrLn $ Text.concat [ tshow co_int, "\t", co_title]
+ liftIO $ Text.putStrLn $ Text.concat [ tshow $ coid_id $ co_coid, "\t", co_title]
|db_cities = do
error "not implemented"
diff --git a/src/Network/Shpider/Forms.hs b/src/Network/Shpider/Forms.hs
index 5301667..2c2e2ba 100644
--- a/src/Network/Shpider/Forms.hs
+++ b/src/Network/Shpider/Forms.hs
@@ -34,6 +34,7 @@ module Network.Shpider.Forms
, mkForm
, gatherTitle
, emptyInputs
+ , gatherCaptcha
)
where
@@ -43,7 +44,7 @@ import Data.Maybe
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
-import Data.String.UTF8 as U (UTF8(..))
+import Data.String.UTF8 as U (UTF8)
import qualified Data.String.UTF8 as U
import qualified Data.Map as M
@@ -52,19 +53,20 @@ import Text.HTML.TagSoup.Parsec
import Network.Shpider.TextUtils
import Network.Shpider.Pairs
+import Text.StringLike (StringLike(..))
-- | Either GET or POST.
data Method =
GET | POST
- deriving Show
+ deriving (Show,Eq)
-- | Plain old form: Method, action and inputs.
-data Form =
+data Form =
Form { method :: Method
- , action :: String
+ , action :: String
, inputs :: M.Map String String
}
- deriving Show
+ deriving (Show,Eq)
emptyInputs :: Form -> [String]
emptyInputs = fst . unzip . filter ( not . null . snd ) . M.toList . inputs
@@ -100,17 +102,29 @@ gatherForms =
gatherTitle :: [Tag String] -> String
gatherTitle ts = case tParse allTitles ts of { [] -> "" ; x:_ -> x }
+gatherCaptcha :: [Tag String] -> Maybe String
+gatherCaptcha ts = case tParse allCaptchas ts of { [] -> Nothing ; x:_ -> Just x }
+
allTitles :: TagParser String [String]
allTitles = do
fs <- allWholeTags "title"
return $ mapMaybe (
\(TagOpen "title" _ , innerTags , _ ) ->
return $ concat $ map (\t -> case t of
- TagText t -> t
+ TagText t2 -> t2
_ -> []
) innerTags
) fs
+allCaptchas :: TagParser String [String]
+allCaptchas = do
+ ts <- allWholeTags "img"
+ return $ flip mapMaybe ts $
+ \(TagOpen "img" attrs , _ , _ ) ->
+ case (lookup "id" attrs, lookup "src" attrs) of
+ (Just "captcha", Just url) -> Just url
+ _ -> Nothing
+
-- | The `TagParser` which parses all forms.
allForms :: TagParser String [ Form ]
allForms = do
@@ -128,6 +142,9 @@ toForm ( TagOpen _ attrs , innerTags , _ ) = do
, method = m
}
+toForm _ = Nothing
+
+methodLookup :: [(String, String)] -> Maybe Method
methodLookup attrs = do
m <- attrLookup "method" attrs
case lowercase m of
@@ -135,9 +152,10 @@ methodLookup attrs = do
Just GET
"post" ->
Just POST
- otherwise ->
+ _ ->
Nothing
+inputNameValue :: Tag String -> Maybe (String, [Char])
inputNameValue ( TagOpen _ attrs ) = do
v <- case attrLookup "value" attrs of
Nothing ->
@@ -147,8 +165,12 @@ inputNameValue ( TagOpen _ attrs ) = do
n <- attrLookup "name" attrs
Just ( n , v )
+inputNameValue _ = Nothing
+
+textAreaNameValue :: StringLike b => (Tag String, [Tag b], c) -> Maybe (String, b)
textAreaNameValue ( TagOpen _ attrs , inner , _ ) = do
let v = innerText inner
n <- attrLookup "name" attrs
Just ( n , v )
+textAreaNameValue _ = Nothing
diff --git a/src/Text/HTML/TagSoup/Parsec.hs b/src/Text/HTML/TagSoup/Parsec.hs
index 9bdb04f..45f0149 100644
--- a/src/Text/HTML/TagSoup/Parsec.hs
+++ b/src/Text/HTML/TagSoup/Parsec.hs
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Text.HTML.TagSoup.Parsec
( module Text.HTML.TagSoup
@@ -202,7 +203,7 @@ maybeP :: Show tok => GenParser tok st a -> GenParser tok st ( Maybe a )
maybeP p =
try ( do t <- p
return $ Just t
- ) <|> ( do anyToken
+ ) <|> ( do _ <- anyToken
return Nothing
)
diff --git a/src/Text/Namefilter.hs b/src/Text/Namefilter.hs
index dd213c3..26c014d 100644
--- a/src/Text/Namefilter.hs
+++ b/src/Text/Namefilter.hs
@@ -1,4 +1,6 @@
-module Text.Namefilter
+{-# OPTIONS_GHC -Wno-missing-signatures #-}
+
+module Text.Namefilter
( namefilter
) where
diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs
index 28fadb7..e82bf12 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -5,200 +5,20 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module Web.VKHS (
- module Web.VKHS
- , module Web.VKHS.Client
+ module Web.VKHS.Client
, module Web.VKHS.Types
- , module Web.VKHS.Error
- , module Web.VKHS.Monad
- , module Web.VKHS.Login
+ , module Web.VKHS.Coroutine
, module Web.VKHS.API
) where
-import Data.Time
-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 qualified Data.ByteString.Char8 as BS
-import qualified Data.Text as Text
-
-import Web.VKHS.Imports
-import Web.VKHS.Error
+import Web.VKHS.Coroutine
import Web.VKHS.Types
-import Web.VKHS.Client hiding (Error, Response, defaultState)
-import qualified Web.VKHS.Client as Client
-import Web.VKHS.Monad hiding (catch)
-import qualified Web.VKHS.Monad as VKHS
-import Web.VKHS.Login (MonadLogin, LoginState(..), ToLoginState(..), printForm, login)
-import qualified Web.VKHS.Login as Login
+import Web.VKHS.Client
+import Web.VKHS.Login
import Web.VKHS.API
-import qualified Web.VKHS.API as API
-
--- | Main state of the VK monad stack. Consists of lesser states plus a copy of
--- generic options provided by the caller.
-data State = State {
- cs :: ClientState
- , ls :: LoginState
- , as :: APIState
- , go :: GenericOptions
- }
-
-instance ToLoginState State where
- toLoginState = ls
- modifyLoginState f = \s -> s { ls = f (ls s) }
-instance ToClientState State where
- toClientState = cs
- modifyClientState f = \s -> s { cs = f (cs s) }
-instance API.ToAPIState State where
- toAPIState = as
- modifyAPIState f = \s -> s { as = f (as s) }
-instance ToGenericOptions State where
- toGenericOptions = go
-
-initialState :: (MonadIO m) => GenericOptions -> m State
-initialState go = State
- <$> liftIO (Client.defaultState go)
- <*> pure (Login.defaultState go)
- <*> pure (API.defaultState)
- <*> pure go
-
-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. VK encodes a coroutine which
--- has entry points defined by 'Result' datatype.
---
--- See also 'runVK' and 'defaultSupervisor`.
---
--- * 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 State
-
--- | 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. @defaultSupervisor@ 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)
-defaultSupervisor :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT Text IO) a
-defaultSupervisor = go where
- go m = do
- GenericOptions{..} <- toGenericOptions <$> get
- res <- stepVK m
- res_desc <- pure (describeResult res)
- case res of
- 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 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
- NotLoggedIn -> do
- alert $ "Attempting to re-login"
- at <- defaultSupervisor (login >>= return . Fine)
- modifyAccessToken at
- go (k $ ReExec m args)
- TooManyRequestsPerSec -> do
- alert $ "Too many requests per second, consider changing options"
- go (k $ ReExec m args)
- ErrorCode ec -> do
- alert $ "Unhandled error code " <> tshow ec <> "\n"
- <> "Consider improving 'defaultSupervisor' or applying \n"
- <> "custom error filters using `apiH` ,`apiHS` or their \n"
- <> "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
-
--- | Run login procedure using 'defaultSupervisor'. Return 'AccessToken' on
--- success
-runLogin :: GenericOptions -> ExceptT Text IO AccessToken
-runLogin go = do
- s <- initialState go
- evalStateT (defaultSupervisor (login >>= return . Fine)) s
-
--- | Run the VK monad @m@ using generic options @go@ and 'defaultSupervisor'.
--- 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
-
- readInitialAccessToken >>= \case
- Nothing ->
- return ()
- Just at -> do
- modifyAccessToken at
-
- defaultSupervisor (m >>= return . Fine)
-
--- | Run the VK monad @m@ using generic options @go@ and 'defaultSupervisor'
-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
- Left e -> fail (tunpack e)
- Right _ -> return ()
diff --git a/src/Web/VKHS/API.hs b/src/Web/VKHS/API.hs
index 1107f76..bfd83b1 100644
--- a/src/Web/VKHS/API.hs
+++ b/src/Web/VKHS/API.hs
@@ -3,7 +3,6 @@ module Web.VKHS.API (
module Web.VKHS.API.Base
, module Web.VKHS.API.Types
, module Web.VKHS.API.Simple
- , module Web.VKHS.API
) where
import Web.VKHS.API.Base
diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs
index e086e8a..0a8b5c9 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -1,3 +1,6 @@
+{-| Definitions of basic API types such as Response and Error, definitions of
+ - various API-caller functions -}
+
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
@@ -7,221 +10,160 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module Web.VKHS.API.Base where
-import Data.Time
-import Control.Applicative
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.Writer
-import Control.Monad.Cont
-import Control.Exception (catch, SomeException)
-
+import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-import Data.ByteString.Lazy (fromStrict,toChunks)
import qualified Data.ByteString.Char8 as BS
-import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as Aeson
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
-import Web.VKHS.Error
-import Web.VKHS.API.Types
-import Debug.Trace
+-- | Alias for 'Result'
+type R t a = APIRoutine t a
+-- | 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 APIRoutine t a =
+ Fine a
+ | APIFailed APIError
+ | ExecuteAPI (MethodName, MethodArgs) (JSON -> t (R t a) (R t a))
+ | UploadFile (HRef,FilePath) (UploadRecord -> t (R t a) (R t a))
+ | APILogin (AccessToken -> t (R t a) (R t a))
+ | APIMessage Verbosity Text (() -> t (R t a) (R t a))
+
+-- | VK Response representation
+data APIResponse a = APIResponse {
+ resp_json :: JSON
+ -- ^ Original JSON representation of the respone, as received from the VK
+ , resp_data :: (a,Bool)
+ -- ^ Haskell ADT representation of the response
+ } deriving (Show, Functor, Data, Typeable)
+
+emptyResponse :: (Monoid a) => APIResponse a
+emptyResponse = APIResponse (JSON $ Aeson.object []) (mempty,True)
+
+parseJSON_obj_error :: String -> Aeson.Value -> Aeson.Parser a
+parseJSON_obj_error name o = fail $
+ printf "parseJSON: %s expects object, got %s" (show name) (show o)
+
+instance (FromJSON a) => FromJSON (APIResponse a) where
+ parseJSON j = Aeson.withObject "APIResponse" (\o ->
+ APIResponse
+ <$> pure (JSON j)
+ <*> (((,) <$> (o .: "error") <*> pure False) <|> ((,) <$> (o .: "response") <*> pure True))
+ ) j
+
+type APICache = Map (MethodName,MethodArgs) (JSON,Time)
+
+cacheQuery :: DiffTime -> MethodName -> MethodArgs -> Time -> APICache -> Maybe JSON
+cacheQuery maxage mname margs time c =
+ case Map.lookup (mname,margs) c of
+ Just (json,birth) ->
+ case time `diffTime` birth > maxage of
+ True -> Nothing {- record is too old -}
+ False -> Just json
+ Nothing -> Nothing
+
+cacheAdd :: MethodName -> MethodArgs -> JSON -> Time -> APICache -> APICache
+cacheAdd mname margs json time = Map.insert (mname,margs) (json,time)
+
+cacheFilter :: DiffTime -> Time -> APICache -> APICache
+cacheFilter maxage now = Map.filter (\(_,t) -> (now`diffTime`t) < maxage)
+
+cacheSave :: FilePath -> APICache -> IO ()
+cacheSave fp c = writeFile fp (show c)
+
+cacheLoad :: FilePath -> IO (Maybe APICache)
+cacheLoad fp =
+ let
+ safeReadFile fn = do
+ liftIO $ Web.VKHS.Imports.catch (Just <$> readFile fn) (\(e :: SomeException) -> return Nothing)
+ in
+ (readMaybe =<<) <$> safeReadFile fp
+
+-- | State of the API engine
data APIState = APIState {
api_access_token :: String
+ , api_state_cache :: APICache
} deriving (Show)
-defaultState = APIState {
+defaultAPIState :: APIState
+defaultAPIState = APIState {
api_access_token = ""
+ , api_state_cache = Map.empty
}
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)) =>
+class (MonadIO (m (R m x)), ToAPIState s, MonadVK (m (R m x)) (R m x) s) =>
MonadAPI m x s | m -> s
+
+-- | Short alias for the coroutine monad
type API m x a = m (R m x) a
--- | Utility function to parse JSON object
---
--- * FIXME Don't raise exception, simply return `Left err`
-decodeJSON :: (MonadAPI m x s)
- => ByteString
- -> API m x JSON
-decodeJSON bs = do
- case Aeson.decode (fromStrict bs) of
- Just js -> return (JSON js)
- Nothing -> raise (JSONParseFailure bs)
-
--- | Invoke the request. Returns answer as JSON object .
---
--- See the official documentation:
--- <https://vk.com/dev/methods>
--- <https://vk.com/dev/json_schema>
---
--- * 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
- -> [(String, Text)]
- -- ^ API method arguments
- -> API m x JSON
-apiJ mname (map (id *** tunpack) -> margs) = do
- GenericOptions{..} <- gets toGenericOptions
- APIState{..} <- gets toAPIState
- let protocol = (case o_use_https of
- True -> "https"
- False -> "http")
- url <- ensure $ pure
- (urlCreate
- (URL_Protocol protocol)
- (URL_Host o_api_host)
- (Just (URL_Port (show o_port)))
- (URL_Path ("/method/" ++ mname))
- (buildQuery (("access_token", api_access_token):margs)))
-
- debug $ "> " <> (tshow url)
-
- req <- ensure (requestCreateGet url (cookiesCreate ()))
- (res, jar') <- requestExecute req
- decodeJSON (responseBody res)
-
-
--- | Invoke the request, return answer as a Haskell datatype. On error fall out
--- to the supervizer (e.g. @VKHS.defaultSuperviser@) without possibility to
--- continue
-api :: (Aeson.FromJSON a, MonadAPI m x s)
- => String
- -- ^ API method name
- -> [(String, Text)]
- -- ^ API method arguments
- -> API m x a
-api m args = do
- 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
--- supervisor. The superwiser has a chance to change the arguments
-apiRf :: (Aeson.FromJSON b, MonadAPI m x s)
- => MethodName -- ^ API method name
- -> MethodArgs -- ^ API method arguments
- -> (b -> Either String a)
- -> API m x a
-apiRf m0 args0 flt = 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 (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
+-- | Perform API call
+api :: (MonadAPI m x s) => MethodName -> MethodArgs -> API m x JSON
+api mname margs = raiseVK (ExecuteAPI (mname,margs))
+
+-- | Upload File to server
+upload :: (MonadAPI m x s) => HRef -> FilePath -> API m x UploadRecord
+upload href filepath = raiseVK (UploadFile (href,filepath))
+
+-- | Ask superviser to re-login
+login :: (MonadAPI m x s) => API m x AccessToken
+login = raiseVK APILogin
+
+-- | Request the superviser to log @text@
+message :: (MonadAPI m x s) => Verbosity -> Text -> API m x ()
+message verb text = raiseVK (APIMessage verb text)
+
+debug :: (MonadAPI m x s) => Text -> API m x ()
+debug = message Debug
--- | Invoke the request, in case of failure, escalate the probelm to the
--- supervisor. The superwiser has a chance to change the arguments
-apiHM :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
+trace :: (MonadAPI m x s) => (a -> Text) -> API m x a -> API m x a
+trace f m = m >>= \a -> message Trace ("> " <> (f a)) >> return a
+
+api1 :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
=> MethodName -- ^ API method name
-> MethodArgs -- ^ API method arguments
- -> (ErrorRecord -> API m x (Maybe a))
-> API m x a
-apiHM m0 args0 handler = go (ReExec m0 args0) where
- go action = do
- j <- do
- case action of
- ReExec m args -> do
- apiJ m args
- ReParse j -> do
- pure j
- case (parseJSON j, parseJSON j) of
- (Left e1, Left e2) -> do
- recovery <- raise (CallFailure (m0, args0, j, e1 <> ";" <> e2))
- go recovery
- (Left e, Right (Response _ err)) -> do
- ma <- (handler err)
- case ma of
- Just a -> return a
- Nothing -> do
- recovery <- raise (CallFailure (m0, args0, j, e))
- go recovery
- (Right _, Right (Response _ err)) -> do
- ma <- (handler err)
- case ma of
- Just a -> return a
- Nothing -> do
- recovery <- raise (CallFailure (m0, args0, j,
- "Response matches both error and result object"))
- go recovery
- (Right (Response _ a), _) -> do
- return a
-
-apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
+api1 mname margs = do
+ json <- api mname margs
+ case parseJSON json of
+ (Left e1) -> do
+ terminate $ APIFailed $ APIInvalidJSON mname json e1
+ (Right (APIResponse _ (a,_))) -> do
+ return a
+
+api2 :: forall m x a b s . (Aeson.FromJSON a, Aeson.FromJSON b, MonadAPI m x s)
=> MethodName -- ^ API method name
-> MethodArgs -- ^ API method arguments
- -> (ErrorRecord -> Maybe a)
- -> API m x a
-apiH m args handler = apiHM m args (\e -> pure (handler e) :: API m x (Maybe a))
-
--- Encode JSON back to string
-jsonEncodeBS :: JSON -> ByteString
-jsonEncodeBS JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson
-
-jsonEncode :: JSON -> Text
-jsonEncode JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encode js_aeson
-
-jsonEncodePrettyBS :: JSON -> ByteString
-jsonEncodePrettyBS JSON{..} = BS.concat $ toChunks $ Aeson.encodePretty js_aeson
-
-jsonEncodePretty :: JSON -> Text
-jsonEncodePretty JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encodePretty js_aeson
+ -> API m x (Either a b)
+api2 mname margs = do
+ json <- api mname margs
+ case (parseJSON json, parseJSON json) of
+ (Left e1, Left e2) -> do
+ terminate $ APIFailed $ APIInvalidJSON mname json (e1 <> ";" <> e2)
+ (Right (APIResponse _ (a,_)), _) -> do
+ return (Left a)
+ (_, Right (APIResponse _ (b,_))) -> do
+ return (Right b)
diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs
index beeba64..dca21a8 100644
--- a/src/Web/VKHS/API/Simple.hs
+++ b/src/Web/VKHS/API/Simple.hs
@@ -1,7 +1,7 @@
--- | 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.
+-- | This module contains definitions of various VK API bindings. It is desigend
+-- to be as simple as possible. The collection is not even close to be complete.
+-- The user is expected to copy-and-paste any function from this module into
+-- their 'runhaskell' script and customize it as required.
--
-- Runhaskell script may looks like the following:
-- @
@@ -24,7 +24,8 @@
-- liftIO $ tputStrLn "--------------"
-- @
--
--- See more scripts under @./app/runhaskell@ folder
+-- See also a collection of scripts in the @./app/runhaskell@ folder of
+-- the distribution package.
--
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
@@ -39,112 +40,263 @@ import qualified Data.Aeson.Types as Aeson
import Web.VKHS.Imports
import Web.VKHS.Types
-import Web.VKHS.Monad
-import Web.VKHS.Error
-import Web.VKHS.Client(requestUploadPhoto, requestExecute, responseBody, responseBodyS)
import Web.VKHS.API.Base
import Web.VKHS.API.Types
+max_count :: Integer
max_count = 1000
-- | We are using API v5.44 by default
+ver :: Text
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)
+users_fields = "can_post,members_count,city,country,education,sex,photo_50,photo_100,photo_200,photo_400_orig,photo_max"
--- | This function demonstrates pure-functional error handling
-groupSearch :: (MonadAPI m x s) => Text -> API m x (Sized [GroupRecord])
+-- | Versioned aliases for api caller functions
+-- apiSimpleF nm args f = apiRf nm (("v",ver):args) f
+apiSimple1 :: (MonadAPI m x s, FromJSON a) => MethodName -> [(String, Text)] -> API m x a
+apiSimple1 nm args = api1 nm (("v",ver):args)
+
+apiSimple2 :: (MonadAPI m x s, FromJSON b, FromJSON a) => MethodName -> [(String, Text)] -> API m x (Either a b)
+apiSimple2 nm args = api2 nm (("v",ver):args)
+-- apiSimpleHM nm args handler = apiHM nm (("v",ver):args) handler
+
+apiSimple :: (FromJSON a, MonadAPI m x s) => MethodName -> [(String, Text)] -> API m x a
+apiSimple nm args = apiSimple1 nm args
+-- apiSimpleE nm args handler = do
+
+apiSimpleH :: (FromJSON t, MonadAPI m x s) => MethodName -> [(String, Text)] -> (t -> b) -> (APIErrorRecord -> Either Text b) -> m (R m x) b
+apiSimpleH nm args handlerA handlerB = do
+ res <- apiSimple2 nm args
+ case res of
+ Left e ->
+ case handlerB e of
+ Left text -> terminate $ APIFailed $ APIUnhandledError nm e text
+ Right a -> return a
+ Right a -> return (handlerA a)
+
+
+-- | Wrapper for 'groups.search' handler. The function demonstrates
+-- pure-functional error handling.
+groupSearch :: (MonadAPI m x s) => Text -> API m x [GroupRecord]
groupSearch q =
- fmap (sortBy (compare `on` gr_members_count)) <$> do
- apiSimpleH "groups.search"
- [("q",q),
- ("fields", "can_post,members_count"),
- ("count", tpack (show max_count))]
- (\ErrorRecord{..} ->
- case er_code of
- AccessDenied -> (Just $ Sized 0 [])
- _ -> Nothing
- )
+ trace (\gr ->
+ case length gr < 10 of
+ True -> "groupSearch: keyword \"" <> q <> "\" returns: " <> Text.intercalate "," (map gr_name gr)
+ False -> "groupSearch: keyword \"" <> q <> "\" returns: " <> tshow (length gr) <> " groups"
+ ) $ do
+ sortBy (compare `on` gr_members_count) <$> do
+ m_items <$> do
+ apiSimpleH "groups.search"
+ [("q",q),
+ ("fields", "can_post,members_count"),
+ ("count", tpack (show max_count))]
+ id
+ (\APIErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> Right (Sized 0 [])
+ _ -> Left ""
+ )
+
+data UsersSearchArgs = UsersSearchArgs {
+ usa_q :: Text
+ , usa_city :: Maybe City
+ , usa_coid :: Maybe CountryId
+ , usa_sex :: Maybe Sex
+} deriving (Show)
+
+defaultUsersSearchArgs = UsersSearchArgs "" Nothing Nothing Nothing
-getCountries :: (MonadAPI m x s) => API m x (Sized [Country])
+usersSearch :: (MonadAPI m x s) => UsersSearchArgs -> Integer -> API m x [UserRecord]
+usersSearch UsersSearchArgs{..} offset =
+ trace (\r ->
+ case length r < 10 of
+ True -> "usersSearch: keyword \"" <> usa_q <> "\" returns: " <> Text.intercalate "," (map ur_first_name r)
+ False -> "usersSearch: keyword \"" <> usa_q <> "\" returns: " <> tshow (length r) <> " users"
+ ) $ do
+ m_items <$> do
+ apiSimpleH "users.search"
+ ([("q",usa_q)
+ ,("fields", users_fields)
+ ,("offset", tshow offset)
+ ,("count", tshow max_count)
+ ,("sort", "0") -- popularity
+ ] <> concat [
+ maybe [] ((:[]) . ("sex",) . tshow . sexId) usa_sex
+ , maybe [] ((:[]) . ("country",) . tshow . coid_id) usa_coid
+ ])
+ id
+ (\APIErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> Right (mempty :: Sized [UserRecord])
+ _ -> Left ""
+ )
+
+-- | Get list of countries, known to VK
+getCountries :: (MonadAPI m x s) => API m x [Country]
getCountries =
- fmap (sortBy (compare `on` co_title)) <$> do
+ sortBy (compare `on` co_title) <$> do
+ m_items <$> do
apiSimple "database.getCountries"
[("v",ver),
("need_all", "1"),
("count", tpack (show max_count))
]
+-- | Get list of country cities, known to VK
getCities :: (MonadAPI m x s) => Country -> Maybe Text -> API m x (Sized [City])
getCities Country{..} mq =
apiSimple "database.getCities" $
- [("country_id", tpack (show co_int)),
+ [("country_id", tshow $ coid_id $ co_coid),
("count", tpack (show max_count))
] ++
maybe [] (\q -> [("q",q)]) mq
--- | See [https://vk.com/dev/wall.get]
---
+-- | Wrapper for [https://vk.com/dev/wall.get] function
-- 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"
- [("owner_id", "-" <> tshow gr_id),
+ apiSimpleH "wall.get"
+ [("owner_id", "-" <> (tshow $ gid_id $ gr_gid)),
("count", "100")
]
- (\ErrorRecord{..} ->
+ id
+ (\APIErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> (Right $ Sized 0 [])
+ _ -> Left ""
+ )
+
+-- | Wrapper for [https://vk.com/dev/wall.get] function
+getWall :: forall m x s . (MonadAPI m x s) => Int -> Int -> API m x (Sized [WallRecord])
+getWall owner_id count =
+ apiSimpleH "wall.get"
+ [("owner_id", tshow owner_id),
+ ("count", tshow count)
+ ]
+ id
+ (\APIErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> Right $ Sized 0 []
+ _ -> Left ""
+ )
+
+-- | https://vk.com/dev/wall.getById
+getWallById :: (MonadAPI m x s) => (Int, Int) -> API m x (Maybe WallRecord)
+getWallById (owner_id, post_id) = do
+ apiSimpleH "wall.getById"
+ [("posts", tshow owner_id <> "_" <> tshow post_id)
+ ]
+ Just
+ (\APIErrorRecord{..} ->
case er_code of
- AccessDenied -> do
- return (Just $ Sized 0 [])
- _ -> do
- return Nothing
- :: API m x (Maybe (Sized [WallRecord])))
+ AccessDenied -> Right Nothing
+ _ -> Left ""
+ )
+
+-- | Return modified and unmodified reposts of this wall recor. Algorithm is
+-- based on the following methods:
+-- https://vk.com/dev/wall.getReposts
+-- https://vk.com/dev/likes.getList
+-- See also https://habrahabr.ru/post/177641 (in Russian) for explanation
+getWallReposts :: (MonadAPI m x s) => WallRecord -> API m x [WallRecord]
+getWallReposts wr = do
+ modified_reposts <- apiSimple "wall.getReposts" $
+ [ ("owner_id",tshow (wr_owner_id wr))
+ , ("post_id",tshow (wr_id wr))
+ , ("count",tshow max_count)
+ ]
+
+ (Sized cnt owners :: Sized [Int]) <-
+ apiSimple "likes.getList" $
+ [ ("type","post")
+ , ("owner_id",tshow (wr_owner_id wr))
+ , ("item_id",tshow (wr_id wr))
+ , ("filter","copies")
+ , ("count",tshow max_count)
+ ]
+
+ unmodified_reposts <-
+ concat <$> do
+ forM owners $ \o -> do
+ (Sized _ wrs) <- getWall o 20
+ return [ x | x <- wrs, (wr_id wr) `elem`(map wr_id (wr_copy_history x))]
+ return $ (rr_items modified_reposts) <> unmodified_reposts
-- TODO: Take User as argument for more type-safety
getAlbums :: (MonadAPI m x s) => Maybe Integer -> API m x (Sized [Album])
getAlbums muid =
- apiSimple "photos.getAlbums" $
- (case muid of
- Just uid -> [("owner_id", tshow uid)]
- Nothing -> [])
- <>
- [("need_system", "1")
- ]
+ apiSimpleH "photos.getAlbums"
+ ((case muid of
+ Just uid -> [("owner_id", tshow uid)]
+ Nothing -> [])
+ <>
+ [("need_system", "1")])
+ id
+ (\APIErrorRecord{..} ->
+ case er_code of
+ AccessDenied -> Right (Sized 0 [])
+ _ -> Left ""
+ )
getPhotoUploadServer :: (MonadAPI m x s) => Album -> API m x PhotoUploadServer
getPhotoUploadServer Album{..} =
apiSimple "photos.getUploadServer" [("album_id", tshow al_id)]
+getUsers :: (MonadAPI m x s) => [UserId] -> API m x [UserRecord]
+getUsers [] = return []
+getUsers uids = do
+ apiSimple "users.get" [
+ ("user_ids", Text.intercalate "," [tshow x | UserId x <- uids])
+ , ("fields", users_fields)
+ ]
+
+-- | Get current user
getCurrentUser :: (MonadAPI m x s) => API m x UserRecord
getCurrentUser = do
- apiSimpleF "users.get" [] $ \users ->
- case (length users == 1) of
- False -> Left "getCurrentUser: array with one user record"
- True -> Right (head users)
-
+ trace (\UserRecord{..} -> "getCurrentUser: returned " <> tshow ur_uid) $ do
+ users <- apiSimple "users.get" []
+ case (length users == 1) of
+ False -> terminate $ APIFailed $ APIUnexpected "users.get" "should be and array containing a single user record"
+ True -> return $ head users
-- * FIXME move low-level upload code to API.Base
setUserPhoto :: (MonadAPI m x s) => UserRecord -> FilePath -> API m x ()
setUserPhoto UserRecord{..} photo_path = do
OwnerUploadServer{..} <-
- resp_data <$> api "photos.getOwnerPhotoUploadServer"
- [("owner_id", tshow ur_id)]
- req <- ensure $ requestUploadPhoto ous_upload_url photo_path
- (res, _) <- requestExecute req
- j@JSON{..} <- decodeJSON (responseBody res)
- liftIO $ BS.putStrLn $ (responseBody res)
- UploadRecord{..} <-
- case Aeson.parseEither Aeson.parseJSON js_aeson of
- Right a -> return a
- Left e -> terminate (JSONParseFailure' j e)
- Response{..} <- api "photos.saveOwnerPhoto"
- [("server", tshow upl_server)
- ,("hash", upl_hash)
- ,("photo", upl_photo)]
- PhotoSaveResult{..} <- pure resp_data
+ (fst . resp_data) <$> apiSimple "photos.getOwnerPhotoUploadServer"
+ [("owner_id", tshow $ uid_id $ ur_uid)]
+
+ UploadRecord{..} <- upload ous_upload_url photo_path
+
+ APIResponse{..} <- apiSimple "photos.saveOwnerPhoto"
+ [ ("server", tshow upl_server)
+ , ("hash", upl_hash)
+ , ("photo", upl_photo)
+ ]
+ PhotoSaveResult{..} <- pure (fst resp_data)
return ()
+
+getGroupMembersN :: (MonadAPI m x s) => Integer -> GroupId -> API m x [UserId]
+getGroupMembersN offset GroupId{..} =
+ trace (\uids ->
+ "getGroupMembers: group " <> tshow gid_id <>
+ " offset " <> tshow offset <>
+ " includes : " <> (
+ case length uids < 10 of
+ True -> tshow uids
+ False -> tshow (length uids) <> " users")
+ ) $ do
+ m_items <$>
+ (apiSimple "groups.getMembers"
+ [ ("group_id", tshow gid_id)
+ , ("offset", tshow offset)
+ , ("count", tshow max_count)
+ , ("fileds", "bdate,city,education")
+ ])
+
+getGroupMembers :: (MonadAPI m x s) => GroupId -> API m x [UserId]
+getGroupMembers = getGroupMembersN 0
+
+
diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs
index e9dae6a..ba94472 100644
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -1,6 +1,8 @@
--- | This module contains base VK API types
+-- | This module contains wrappers for common API data types. The collection is
+-- incomplete and may be out of date, since API is evolving constantly. Users
+-- should consider extending this set by their own per-task definitions.
--
--- See [VK development docs](https://vk.com/dev) for the details
+-- See [VK development docs](https://vk.com/dev) for the official documentation
--
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -8,7 +10,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Web.VKHS.API.Types where
@@ -19,27 +23,21 @@ import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Vector as Vector (head, tail)
-import Web.VKHS.Imports
-import Web.VKHS.Error
import Web.VKHS.Types
+import Web.VKHS.Imports
-data Response a = Response {
- resp_json :: JSON
- , resp_data :: a
- } deriving (Show, Functor, Data, Typeable)
+import Web.VKHS.API.Base
-emptyResponse :: (Monoid a) => Response a
-emptyResponse = Response (JSON $ Aeson.object []) mempty
+data APIUrl = APIUrl { aurl_str :: Text }
+ deriving(Show, Eq, Ord, Data, Typeable, Generic, Hashable)
-parseJSON_obj_error :: String -> Aeson.Value -> Aeson.Parser a
-parseJSON_obj_error name o = fail $
- printf "parseJSON: %s expects object, got %s" (show name) (show o)
+instance FromJSON APIUrl where
+ parseJSON j = APIUrl <$> Aeson.parseJSON j
-instance (FromJSON a) => FromJSON (Response a) where
- parseJSON j = Aeson.withObject "Response" (\o ->
- Response <$> pure (JSON j) <*> (o .: "error" <|> o .: "response")) j
+printAPIUrl :: APIUrl -> Text
+printAPIUrl APIUrl{..} = aurl_str
--- | DEPRECATED, use @Sized@ instead
+{-# DEPRECATED SizedList "a) Use Sized instead. b) newer API verison may not need this" #-}
data SizedList a = SizedList Int [a]
deriving(Show, Data, Typeable)
@@ -49,6 +47,7 @@ instance (FromJSON a) => FromJSON (SizedList a) where
t <- Aeson.parseJSON (Aeson.Array (Vector.tail v))
return (SizedList n t)
+{-# DEPRECATED MusicRecord "music API was disabled by VK, unfortunately" #-}
data MusicRecord = MusicRecord
{ mr_id :: Int
, mr_owner_id :: Int
@@ -75,12 +74,57 @@ instance FromJSON MusicRecord where
-}
+data RepostRecord = RepostRecord {
+ rr_items :: [WallRecord]
+ , rr_groups :: [GroupRecord]
+ , rr_profiles :: [UserRecord]
+ }
+ deriving (Show, Data, Typeable)
+
+instance FromJSON RepostRecord where
+ parseJSON = Aeson.withObject "RepostRecord" $ \o ->
+ RepostRecord
+ <$> (o .: "items")
+ <*> (o .: "groups")
+ <*> (o .: "profiles")
+
+data UserId = UserId { uid_id :: Integer }
+ deriving(Show, Data, Eq, Ord, Typeable, Generic, Hashable)
+
+instance FromJSON UserId where
+ parseJSON j = UserId <$> (Aeson.parseJSON j)
+
+data Sex = Male | Female | Undefined
+ deriving(Show, Data, Eq, Ord, Typeable, Generic, Hashable)
+
+instance FromJSON Sex where
+ parseJSON j = do
+ Aeson.parseJSON j >>= \case
+ 1 -> return Female
+ 2 -> return Male
+ (_::Integer) -> return Undefined
+
+sexId :: Sex -> Integer
+sexId Male = 2
+sexId Female = 1
+sexId _ = 0
+
data UserRecord = UserRecord
- { ur_id :: Integer
+ { ur_uid :: UserId
, ur_first_name :: Text
, ur_last_name :: Text
, ur_deactivated :: Maybe Text
, ur_hidden :: Maybe Integer
+ , ur_city :: Maybe City
+ , ur_country :: Maybe Country
+ , ur_bdate :: Maybe Text
+ , ur_education :: Maybe Text
+ , ur_sex :: Maybe Sex
+ , ur_photo_50 :: Maybe APIUrl
+ , ur_photo_100 :: Maybe APIUrl
+ , ur_photo_200 :: Maybe APIUrl
+ , ur_photo_400_orig :: Maybe APIUrl
+ , ur_photo_max :: Maybe APIUrl
-- , ur_photo :: String
-- , ur_university :: Maybe Int
-- , ur_university_name :: Maybe String
@@ -92,37 +136,34 @@ data UserRecord = UserRecord
instance FromJSON UserRecord where
parseJSON = Aeson.withObject "UserRecord" $ \o ->
UserRecord
- <$> (o .: "id")
+ <$> (UserId <$> (o .: "id"))
<*> (o .: "first_name")
<*> (o .: "last_name")
<*> (o .:? "deactivated")
<*> (o .:? "hidden")
-
-data ErrorCode =
- AccessDenied
- | NotLoggedIn
- | TooManyRequestsPerSec
- | ErrorCode Scientific
- deriving(Show,Read, Eq, Ord)
-
-instance FromJSON ErrorCode where
- parseJSON = Aeson.withScientific "ErrorCode" $ \n ->
- case n of
- 5 -> return NotLoggedIn
- 6 -> return TooManyRequestsPerSec
- 15 -> return AccessDenied
- x -> return (ErrorCode x)
-
-data ErrorRecord = ErrorRecord
- { er_code :: ErrorCode
- , er_msg :: Text
- } deriving(Show)
-
-instance FromJSON ErrorRecord where
- parseJSON = Aeson.withObject "ErrorRecord" $ \o ->
- ErrorRecord
- <$> (o .: "error_code")
- <*> (o .: "error_msg")
+ <*> (o .:? "city")
+ <*> (o .:? "country")
+ <*> (o .:? "bdate")
+ <*> (o .:? "education")
+ <*> (o .:? "sex")
+ <*> (o .:? "photo_50")
+ <*> (o .:? "photo_100")
+ <*> (o .:? "photo_200")
+ <*> (o .:? "photo_400_orig")
+ <*> (o .:? "photo_max")
+
+printUserBio :: UserRecord -> Text
+printUserBio UserRecord{..} =
+ printUserUrl ur_uid <> " " <>
+ "name \""<> ur_first_name <> " " <> ur_last_name <> "\" " <>
+ "birth \"" <> (maybe "?" id ur_bdate) <> "\" " <>
+ "city \"" <> (maybe "?" (c_title) ur_city) <> "\""
+
+userUrl :: UserId -> APIUrl
+userUrl (UserId x) = APIUrl $ "https://vk.com/id" <> tshow x
+
+printUserUrl :: UserId -> Text
+printUserUrl (UserId x) = printAPIUrl $ APIUrl $ "https://vk.com/id" <> tshow x
-- | Wall post representation (partial)
--
@@ -130,22 +171,29 @@ instance FromJSON ErrorRecord where
data WallRecord = WallRecord
{ wr_id :: Int
, wr_from_id :: Int
+ , wr_owner_id :: Int
, wr_text :: Text
, wr_date :: Int
- } deriving (Show)
+ , wr_posttype :: Text
+ , wr_attachments_json :: Maybe JSON
+ , wr_copy_history :: [WallRecord]
+ } deriving (Eq, Show, Data, Typeable)
instance FromJSON WallRecord where
parseJSON = Aeson.withObject "WallRecord" $ \o ->
WallRecord
<$> (o .: "id")
<*> (o .: "from_id")
+ <*> (o .: "owner_id" <|> o .: "to_id")
<*> (o .: "text")
<*> (o .: "date")
+ <*> (o .: "post_type")
+ <*> (o .:? "attachments")
+ <*> (fromMaybe [] <$> (o .:? "copy_history"))
publishedAt :: WallRecord -> UTCTime
publishedAt wr = posixSecondsToUTCTime $ fromIntegral $ wr_date wr
-
data Sized a = Sized {
m_count :: Int
, m_items :: a
@@ -160,30 +208,34 @@ instance Monoid a => Monoid (Sized a) where
mappend (Sized x a) (Sized y b) = Sized (x+y) (a<>b)
data Deact = Banned | Deleted | OtherDeact Text
- deriving(Show,Eq,Ord)
+ deriving(Show,Eq,Ord,Data,Typeable)
instance FromJSON Deact where
parseJSON = Aeson.withText "Deact" $ \x ->
return $ case x of
"deleted" -> Deleted
"banned" -> Banned
- x -> OtherDeact x
+ other -> OtherDeact other
data GroupType = Group | Event | Public
- deriving(Show,Eq,Ord)
+ deriving(Show,Eq,Ord,Data,Typeable)
instance FromJSON GroupType where
parseJSON = Aeson.withText "GroupType" $ \x ->
- return $ case x of
- "group" -> Group
- "page" -> Public
- "event" -> Event
+ case x of
+ "group" -> return Group
+ "page" -> return Public
+ "event" -> return Event
+ _ -> fail $ "Invalid GroupType: '" <> tunpack x <> "'"
data GroupIsClosed = GroupOpen | GroupClosed | GroupPrivate
- deriving(Show,Eq,Ord,Enum)
+ deriving(Show,Eq,Ord,Enum,Data,Typeable)
+
+data GroupId = GroupId { gid_id :: Integer }
+ deriving(Show,Eq,Ord,Data,Typeable,Generic,Hashable)
data GroupRecord = GroupRecord {
- gr_id :: Int
+ gr_gid :: GroupId
, gr_name :: Text
, gr_screen_name :: Text
, gr_is_closed :: GroupIsClosed
@@ -195,18 +247,18 @@ data GroupRecord = GroupRecord {
, gr_invited_by :: Maybe Int
, gr_type :: GroupType
, gr_has_photo :: Bool
- , gr_photo_50 :: String
- , gr_photo_100 :: String
- , gr_photo_200 :: String
+ , gr_photo_50 :: Maybe APIUrl
+ , gr_photo_100 :: Maybe APIUrl
+ , gr_photo_200 :: Maybe APIUrl
-- arbitrary fields
, gr_can_post :: Maybe Bool
, gr_members_count :: Maybe Int
- } deriving (Show)
+ } deriving (Show, Data, Typeable)
instance FromJSON GroupRecord where
parseJSON = Aeson.withObject "GroupRecord" $ \o ->
GroupRecord
- <$> (o .: "id")
+ <$> (GroupId <$> (o .: "id"))
<*> (o .: "name")
<*> (o .: "screen_name")
<*> fmap toEnum (o .: "is_closed")
@@ -218,23 +270,32 @@ instance FromJSON GroupRecord where
<*> (o .:? "invited_by")
<*> (o .: "type")
<*> (o .:? "has_photo" .!= False)
- <*> (o .: "photo_50")
- <*> (o .: "photo_100")
- <*> (o .: "photo_200")
+ <*> (o .:? "photo_50")
+ <*> (o .:? "photo_100")
+ <*> (o .:? "photo_200")
<*> (fmap (==(1::Int)) <$> (o .:? "can_post"))
<*> (o .:? "members_count")
-groupURL :: GroupRecord -> String
-groupURL GroupRecord{..} = "https://vk.com/" ++ urlify gr_type ++ (show gr_id) where
+groupURL :: GroupRecord -> APIUrl
+groupURL GroupRecord{..} = APIUrl $ "https://vk.com/" <> urlify gr_type <> (tshow $ gid_id $ gr_gid) where
urlify Group = "club"
urlify Event = "event"
urlify Public = "page"
+printGroupUrl :: GroupRecord -> Text
+printGroupUrl = printAPIUrl . groupURL
+
+data CountryId = CountryId {
+ coid_id :: Integer
+} deriving(Show,Data,Typeable,Generic,Hashable)
+
+instance FromJSON CountryId where
+ parseJSON j = CountryId <$> Aeson.parseJSON j
data Country = Country {
- co_int :: Integer
+ co_coid :: CountryId
, co_title :: Text
-} deriving(Show)
+} deriving(Show,Data,Typeable)
instance FromJSON Country where
parseJSON = Aeson.withObject "Country" $ \o ->
@@ -242,13 +303,12 @@ instance FromJSON Country where
<$> (o .: "id")
<*> (o .: "title")
-
data City = City {
c_city_id :: Integer
, c_title :: Text
, c_maybe_area :: Maybe Text
, c_maybe_region :: Maybe Text
-} deriving(Show)
+} deriving(Show,Data,Typeable)
instance FromJSON City where
parseJSON = Aeson.withObject "City" $ \o ->
@@ -283,7 +343,7 @@ instance FromJSON PhotoUploadServer where
<*> (o .: "user_id")
data OwnerUploadServer = OwnerUploadServer {
- ous_upload_url :: Text
+ ous_upload_url :: HRef
} deriving(Show, Data, Typeable)
instance FromJSON OwnerUploadServer where
@@ -291,19 +351,6 @@ instance FromJSON OwnerUploadServer where
OwnerUploadServer
<$> (o .: "upload_url")
-data UploadRecord = UploadRecord {
- upl_server :: Integer
- , upl_photo :: Text
- , upl_hash :: Text
- } deriving(Show, Data, Typeable)
-
-instance FromJSON UploadRecord where
- parseJSON = Aeson.withObject "UploadRecord" $ \o ->
- UploadRecord
- <$> (o .: "server")
- <*> (o .: "photo")
- <*> (o .: "hash")
-
data PhotoSaveResult = PhotoSaveResult {
diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs
index a56734e..63b2b26 100644
--- a/src/Web/VKHS/Client.hs
+++ b/src/Web/VKHS/Client.hs
@@ -8,6 +8,20 @@
{-# LANGUAGE ScopedTypeVariables #-}
module Web.VKHS.Client where
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+import qualified Data.ByteString.Char8 as BS
+import qualified Network.HTTP.Types as Client
+import qualified Network.HTTP.Client as Client
+import qualified Network.HTTP.Client.Internal as Client
+import qualified Network.URI as Client
+import qualified Network.Shpider.Forms as Shpider
+import qualified Network.HTTP.Client.MultipartFormData as Multipart
+import qualified Pipes as Pipes (Producer, for, runEffect, (>->))
+import qualified Pipes.HTTP as Pipes hiding (Request, Response)
+import qualified Text.Parsec as Parsec
+
import Data.List
import Data.Maybe
import Data.Time
@@ -19,44 +33,22 @@ import Control.Monad
import Control.Monad.State
import Control.Monad.Cont
import Data.Default.Class
-import qualified Data.CaseInsensitive as CI
import Data.Map (Map)
-import qualified Data.Map as Map
import Data.List.Split
import Data.Text(Text)
-import qualified Data.Text as Text
import Control.Concurrent (threadDelay)
import System.IO as IO
import System.IO.Unsafe as IO
import System.Clock as Clock
-
import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as BS
-
import Network.HTTP.Client ()
-import qualified Network.HTTP.Client.MultipartFormData as Multipart
import Network.HTTP.Client.Internal (setUri)
import Network.HTTP.Client.TLS (tlsManagerSettings)
-import qualified Network.HTTP.Types as Client
-import qualified Network.HTTP.Client as Client
-import qualified Network.HTTP.Client.Internal as Client
-import qualified Network.URI as Client
-import qualified Network.Shpider.Forms as Shpider
-
import Pipes.Prelude as PP (foldM)
-import qualified Pipes as Pipes (Producer(..), for, runEffect, (>->))
-import qualified Pipes.HTTP as Pipes hiding (Request, Response)
-
-import qualified Text.Parsec as Parsec
-
import Debug.Trace
import Web.VKHS.Types
-data Error = ErrorParseURL { euri :: String, emsg :: String }
- | ErrorSetURL { eurl :: URL, emsg :: String }
- deriving(Show, Eq)
-
{-
__ __ _
| \/ | ___ _ __ __ _ __| |
@@ -72,16 +64,16 @@ data ClientState = ClientState {
, cl_verbose :: Bool
}
-defaultState :: GenericOptions -> IO ClientState
-defaultState GenericOptions{..} = do
+defaultClientState :: GenericOptions -> IO ClientState
+defaultClientState GenericOptions{..} = do
cl_man <- Client.newManager
(Client.managerSetProxy (Client.proxyEnvironment Nothing)
(case o_use_https of
True -> tlsManagerSettings
False -> Client.defaultManagerSettings))
cl_last_execute <- pure (TimeSpec 0 0)
- cl_minimum_interval_ns <- pure (round (10^9 / o_max_request_rate_per_sec))
- cl_verbose <- pure o_verbose
+ cl_minimum_interval_ns <- pure (round ((((10::Rational)^(9::Integer))) / o_max_request_rate_per_sec))
+ cl_verbose <- pure (o_verbosity == Debug)
return ClientState{..}
class ToClientState s where
@@ -90,23 +82,13 @@ class ToClientState s where
class (MonadIO m, MonadState s m, ToClientState s) => MonadClient m s | m -> s
--- newtype ClientT m a = ClientT { unClient :: StateT ClientState m a }
--- deriving(Functor, Applicative, Monad, MonadState ClientState, MonadIO)
-
--- runClient :: (MonadIO m) => ClientT m a -> m a
--- runClient l = do
--- cl_man <- liftIO $ newManager defaultManagerSettings
--- evalStateT (unClient l) ClientState{..}
-
--- liftClient :: (Monad m) => m a -> ClientT m a
--- liftClient = ClientT . lift
-
{-
_ _ ____ _
| | | | _ \| |
| | | | |_) | |
| |_| | _ <| |___
\___/|_| \_\_____|
+
-}
newtype URL_Protocol = URL_Protocol { urlproto :: String }
@@ -120,23 +102,19 @@ newtype URL_Port = URL_Port { urlp :: String }
newtype URL_Path = URL_Path { urlpath :: String }
deriving(Show)
--- | URL wrapper
-newtype URL = URL { uri :: Client.URI }
- deriving(Show, Eq)
-
-- * 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
+ esc x = Client.escapeURIString (\c -> Client.isAllowedInURI c && (not (Client.isReserved c))) x
-urlCreate :: URL_Protocol -> URL_Host -> Maybe URL_Port -> URL_Path -> URL_Query -> Either Error URL
+urlCreate :: URL_Protocol -> URL_Host -> Maybe URL_Port -> URL_Path -> URL_Query -> URL
urlCreate URL_Protocol{..} URL_Host{..} port URL_Path{..} URL_Query{..} =
- pure $ URL $ Client.URI (urlproto ++ ":") (Just (Client.URIAuth "" urlh (maybe "" ((":"++).urlp) port))) urlpath urlq []
+ URL $ Client.URI (urlproto ++ ":") (Just (Client.URIAuth "" urlh (maybe "" ((":"++).urlp) port))) urlpath urlq []
-urlFromString :: String -> Either Error URL
+urlFromString :: String -> Either ClientError URL
urlFromString s =
case Client.parseURI s of
- Nothing -> Left (ErrorParseURL s "Client.parseURI failed")
+ Nothing -> Left (ErrorParseURL (Text.pack s) "Client.parseURI failed")
Just u -> Right (URL u)
-- | * FIXME Convert to ByteString / Text
@@ -152,7 +130,7 @@ splitFragments sep eqs =
f (x:xs) = (trim x, trim $ intercalate eqs xs)
trim = rev (dropWhile (`elem` (" \t\n\r" :: String)))
- where rev f = reverse . f . reverse . f
+ where rev g = reverse . g . reverse . g
-- | * FIXME Convert to ByteString / Text
urlFragments :: URL -> [(String,String)]
@@ -169,7 +147,7 @@ urlFragments URL{..} = splitFragments "&" "=" $ unsharp $ Client.uriFragment ur
-}
data Cookies = Cookies { jar :: Client.CookieJar }
- deriving(Show,Eq)
+ deriving(Show, Read, Eq)
cookiesCreate :: () -> Cookies
cookiesCreate () = Cookies (Client.createCookieJar [])
@@ -182,13 +160,13 @@ cookiesCreate () = Cookies (Client.createCookieJar [])
|_| |_| |_| |_| |_|
-}
-data Request = Request {
+data ClientRequest = ClientRequest {
req :: Client.Request
, req_jar :: Client.CookieJar
}
-- | Create HTTP(S) GET request
-requestCreateGet :: (MonadClient m s) => URL -> Cookies -> m (Either Error Request)
+requestCreateGet :: (MonadClient m s) => URL -> Cookies -> m (Either ClientError ClientRequest)
requestCreateGet URL{..} Cookies{..} = do
case setUri Client.defaultRequest uri of
Left exc -> do
@@ -197,7 +175,7 @@ requestCreateGet URL{..} Cookies{..} = do
Right r -> do
now <- liftIO getCurrentTime
(r',_) <- pure $ Client.insertCookiesIntoRequest r jar now
- return $ Right $ Request {
+ return $ Right $ ClientRequest {
req = r'{
Client.redirectCount = 0
},
@@ -205,76 +183,76 @@ requestCreateGet URL{..} Cookies{..} = do
}
-- | Create HTTP(S) POST request
-requestCreatePost :: (MonadClient m s) => FilledForm -> Cookies -> m (Either Error Request)
+requestCreatePost :: (MonadClient m s) => FilledForm -> Cookies -> m (Either ClientError ClientRequest)
requestCreatePost (FilledForm tit Shpider.Form{..}) c = do
case Client.parseURI (Client.escapeURIString Client.isAllowedInURI action) of
- Nothing -> return (Left (ErrorParseURL action "parseURI failed"))
+ Nothing -> return (Left (ErrorParseURL (Text.pack action) "parseURI failed"))
Just action_uri -> do
r <- requestCreateGet (URL action_uri) c
case r of
Left err -> do
return $ Left err
- Right Request{..} -> do
- return $ Right $ Request (Client.urlEncodedBody (map (BS.pack *** BS.pack) $ Map.toList inputs) req) req_jar
+ Right ClientRequest{..} -> do
+ return $ Right $ ClientRequest (Client.urlEncodedBody (map (BS.pack *** BS.pack) $ Map.toList inputs) req) req_jar
-- | Upload the bytestring data @bs@ to the server @text_url@
--
-- * FIXME Use 'URL' rather than Text. Think about
-- https://github.com/blamario/network-uri
--
-requestUploadPhoto :: (MonadClient m s) => Text -> String -> m (Either Error Request)
-requestUploadPhoto text_url bs = do
- case Client.parseURI (Text.unpack text_url) of
- Nothing -> return (Left (ErrorParseURL (Text.unpack text_url) "parseURI failed"))
+requestUploadPhoto :: (MonadClient m s) => HRef -> String -> m (Either ClientError ClientRequest)
+requestUploadPhoto HRef{..} bs = do
+ case Client.parseURI (Text.unpack href) of
+ Nothing -> return (Left (ErrorParseURL href "parseURI failed"))
Just uri -> do
r <- requestCreateGet (URL uri) (cookiesCreate ())
case r of
Left err -> do
return $ Left err
- Right Request{..} -> do
+ Right ClientRequest{..} -> do
req' <- Multipart.formDataBody [Multipart.partFile "photo" bs] req
- return $ Right $ Request req' req_jar
+ return $ Right $ ClientRequest req' req_jar
-data Response = Response {
+data ClientResponse = ClientResponse {
resp :: Client.Response (Pipes.Producer ByteString IO ())
, resp_body :: ByteString
}
-responseBodyS :: Response -> String
-responseBodyS Response{..} = BS.unpack $ resp_body
+responseBodyS :: ClientResponse -> String
+responseBodyS ClientResponse{..} = BS.unpack $ resp_body
-responseBody :: Response -> ByteString
-responseBody Response{..} = resp_body
+responseBody :: ClientResponse -> ByteString
+responseBody ClientResponse{..} = resp_body
-dumpResponseBody :: (MonadClient m s) => FilePath -> Response -> m ()
-dumpResponseBody f Response{..} = liftIO $ BS.writeFile f resp_body
+dumpResponseBody :: (MonadClient m s) => FilePath -> ClientResponse -> m ()
+dumpResponseBody f ClientResponse{..} = liftIO $ BS.writeFile f resp_body
-responseCookies :: Response -> Cookies
-responseCookies Response{..} = Cookies (Client.responseCookieJar resp)
+responseCookies :: ClientResponse -> Cookies
+responseCookies ClientResponse{..} = Cookies (Client.responseCookieJar resp)
-responseHeaders :: Response -> [(String,String)]
-responseHeaders Response{..} =
+responseHeaders :: ClientResponse -> [(String,String)]
+responseHeaders ClientResponse{..} =
map (\(o,h) -> (BS.unpack (CI.original o), BS.unpack h)) $ Client.responseHeaders resp
-responseCode :: Response -> Int
-responseCode Response{..} = Client.statusCode $ Client.responseStatus resp
+responseCode :: ClientResponse -> Int
+responseCode ClientResponse{..} = Client.statusCode $ Client.responseStatus resp
-responseCodeMessage :: Response -> String
-responseCodeMessage Response{..} = BS.unpack $ Client.statusMessage $ Client.responseStatus resp
+responseCodeMessage :: ClientResponse -> String
+responseCodeMessage ClientResponse{..} = BS.unpack $ Client.statusMessage $ Client.responseStatus resp
-responseRedirect :: Response -> Maybe URL
+responseRedirect :: ClientResponse -> Maybe URL
responseRedirect r =
case lookup "Location" (responseHeaders r) of
Just loc -> URL <$> Client.parseURI loc
Nothing -> Nothing
-responseOK :: Response -> Bool
+responseOK :: ClientResponse -> Bool
responseOK r = c == 200 where
c = responseCode r
-- | Execute the 'Request' created by 'requestCreatePost' or 'requestCreateGet'
-requestExecute :: (MonadClient m s) => Request -> m (Response, Cookies)
-requestExecute Request{..} = do
+requestExecute :: (MonadClient m s) => ClientRequest -> m (ClientResponse, Cookies)
+requestExecute ClientRequest{..} = do
jar <- pure req_jar
ClientState{..} <- toClientState <$> get
clk <- liftIO $ do
@@ -293,13 +271,13 @@ requestExecute Request{..} = do
Pipes.withHTTP req cl_man $ \resp -> do
resp_body <- PP.foldM (\a b -> return $ BS.append a b) (return BS.empty) return (Client.responseBody resp)
now <- getCurrentTime
- let (jar', resp') = Client.updateCookieJar resp req now jar
- return (Response resp resp_body, Cookies jar')
+ let (jar', _) = Client.updateCookieJar resp req now jar
+ return (ClientResponse resp resp_body, Cookies jar')
-- | Download helper
downloadFileWith :: (MonadClient m s) => URL -> (ByteString -> IO ()) -> m ()
downloadFileWith url h = do
(ClientState{..}) <- toClientState <$> get
- (Right Request{..}) <- requestCreateGet url (cookiesCreate ())
+ (Right ClientRequest{..}) <- requestCreateGet url (cookiesCreate ())
liftIO $ Pipes.withHTTP req cl_man $ \resp -> do
PP.foldM (\() a -> h a) (return ()) (const (return ())) (Client.responseBody resp)
diff --git a/src/Web/VKHS/Coroutine.hs b/src/Web/VKHS/Coroutine.hs
new file mode 100644
index 0000000..f98564d
--- /dev/null
+++ b/src/Web/VKHS/Coroutine.hs
@@ -0,0 +1,438 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | TODO: Rename to Coroutine.hs
+module Web.VKHS.Coroutine where
+
+import qualified Text.HTML.TagSoup.Parsec as Tagsoup
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Encode.Pretty as Aeson
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified Network.Shpider.Forms as Shpider
+import qualified System.Process as Process
+
+import qualified Web.VKHS.Client as Client
+import qualified Web.VKHS.Login as Login
+import qualified Web.VKHS.API as API
+
+import Web.VKHS.Types
+import Web.VKHS.Imports
+import Web.VKHS.Client (ToClientState(..), ClientState(..), MonadClient,
+ urlCreate, URL_Protocol(..), URL_Host(..), URL_Port(..), URL_Path(..),
+ buildQuery, requestCreateGet, cookiesCreate, requestExecute, requestUploadPhoto,
+ responseBody, requestExecute, defaultClientState, dumpResponseBody, requestCreatePost)
+import Web.VKHS.Login (MonadLogin, LoginState(..), ToLoginState(..), printForm, loginRoutine, LoginRoutine(..), L,
+ defaultLoginState, RobotAction(..), printAction, ensureClient)
+import Web.VKHS.API (MonadAPI, APIState(..), ToAPIState(..), APIResponse(..), APIRoutine(..), R, defaultAPIState)
+
+-- | Main state of the VK monad stack. Consists of lesser states plus a copy of
+-- generic options provided by the caller.
+data VKState = VKState {
+ cs :: ClientState
+ , ls :: LoginState
+ , as :: APIState
+ , go :: GenericOptions
+ }
+
+instance ToLoginState VKState where
+ toLoginState = ls
+ modifyLoginState f = \s -> s { ls = f (ls s) }
+instance ToClientState VKState where
+ toClientState = cs
+ modifyClientState f = \s -> s { cs = f (cs s) }
+instance API.ToAPIState VKState where
+ toAPIState = as
+ modifyAPIState f = \s -> s { as = f (as s) }
+instance ToGenericOptions VKState where
+ toGenericOptions = go
+
+-- | Initial State constructor
+initialState :: (MonadIO m) => GenericOptions -> m VKState
+initialState go = VKState
+ <$> liftIO (defaultClientState go)
+ <*> pure (defaultLoginState go)
+ <*> pure (defaultAPIState)
+ <*> pure go
+
+type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a
+
+-- | Main VK monad transformer able to raise errors, track 'VKState', set
+-- coroutine-style exit with continuation by the means of continuation monad.
+-- Technicaly, this monad encodes a coroutine with entry points defined by
+-- `APIRoutine` datatype.
+--
+-- See also `runVK` and `apiSupervisor`
+--
+-- FIXME * Re-write using modern `Monad.Free`
+newtype VKT m r a = VKT { unVKT :: Guts (VKT m) (StateT VKState (ExceptT VKError m)) r a }
+ deriving(MonadIO, Functor, Applicative, Monad, MonadReader (r -> VKT m r r), MonadCont)
+
+
+
+-- | Alias for IO-based monad stack
+type VK r a = VKT IO r a
+
+instance (MonadIO m) => MonadVK (VKT m r) r VKState where
+ getVKState = VKT $ get
+ putVKState = VKT . put
+
+-- instance (MonadIO m) => MonadClient (VKT m r) VKState
+instance (MonadIO m) => MonadLogin (VKT m) r VKState
+instance (MonadIO m) => MonadAPI (VKT m) r VKState
+instance (MonadIO m) => MonadClient (StateT VKState (ExceptT VKError m)) VKState
+
+instance (MonadState s m) => MonadState s (VKT m r) where
+ get = VKT $ lift $ lift $ lift $ lift $ get
+ put = VKT . lift . lift . lift . lift . put
+
+printAPIError :: APIError -> Text
+printAPIError = \case
+ APIInvalidJSON mname json t ->
+ "Method \"" <> tpack mname <> "\": invalid json (" <> jsonEncode json <> ")"
+ APIUnhandledError mname erec t ->
+ "Method \"" <> tpack mname <> "\": server responded with error (" <> tshow erec <> ")"
+ APIUnexpected mname t ->
+ "Method \"" <> tpack mname <> "\": unexpected condition (" <> t <> ")"
+
+printClientError :: ClientError -> Text
+printClientError = \case
+ ErrorParseURL{..} -> "Invalid HTTP url \"" <> euri <> "\""
+ ErrorSetURL{..} -> "Invalid URL \"" <> tshow eurl <> "\""
+
+printLoginError :: LoginError -> Text
+printLoginError = \case
+ LoginNoAction -> "No obvious login action left"
+ LoginClientError e -> "Failed to login due to client error: " <> printClientError e
+ LoginInvalidInputs Form{..} inputs ->
+ "Invalid values for " <> (tshow $ Set.toList inputs) <> " inputs of form \"" <> tpack form_title <> "\""
+
+data VKJSONError =
+ VKJSONDecodeError Text ByteString
+ | VKJSONParseError Text JSON
+ deriving(Show)
+
+printVKJSONError :: VKJSONError -> Text
+printVKJSONError = \case
+ VKJSONDecodeError err bsjson ->
+ "Failed to decode JSON: " <> err <> ":\n" <> bspack bsjson
+ VKJSONParseError err json ->
+ "Failed to parse JSON: " <> err <> ":\n" <> jsonEncodePretty json
+
+data VKError =
+ VKFormInputError Form Text
+ | VKLoginError LoginError
+ | VKLoginRequestError ClientError
+ | VKUploadError FilePath (Either ClientError VKJSONError)
+ | VKExecAPIError MethodName (Either ClientError VKJSONError)
+ | VKAPIError APIError
+ deriving(Show)
+
+printVKError :: VKError -> Text
+printVKError = \case
+ VKFormInputError Form{..} input ->
+ "No value to fill input \"" <> input <> "\" of form \"" <> tpack form_title <> "\""
+ VKLoginError e -> printLoginError e
+ VKUploadError fpath e ->
+ "Failed to upload file \"" <> tpack fpath <> "\": " <> either printClientError printVKJSONError e
+ VKExecAPIError mname e ->
+ "Failed execute method \"" <> tpack mname <> "\": " <> either printClientError printVKJSONError e
+ VKAPIError e ->
+ "API program failed: " <> printAPIError e
+ VKLoginRequestError ce ->
+ "Unable to execute login procedure, " <> printClientError ce
+
+llprompt :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
+llprompt str = do
+ liftIO $ Text.hPutStrLn stderr str
+ liftIO $ Text.hPutStr stderr "> "
+
+llmessage :: (ToGenericOptions s, MonadState s m, MonadIO m) => Verbosity -> Text -> m ()
+llmessage verb str = do
+ GenericOptions{..} <- gets toGenericOptions
+ when (verb <= o_verbosity) $ do
+ liftIO $ Text.hPutStrLn stderr str
+
+llalert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
+llalert str = llmessage Normal str
+
+lldebug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
+lldebug str = llmessage Debug str
+
+executeAPI :: (MonadIO m) => MethodName -> [(String,String)] -> StateT VKState (ExceptT VKError m) JSON
+executeAPI mname margs = do
+ lldebug $ "Executing API: " <> tpack mname
+
+ GenericOptions{..} <- gets toGenericOptions
+ APIState{..} <- gets toAPIState
+
+ let throwAPIError x = throwError (VKExecAPIError mname x)
+
+ let protocol = (case o_use_https of
+ True -> "https"
+ False -> "http")
+ url <- pure $ urlCreate
+ (URL_Protocol protocol)
+ (URL_Host o_api_host)
+ (Just (URL_Port (show o_port)))
+ (URL_Path ("/method/" ++ mname))
+ (buildQuery (("access_token", api_access_token):margs))
+
+ lldebug $ "> " <> (tshow url)
+
+ mreq <- requestCreateGet url (cookiesCreate ())
+ case mreq of
+ Left err -> do
+ throwAPIError (Left err)
+ Right req -> do
+ (res, jar') <- requestExecute req
+ bsjson <- pure $ responseBody res
+ case decodeJSON bsjson of
+ Left err -> do
+ throwAPIError (Right $ VKJSONDecodeError err bsjson)
+ Right json -> do
+ lldebug $ "< " <> jsonEncodePretty json
+
+ case parseJSON json of
+ Left err -> do
+ return json {- not an error -}
+
+ Right (APIResponse _ (APIErrorRecord{..},_)) -> do
+ case er_code of
+ NotLoggedIn -> do
+ llalert $ "Attempting to re-login"
+ at <- loginSupervisor (loginRoutine >>= return . LoginOK)
+ modifyAccessToken at
+ executeAPI mname margs
+
+ TooManyRequestsPerSec -> do
+ llalert $ "Too many requests per second, consider changing options"
+ executeAPI mname margs
+
+ _ -> do
+ return json {- Allow application to handle the code -}
+
+
+uploadFile :: (FromJSON b, MonadError VKError m, MonadClient m s) => HRef -> String -> m b
+uploadFile href filepath = do
+ mreq <- requestUploadPhoto href filepath
+ case mreq of
+ Left err ->
+ throwError $ VKUploadError filepath (Left err)
+ Right req -> do
+ (res, _) <- requestExecute req
+ bsjson <- pure $ responseBody res
+ case decodeJSON bsjson of
+ Left err -> do
+ throwError $ VKUploadError filepath (Right $ VKJSONDecodeError err bsjson)
+ Right json -> do
+ case parseJSON json of
+ Left err -> do
+ throwError $ VKUploadError filepath (Right $ VKJSONParseError err json)
+ Right urec -> do
+ return urec
+
+-- | Run the VK coroutine till next return. Consider using `runVK` for full
+-- spinup.
+stepVK :: (MonadIO m) => VKT m r r -> StateT VKState (ExceptT VKError m) r
+stepVK m = runContT (runReaderT (unVKT (catchVK m)) undefined) return
+
+
+loginSupervisor :: (MonadIO m, Show a) => VKT m (L (VKT m) a) (L (VKT m) a) -> StateT VKState (ExceptT VKError m) a
+loginSupervisor = go where
+ go m = do
+ let throwLoginError x = throwError (VKLoginRequestError x)
+ GenericOptions{..} <- toGenericOptions <$> get
+ res <- stepVK m
+ case res of
+
+ LoginOK a -> do
+ return a
+
+ LoginAskInput tags form@(Form tit f) i k ->
+ let
+ generic_filler = do
+ llprompt $ "Please, enter the value for input \"" <> tpack i <> "\""
+ v <- liftIO $ getLine
+ go (k v)
+
+ in do
+ lldebug $ "While filling form " <> (printForm "" f)
+ case (o_allow_interactive, i) of
+
+ (True,"captcha_key") -> do
+ case Shpider.gatherCaptcha tags of
+ Just c -> do
+ llprompt $ "Please fill the captcha " <> tshow c
+ _ <- liftIO $ Process.spawnCommand $ "curl '" <> c <> "' | feh -"
+ v <- liftIO $ getLine
+ go (k v)
+ Nothing ->
+ generic_filler
+ (True,_) -> generic_filler
+
+ (False,_) -> do
+ throwError (VKFormInputError form (tpack i))
+
+ LoginRequestExecute ra k -> do
+ case ra of
+ a@(DoGET url jar) -> do
+ lldebug (printAction "> " a)
+ mreq <- requestCreateGet url jar
+ case mreq of
+ Left err -> throwLoginError err
+ Right req -> do
+ (cres, jar') <- requestExecute req
+ dumpResponseBody "latest.html" cres
+ go (k (cres, jar'))
+
+ a@(DoPOST form jar) -> do
+ lldebug (printAction "> " a)
+ mreq <- requestCreatePost form jar
+ case mreq of
+ Left err -> throwLoginError err
+ Right req -> do
+ (cres, jar') <- requestExecute req
+ dumpResponseBody "latest.html" cres
+ go (k (cres, jar'))
+
+ LoginMessage verb text k -> do
+ llmessage verb text
+ go (k ())
+
+ LoginFailed e -> do
+ throwError $ VKLoginError e
+
+
+-- | Run VK monad @m@ and handle continuation requests using default
+-- algorithm. @apiSupervisor@ 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)
+apiSupervisor :: (MonadIO m, Show a) => VKT m (R (VKT m) a) (R (VKT m) a) -> StateT VKState (ExceptT VKError m) a
+apiSupervisor = go where
+ go m = do
+ GenericOptions{..} <- toGenericOptions <$> get
+ res <- stepVK m
+ case res of
+
+ Fine a -> do
+ return a
+
+ APIFailed e ->
+ throwError (VKAPIError e)
+
+ APIMessage verb text k -> do
+ llmessage verb text
+ go (k ())
+
+ ExecuteAPI (mname,margs) k -> do
+ json <- executeAPI mname (map (id *** tunpack) margs)
+ go (k json)
+
+ UploadFile (href,filepath) k -> do
+ urec <- uploadFile href filepath
+ go (k urec)
+
+ APILogin k -> do
+ at <- loginSupervisor (loginRoutine >>= return . LoginOK)
+ modifyAccessToken at
+ go (k at)
+
+-- | Run loginRoutine procedure using 'apiSupervisor'. Return 'AccessToken' on
+-- success
+runLogin :: GenericOptions -> ExceptT VKError IO AccessToken
+runLogin go = do
+ s <- initialState go
+ evalStateT (loginSupervisor (loginRoutine >>= return . LoginOK)) s
+
+-- | Run the VK monad @m@ using generic options @go@ and 'apiSupervisor'.
+-- Perform loginRoutine procedure if needed. This is an mid-layer runner, consider
+-- using 'runVK' instead.
+runAPI :: (MonadIO m, Show b) => GenericOptions -> VKT m (R (VKT m) b) b -> ExceptT VKError m b
+runAPI go@GenericOptions{..} m = do
+ s <- initialState go
+ flip evalStateT s $ do
+
+ readInitialAccessToken >>= \case
+ Nothing -> do
+ lldebug "No initial access token was read"
+ return ()
+ Just at -> do
+ modifyAccessToken at
+
+ apiSupervisor (m >>= return . Fine)
+
+-- | Run the VK monad @m@ using generic options @go@ and `apiSupervisor`
+runVK :: (MonadIO m, Show a) => GenericOptions -> VKT m (R (VKT m) a) a -> m (Either VKError a)
+runVK go = runExceptT . runAPI go
+
+-- | A version of `runVK` with unit return.
+runVK_ :: (MonadIO m, Show a) => GenericOptions -> VKT m (R (VKT m) a) a -> m ()
+runVK_ go = do
+ runVK go >=> \case
+ Left e -> fail (tunpack $ printVKError e)
+ Right _ -> return ()
+
+-- | Read the access token according with respect to user-defined parameters
+--
+-- See also `modifyAccessToken`
+--
+-- FIXME Move to Utils
+readInitialAccessToken :: (MonadIO m, MonadState s m, ToGenericOptions s) => m (Maybe AccessToken)
+readInitialAccessToken =
+ let
+ str2at s = Just (AccessToken s "<unknown>" "<unknown>")
+
+ safeReadFile fn = do
+ liftIO $ catch (Just <$> readFile fn) (\(e :: SomeException) -> return Nothing)
+
+ in do
+ GenericOptions{..} <- toGenericOptions <$> get
+ case l_access_token of
+ [] -> do
+ lldebug "Initial access token is empty"
+ case l_access_token_file of
+ [] -> do
+ lldebug "No access token file specified"
+ 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
+ lldebug $ "Unable to read access token from file '" <> tpack l_access_token_file <> "'"
+ return Nothing
+ _ -> do
+ return (str2at l_access_token)
+
+-- | Modify VK access token in the internal state and its external mirror
+-- if enabled, if any.
+--
+-- See also `readInitialAccessToken`
+modifyAccessToken :: (MonadIO m, MonadState s m, ToAPIState s) => AccessToken -> m ()
+modifyAccessToken at@AccessToken{..} = do
+ lldebug $ "Modifying access token, new value: " <> tshow at
+ modify $ modifyAPIState (\as -> as{api_access_token = at_access_token})
+ GenericOptions{..} <- toGenericOptions <$> get
+ case l_access_token_file of
+ [] -> return ()
+ fl -> do
+ lldebug $ "Writing access token to file '" <> tpack l_access_token_file <> "'"
+ liftIO $ writeFile l_access_token_file (show at)
+ return ()
+
diff --git a/src/Web/VKHS/Error.hs b/src/Web/VKHS/Error.hs
deleted file mode 100644
index 71fa7c7..0000000
--- a/src/Web/VKHS/Error.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module Web.VKHS.Error where
-
-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 Web.VKHS.Imports
-
-data Error = ETimeout | EClient Client.Error
- deriving(Show, Eq)
-
--- | 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 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
- | UnexpectedInt Error (Int -> t (R t a) (R t a))
- -- ^ Invalid integer value. It is possible for client to set a correct URL and
- -- continue
- | UnexpectedBool Error (Bool -> t (R t a) (R t a))
- -- ^ Invalid boolean value. It is possible for client to set a correct URL and
- -- continue
- | UnexpectedURL Client.Error (URL -> t (R t a) (R t a))
- -- ^ Invalid URL. It is possible for client to set a correct URL and continue
- | UnexpectedRequest Client.Error (Request -> t (R t a) (R t a))
- | UnexpectedResponse Client.Error (Response -> t (R t a) (R t a))
- | UnexpectedFormField Form String (String -> t (R t a) (R t a))
- | LoginActionsExhausted
- | RepeatedForm Form (() -> t (R t a) (R t a))
- | JSONParseFailure ByteString (JSON -> t (R t a) (R t a))
- | JSONParseFailure' JSON String
- | JSONCovertionFailure (JSON, Text) (JSON -> t (R t a) (R 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)
-describeResult (UnexpectedBool e k) = "UnexpectedBool " <> (tshow e)
-describeResult (UnexpectedURL e k) = "UnexpectedURL " <> (tshow e)
-describeResult (UnexpectedRequest e k) = "UnexpectedRequest " <> (tshow e)
-describeResult LoginActionsExhausted = "LoginActionsExhausted"
-describeResult (RepeatedForm f k) = "RepeatedForm"
-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 1d5f813..1133850 100644
--- a/src/Web/VKHS/Imports.hs
+++ b/src/Web/VKHS/Imports.hs
@@ -1,4 +1,6 @@
--- | This module re-imports common declarations used across the VKHS
+{-# LANGUAGE TupleSections #-}
+
+-- | This module re-imports common declarations used across the VKHS library
module Web.VKHS.Imports (
module Web.VKHS.Imports
, module Control.Arrow
@@ -6,6 +8,11 @@ module Web.VKHS.Imports (
, module Control.Applicative
, module Control.Monad
, module Control.Monad.Trans
+ , module Control.Monad.State
+ , module Control.Monad.Cont
+ , module Control.Monad.Reader
+ , module Control.Monad.Except
+ , module Control.Monad.Writer
, module Control.Exception
, module Data.Aeson
, module Data.ByteString.Char8
@@ -15,22 +22,37 @@ module Web.VKHS.Imports (
, module Data.Text
, module Data.Text.IO
, module Data.List
+ , module Data.Set
, module Data.Function
+ , module Data.Function.Flippers
, module Data.Either
, module Data.Maybe
+ , module Data.Map
+ , module Data.Hashable
, module Data.Typeable
, module Data.Data
, module Data.Scientific
+ , module Debug.Trace
+ , module GHC.Generics
, module Text.Printf
, module Text.Show.Pretty
, module Text.Read
+ , module System.IO
) where
+import qualified Data.ByteString.Char8 as ByteString
+import qualified Data.Text as Text
+
import Control.Arrow ((***),(&&&))
import Control.Category ((>>>))
import Control.Applicative ((<$>), (<*>), (<|>), pure)
import Control.Monad
import Control.Monad.Trans
+import Control.Monad.State
+import Control.Monad.Cont
+import Control.Monad.Reader
+import Control.Monad.Except
+import Control.Monad.Writer
import Control.Exception (SomeException(..),try,catch,bracket)
import Data.Aeson ((.=), (.:), (.:?), (.!=), FromJSON)
import Data.Typeable
@@ -41,26 +63,48 @@ import Data.ByteString.Lazy (fromStrict,toChunks)
import Data.Scientific (Scientific, FPFormat(..))
import Data.Either
import Data.Maybe
+import Data.Map(Map)
+import Data.Hashable
import Data.Monoid((<>))
import Data.Function (on)
-import Data.Text (Text(..), pack, unpack)
+import Data.Function.Flippers
+import Data.Text (Text)
import Data.Text.IO (putStrLn, hPutStrLn)
import Data.List (head, length, sortBy, (++))
--- import Prelude (error, Integer, FilePath, (==), (.), Show(..), String,
--- ($), IO(..), Bool(..), compare, Ordering(..),
--- Read(..), error, undefined)
+import Data.Set (Set)
+import Debug.Trace hiding (trace)
+import GHC.Generics(Generic)
import Text.Printf
import Text.Show.Pretty
import Text.Read (readMaybe)
+import System.IO (stdout,stderr,Handle)
+
+bspack :: ByteString -> Text
+bspack = tpack . ByteString.unpack
tpack :: String -> Text
-tpack = pack
+tpack = Text.pack
+
tunpack :: Text -> String
-tunpack = unpack
+tunpack = Text.unpack
tshow :: (Show a) => a -> Text
tshow = tpack . show
-tputStrLn = Data.Text.IO.putStrLn
-thPutStrLn = Data.Text.IO.hPutStrLn
+tputStrLn :: MonadIO m => Text -> m ()
+tputStrLn t = liftIO $ Data.Text.IO.putStrLn t
+
+thPutStrLn :: MonadIO m => Handle -> Text -> m ()
+thPutStrLn h t = liftIO $ Data.Text.IO.hPutStrLn h t
+
+whileM :: (Monad m) => t -> b -> (t -> b -> m (Maybe t, b)) -> m b
+whileM i s f = do
+ (mbi,s') <- f i s
+ case mbi of
+ Just i' -> whileM i' s' f
+ Nothing -> return s'
+
+whileM_ :: (Monad m) => t -> (t -> m (Maybe t)) -> m ()
+whileM_ i f = whileM i () (\i () -> (,()) <$> f i)
+
diff --git a/src/Web/VKHS/Login.hs b/src/Web/VKHS/Login.hs
index b33a782..9758ad2 100644
--- a/src/Web/VKHS/Login.hs
+++ b/src/Web/VKHS/Login.hs
@@ -5,39 +5,47 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
module Web.VKHS.Login where
+import qualified Data.Map as Map
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.Text as Text
+import qualified Text.HTML.TagSoup.Parsec as Tagsoup
+import qualified Network.Shpider.Forms as Shpider
+import qualified Data.Set as Set
+
import Data.List
import Data.Maybe
import Data.Time
+import Data.Set(Set)
import Data.Either
import Control.Category ((>>>))
import Control.Applicative
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.Writer
-import Control.Monad.Cont
-
import Data.Map (Map)
-import qualified Data.Map as Map
-
import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as BS
-
import Data.Text(Text)
-import qualified Data.Text as Text
-
-import qualified Text.HTML.TagSoup.Parsec as Tagsoup
-import qualified Network.Shpider.Forms as Shpider
+import Debug.Trace
+import System.IO
+import System.Directory (doesFileExist)
import Web.VKHS.Types
-import Web.VKHS.Client
-import Web.VKHS.Monad
-import Web.VKHS.Error
+import Web.VKHS.Client (ToClientState(..), ClientState(..), MonadClient,
+ urlCreate, URL_Protocol(..), URL_Host(..), URL_Port(..), URL_Path(..),
+ buildQuery, requestCreateGet, cookiesCreate, responseBody, defaultClientState,
+ ClientRequest(..), ClientResponse(..), Cookies(..), requestCreatePost,
+ responseBodyS, responseRedirect, urlFragments)
import Web.VKHS.Imports
-import Debug.Trace
-import System.IO
+-- | Alias for `LoginRoutine`
+type L t a = LoginRoutine t a
+
+data LoginRoutine t a =
+ LoginOK a
+ | LoginFailed LoginError
+ | LoginAskInput [Tagsoup.Tag String] Form String (String -> t (L t a) (L t a))
+ | LoginRequestExecute RobotAction ((ClientResponse,Cookies) -> t (L t a) (L t a))
+ | LoginMessage Verbosity Text (() -> t (L t a) (L t a))
data LoginState = LoginState {
ls_rights :: [AccessRight]
@@ -46,24 +54,32 @@ data LoginState = LoginState {
-- ^ Application ID provided by vk.com
, ls_formdata :: [(String,String)]
-- ^ Dictionary containig inputID/value map for filling forms
- , ls_input_sets :: [[String]]
+ , ls_touched_inputs :: Set String -- [[String]]
+ -- ^ Input fields that was once set explicitly
+ , ls_cookies :: Cookies
+ -- ^ Cookies of the session
}
-defaultState :: GenericOptions -> LoginState
-defaultState go@GenericOptions{..} =
+defaultLoginState :: GenericOptions -> LoginState
+defaultLoginState go@GenericOptions{..} =
LoginState {
ls_rights = allAccess
, ls_appid = l_appid
, ls_formdata = (if not (null l_username) then [("email", l_username)] else [])
++ (if not (null l_password) then [("pass", l_password)] else [])
- , ls_input_sets = []
+ , ls_touched_inputs = Set.fromList []
+ , ls_cookies = Cookies mempty
}
class (ToGenericOptions s) => ToLoginState s where
toLoginState :: s -> LoginState
modifyLoginState :: (LoginState -> LoginState) -> (s -> s)
-class (MonadIO m, MonadClient m s, ToLoginState s, MonadVK m r) => MonadLogin m r s | m -> s
+-- class (MonadIO m, MonadClient m s, ToLoginState s, MonadVK m r) => MonadLogin m r s | m -> s
+-- | 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 (L m x)), ToLoginState s, MonadVK (m (L m x)) (L m x) s) =>
+ MonadLogin m x s | m -> s
-- | Login robot action
data RobotAction = DoGET URL Cookies | DoPOST FilledForm Cookies
@@ -73,18 +89,27 @@ printAction :: String -> RobotAction -> Text
printAction prefix (DoGET url jar) = tpack $ prefix ++ " GET " ++ (show url)
printAction prefix (DoPOST FilledForm{..} jar) = printForm prefix fform
-type Login m x a = m (R m x) a
+type Login m x a = m (LoginRoutine m x) a
+
-initialAction :: (MonadLogin (m (R m x)) (R m x) s) => Login m x RobotAction
+debug :: (MonadLogin m x s) => Text -> Login m x ()
+debug text = raiseVK (LoginMessage Debug text)
+
+ensureClient :: (MonadLogin m x s) => Login m x (Either ClientError a) -> Login m x a
+ensureClient m = m >>= \case
+ Left e -> terminate $ LoginFailed $ LoginClientError e
+ Right a -> return a
+
+initialAction :: (MonadLogin m x s) => Login m x RobotAction
initialAction = do
- LoginState{..} <- gets toLoginState
- GenericOptions{..} <- gets toGenericOptions
+ LoginState{..} <- toLoginState <$> getVKState
+ GenericOptions{..} <- toGenericOptions <$> getVKState
let
protocol = (case o_use_https of
True -> "https"
False -> "http")
- u <- ensure $ pure
- (urlCreate
+ u <- pure $
+ urlCreate
(URL_Protocol protocol)
(URL_Host o_login_host)
(Just (URL_Port (show o_port)))
@@ -95,8 +120,15 @@ initialAction = do
, ("redirect_url", protocol ++ "://oauth.vk.com/blank.html")
, ("display", "wap")
, ("response_type", "token")
- ]))
- return (DoGET u (cookiesCreate ()))
+ ])
+ cookies <- if null l_cookies_file
+ then pure $ Cookies mempty
+ else liftIO $ do
+ c <- doesFileExist l_cookies_file
+ if c then read <$> readFile l_cookies_file
+ else pure $ Cookies mempty
+ modifyVKState (modifyLoginState (\s -> s{ls_cookies = cookies}))
+ return (DoGET u cookies)
printForm :: String -> Shpider.Form -> Text
printForm prefix Shpider.Form{..} =
@@ -109,30 +141,31 @@ printForm prefix Shpider.Form{..} =
forM_ (Map.toList inputs) $ \(input,value) -> do
telln $ prefix ++ "\t" ++ input ++ ":" ++ (if null value then "<empty>" else value)
-fillForm :: (MonadLogin (m (R m x)) (R m x) s) => Form -> Login m x FilledForm
-fillForm f@(Form{..}) = do
- LoginState{..} <- toLoginState <$> get
- GenericOptions{..} <- gets toGenericOptions
- let empty_inputs = Shpider.emptyInputs form
- case empty_inputs `elem` ls_input_sets of
- False -> do
- modify $ modifyLoginState (\s -> s{ls_input_sets = empty_inputs:ls_input_sets})
+fillForm :: (MonadLogin m x s) => [Tagsoup.Tag String] -> Form -> Login m x FilledForm
+fillForm tags f@(Form{..}) = do
+ LoginState{..} <- toLoginState <$> getVKState
+ GenericOptions{..} <- toGenericOptions <$> getVKState
+ let empty_inputs = Set.fromList $ Shpider.emptyInputs form
+ let cleared_inputs = empty_inputs `Set.intersection` ls_touched_inputs
+ case Set.null cleared_inputs of
True -> do
- raise (\k -> RepeatedForm f k)
- return ()
- fis <- forM (Map.toList (Shpider.inputs form)) $ \(input,value) -> do
- case lookup input ls_formdata of
- Just value' -> do
- -- trace $ "Overwriting default value for " ++ input ++ "( " ++ value ++ ") with " ++ value' $ do
- return (input, value')
- Nothing -> do
- case null value of
- False -> do
- -- trace "Using default value for " ++ input ++ " (" ++ value ++ ")" $ do
- return (input, value)
- True -> do
- value' <- raise (\k -> UnexpectedFormField f input k)
- return (input, value')
+ modifyVKState $ modifyLoginState (\s -> s{ls_touched_inputs = empty_inputs`Set.union`ls_touched_inputs})
+ False -> do
+ terminate (LoginFailed $ LoginInvalidInputs f cleared_inputs)
+ fis <-
+ forM (Map.toList (Shpider.inputs form)) $ \(input,value) -> do
+ case lookup input ls_formdata of
+ Just value' -> do
+ -- trace $ "Overwriting default value for " ++ input ++ "( " ++ value ++ ") with " ++ value' $ do
+ return (input, value')
+ Nothing -> do
+ case null value of
+ False -> do
+ -- trace "Using default value for " ++ input ++ " (" ++ value ++ ")" $ do
+ return (input, value)
+ True -> do
+ value' <- raiseVK (LoginAskInput tags f input)
+ return (input, value')
-- Replace HTTPS with HTTP if not using TLS
let action' = (if o_use_https == False && isPrefixOf "https" (Shpider.action form) then
"http" ++ (fromJust $ stripPrefix "https" (Shpider.action form))
@@ -140,25 +173,19 @@ fillForm f@(Form{..}) = do
Shpider.action form)
return $ FilledForm form_title form{Shpider.inputs = Map.fromList fis, Shpider.action = action'}
-actionRequest :: (MonadLogin (m (R m x)) (R m x) s) => RobotAction -> Login m x (Response, Cookies)
-actionRequest a@(DoGET url jar) = do
- debug (printAction "> " a)
- req <- ensure $ requestCreateGet url jar
- (res, jar') <- requestExecute req
- return (res, jar')
-actionRequest a@(DoPOST form jar) = do
- debug (printAction "> " a)
- req <- ensure $ requestCreatePost form jar
- (res, jar') <- requestExecute req
+actionRequest :: (MonadLogin m x s) => RobotAction -> Login m x (ClientResponse, Cookies)
+actionRequest ra = do
+ (res, jar') <- raiseVK (LoginRequestExecute ra)
+ modifyVKState (modifyLoginState (\s -> s{ls_cookies = jar'}))
return (res, jar')
-analyzeResponse :: (MonadLogin (m (R m x)) (R m x) s) => (Response, Cookies) -> Login m x (Either RobotAction AccessToken)
+analyzeResponse :: (MonadLogin m x s) => (ClientResponse, Cookies) -> Login m x (Either RobotAction AccessToken)
analyzeResponse (res, jar) = do
- LoginState{..} <- toLoginState <$> get
+ LoginState{..} <- toLoginState <$> getVKState
let tags = Tagsoup.parseTags (responseBodyS res)
title = Shpider.gatherTitle tags
- forms = map (Form title) (Shpider.gatherForms tags)
- dumpResponseBody "latest.html" res
+
+ forms <- pure $ map (Form title) (Shpider.gatherForms tags)
debug ("< 0 Title: " <> tpack title)
case (responseRedirect res) of
@@ -173,23 +200,27 @@ analyzeResponse (res, jar) = do
Nothing -> do
case forms of
[] -> do
- terminate LoginActionsExhausted
+ terminate $ LoginFailed $ LoginNoAction
(f:[]) -> do
debug $ printForm "< 0 " $ form f
- ff <- fillForm f
+ ff <- fillForm tags f
return $ Left (DoPOST ff jar)
fs -> do
- forM_ (fs`zip`[0..]) $ \(f,n) -> do
- ff <- fillForm f
+ forM_ (fs`zip`[(0::Integer)..]) $ \(f,n) -> do
+ ff <- fillForm tags f
debug $ printForm ("< " ++ (show n) ++ " ") $ fform ff
- terminate LoginActionsExhausted
+ terminate $ LoginFailed $ LoginNoAction
-login :: (MonadLogin (m (R m x)) (R m x) s) => Login m x AccessToken
-login = initialAction >>= go where
+loginRoutine :: (MonadLogin m x s) => Login m x AccessToken
+loginRoutine = (initialAction >>= go) <* saveCookies where
go a = do
req <- actionRequest a
res <- analyzeResponse req
case res of
Left a' -> go a'
Right at -> return at
-
+ saveCookies = do
+ cookies_file <- l_cookies_file <$> toGenericOptions <$> getVKState
+ cookies <- ls_cookies <$> toLoginState <$> getVKState
+ when (not $ null cookies_file) $
+ liftIO $ writeFile cookies_file $ show cookies
diff --git a/src/Web/VKHS/Monad.hs b/src/Web/VKHS/Monad.hs
deleted file mode 100644
index 10d10ad..0000000
--- a/src/Web/VKHS/Monad.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FunctionalDependencies #-}
-module Web.VKHS.Monad where
-
-import Data.List
-import Data.Maybe
-import Data.Time
-import Data.Either
-import Control.Applicative
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.Reader
-import Control.Monad.Cont
-import Data.Default.Class
-import System.IO
-
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString.Char8 as BS
-
-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)
-import qualified Web.VKHS.Client as Client
-
-
--- newtype VKT m r a = VKT { unVKT :: StateT (r -> VKT m r r) (ContT r m) a }
--- deriving(Functor, Applicative, Monad, MonadState (r -> VKT m r r), MonadCont, MonadIO)
-
-class (MonadCont m, MonadReader (r -> m r) m) => MonadVK m r
-
--- instance (Monad m) => MonadVK (VKT m r) r
-
--- | Store early exit handler in the reader monad, run the computation @m@
-catch :: (MonadVK m r) => m r -> m r
-catch m = do
- callCC $ \k -> do
- local (const k) m
-
-raise :: (MonadVK m r) => ((a -> m b) -> r) -> m a
-raise z = callCC $ \k -> do
- err <- ask
- err (z k)
- undefined
-
-terminate :: (MonadVK m r) => r -> m a
-terminate r = do
- err <- ask
- err r
- undefined
-
--- | 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)
-
-class MonadVK (t r) r => EnsureVK t r c a | c -> a where
- ensure :: t r c -> t r a
-
-instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error Request) Request where
- ensure m = m >>= \x ->
- case x of
- (Right u) -> return u
- (Left e) -> raise (\k -> UnexpectedRequest e k)
-
-instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error URL) URL where
- ensure m = m >>= \x ->
- case x of
- (Right u) -> return u
- (Left e) -> raise (\k -> UnexpectedURL e k)
-
-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 6698cee..ed1c5c7 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -5,28 +6,19 @@
{-# LANGUAGE RecordWildCards #-}
module Web.VKHS.Types where
-import Data.List
-import Data.Char
-import Data.Data
-import Data.Typeable
-
-import Data.Text(Text)
import qualified Data.Text.IO as Text
import qualified Data.Text as Text
-
-import Data.ByteString.Char8 (ByteString)
+import qualified Data.Text.Encoding as Text
import qualified Data.ByteString.Char8 as ByteString
-
-import Data.Aeson (FromJSON(..), ToJSON(..), (.=), (.:))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
-
+import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Network.Shpider.Forms as Shpider
+import qualified Data.List as List
-import Control.Monad.State (MonadState(..), gets)
+import Data.Time (secondsToDiffTime,NominalDiffTime(..),UTCTime(..),diffUTCTime)
+import Network.URI(URI(..))
import Web.VKHS.Imports
-import System.IO (stderr)
-
-- | AccessToken is a authentication data, required by all VK API
-- functions. It is a tuple of access_token, user_id, expires_in fields,
@@ -68,7 +60,7 @@ data AccessRight
deriving(Show, Eq, Ord, Enum)
toUrlArg :: [AccessRight] -> String
-toUrlArg = intercalate "," . map (map toLower . show)
+toUrlArg = List.intercalate "," . map (map toLower . show)
allAccess :: [AccessRight]
@@ -97,28 +89,50 @@ allAccess =
newtype AppID = AppID { aid_string :: String }
deriving(Show, Eq, Ord)
-
-- | JSON wrapper.
--
-- * FIXME Implement full set of helper functions
data JSON = JSON { js_aeson :: Aeson.Value }
- deriving(Show, Data, Typeable)
+ deriving(Show, Read, Data, Typeable, Eq)
+
+-- | Encode JSON to strict Char8 ByteStirng
+jsonEncodeBS :: JSON -> ByteString
+jsonEncodeBS JSON{..} = ByteString.concat $ toChunks $ Aeson.encode js_aeson
+
+-- | Encode JSON to Text
+jsonEncode :: JSON -> Text
+jsonEncode JSON{..} = Text.decodeUtf8 $ ByteString.concat $ toChunks $ Aeson.encode js_aeson
+
+-- | Encode JSON to strict Char8 ByteString using pretty-style formatter
+jsonEncodePrettyBS :: JSON -> ByteString
+jsonEncodePrettyBS JSON{..} = ByteString.concat $ toChunks $ Aeson.encodePretty js_aeson
+
+-- | Encode JSON to Text using pretty-style formatter
+jsonEncodePretty :: JSON -> Text
+jsonEncodePretty JSON{..} = Text.decodeUtf8 $ ByteString.concat $ toChunks $ Aeson.encodePretty js_aeson
+
+-- | Utility function to parse ByteString into JSON object
+decodeJSON :: ByteString -> Either Text JSON
+decodeJSON bs = do
+ case Aeson.eitherDecode (fromStrict bs) of
+ Left err -> Left (tpack err)
+ Right js -> Right (JSON js)
instance FromJSON JSON where
parseJSON v = return $ JSON v
-parseJSON :: (Aeson.FromJSON a) => JSON -> Either String a
-parseJSON j = Aeson.parseEither Aeson.parseJSON (js_aeson j)
+parseJSON :: (Aeson.FromJSON a) => JSON -> Either Text a
+parseJSON j = either (Left . tpack) Right $ Aeson.parseEither Aeson.parseJSON (js_aeson j)
data Form = Form {
form_title :: String
, form :: Shpider.Form
- } deriving(Show)
+ } deriving(Show,Eq)
data FilledForm = FilledForm {
fform_title :: String
, fform :: Shpider.Form
- } deriving(Show)
+ } deriving(Show,Eq)
-- | Generic parameters of the VK execution. For accessing from VK runtime, use
@@ -127,7 +141,7 @@ data GenericOptions = GenericOptions {
o_login_host :: String
, o_api_host :: String
, o_port :: Int
- , o_verbose :: Bool
+ , o_verbosity :: Verbosity
, o_use_https :: Bool
, o_max_request_rate_per_sec :: Rational
-- ^ How many requests per second is allowed
@@ -145,13 +159,18 @@ data GenericOptions = GenericOptions {
, l_access_token_file :: FilePath
-- ^ Filename to store actual access token, should be used to pass its value
-- between sessions
+ , l_cookies_file :: FilePath
+ -- ^ File to load/save cookies for storing them between program runs. Empty
+ -- means 'not set.'
+ -- , l_api_cache_time :: DiffTime
} deriving(Show)
+defaultOptions :: GenericOptions
defaultOptions = GenericOptions {
o_login_host = "oauth.vk.com"
, o_api_host = "api.vk.com"
, o_port = 443
- , o_verbose = False
+ , o_verbosity = Normal
, o_use_https = True
, o_max_request_rate_per_sec = 2
, o_allow_interactive = True
@@ -161,6 +180,8 @@ defaultOptions = GenericOptions {
, l_password = ""
, l_access_token = ""
, l_access_token_file = ".vkhs-access-token"
+ , l_cookies_file = ".vkhs-cookies"
+ -- , l_api_cache_time = realToFrac $ secondsToDiffTime 60
}
class ToGenericOptions s where
@@ -169,40 +190,121 @@ class ToGenericOptions s where
data Verbosity = Normal | Trace | Debug
deriving(Enum,Eq,Ord,Show)
-debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
-debug str = do
- GenericOptions{..} <- gets toGenericOptions
- when o_verbose $ do
- liftIO $ Text.hPutStrLn stderr str
-
-alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m ()
-alert str = do
- liftIO $ Text.hPutStrLn stderr str
-
-
-data MusicOptions = MusicOptions {
- m_list_music :: Bool
- , m_search_string :: String
- , m_name_format :: String
- , m_output_format :: String
- , m_out_dir :: Maybe String
- , m_records_id :: [String]
- , m_skip_existing :: Bool
- } deriving(Show)
-data UserOptions = UserOptions {
- u_queryString :: String
- } deriving(Show)
+type MethodName = String
+type MethodArgs = [(String, Text)]
-data WallOptions = WallOptions {
- w_woid :: String
- } deriving(Show)
-data GroupOptions = GroupOptions {
- g_search_string :: String
- , g_output_format :: String
+data UploadRecord = UploadRecord {
+ upl_server :: Integer
+ , upl_photo :: Text
+ , upl_hash :: Text
+ } deriving(Show, Data, Typeable)
+
+instance FromJSON UploadRecord where
+ parseJSON = Aeson.withObject "UploadRecord" $ \o ->
+ UploadRecord
+ <$> (o .: "server")
+ <*> (o .: "photo")
+ <*> (o .: "hash")
+
+data HRef = HRef { href :: Text }
+ deriving(Show, Read, Eq, Data, Typeable)
+
+instance FromJSON HRef where
+ parseJSON j = HRef <$> Aeson.parseJSON j
+
+
+data APIError =
+ APIInvalidJSON MethodName JSON Text
+ | APIUnhandledError MethodName APIErrorRecord Text
+ | APIUnexpected MethodName Text
+ deriving(Show)
+
+
+-- | Wrapper for common error codes returned by the VK API
+data APIErrorCode =
+ AccessDenied
+ | NotLoggedIn
+ | TooManyRequestsPerSec
+ | ErrorCode Scientific
+ -- ^ Other codes go here
+ deriving(Show,Eq,Ord)
+
+instance FromJSON APIErrorCode where
+ parseJSON = Aeson.withScientific "ErrorCode" $ \n ->
+ case n of
+ 5 -> return NotLoggedIn
+ 6 -> return TooManyRequestsPerSec
+ 15 -> return AccessDenied
+ x -> return (ErrorCode x)
+
+-- | Top-level error description, returned by VK API
+data APIErrorRecord = APIErrorRecord
+ { er_code :: APIErrorCode
+ , er_msg :: Text
} deriving(Show)
-type MethodName = String
-type MethodArgs = [(String, Text)]
+instance FromJSON APIErrorRecord where
+ parseJSON = Aeson.withObject "ErrorRecord" $ \o ->
+ APIErrorRecord
+ <$> (o .: "error_code")
+ <*> (o .: "error_msg")
+
+-- | TODO: Move to Login/Types.hs
+data LoginError =
+ LoginNoAction
+ | LoginClientError ClientError
+ | LoginInvalidInputs Form (Set String)
+ deriving(Show,Eq)
+
+-- | URL wrapper
+-- TODO: Move to Client/Types.hs
+newtype URL = URL { uri :: URI }
+ deriving(Show, Eq)
+
+-- | TODO: Move to Client/Types.hs
+data ClientError =
+ ErrorParseURL { euri :: Text, emsg :: String }
+ | ErrorSetURL { eurl :: URL, emsg :: String }
+ deriving(Show, Eq)
+
+
+data Time = Time { t_utc :: UTCTime }
+ deriving(Show, Read, Eq, Ord)
+
+data DiffTime = DiffTime { dt_utc :: NominalDiffTime }
+ deriving(Show, Eq, Ord)
+
+diffTime :: Time -> Time -> DiffTime
+diffTime a b = DiffTime $ diffUTCTime (t_utc a) (t_utc b)
+
+class (MonadCont m, MonadReader (r -> m r) m) => MonadVK m r s | m -> s where
+ getVKState :: m s
+ putVKState :: s -> m ()
+
+modifyVKState :: MonadVK m r s => (s -> s) -> m ()
+modifyVKState f = getVKState >>= putVKState . f
+
+-- | Store early exit handler in the reader monad, run the computation @m@
+catchVK :: (MonadVK m r s) => m r -> m r
+catchVK m = do
+ callCC $ \k -> do
+ local (const k) m
+
+raiseVK :: (MonadVK m r s) => ((a -> m b) -> r) -> m a
+raiseVK z = callCC $ \k -> do
+ err <- ask
+ _ <- err (z k)
+ undefined
+
+terminate :: (MonadVK m r s) => r -> m a
+terminate r = do
+ err <- ask
+ _ <- err r
+ undefined
+
+-- getGenericOptions :: (MonadState s m, ToGenericOptions s) => m GenericOptions
+-- getGenericOptions = gets toGenericOptions
+