VKHS 1.9.1 → 1.9.2
raw patch · 20 files changed
+1481/−1031 lines, 20 filesdep +VKHSdep +flippersdep +hashable
Dependencies added: VKHS, flippers, hashable, process
Files
- LICENSE +1/−1
- README.md +40/−37
- VKHS.cabal +21/−8
- app/common/Util.hs +2/−30
- app/vkq/Main.hs +103/−23
- src/Network/Shpider/Forms.hs +29/−7
- src/Text/HTML/TagSoup/Parsec.hs +2/−1
- src/Text/Namefilter.hs +3/−1
- src/Web/VKHS.hs +8/−188
- src/Web/VKHS/API.hs +0/−1
- src/Web/VKHS/API/Base.hs +115/−173
- src/Web/VKHS/API/Simple.hs +217/−65
- src/Web/VKHS/API/Types.hs +128/−81
- src/Web/VKHS/Client.hs +61/−83
- src/Web/VKHS/Coroutine.hs +438/−0
- src/Web/VKHS/Error.hs +0/−80
- src/Web/VKHS/Imports.hs +53/−9
- src/Web/VKHS/Login.hs +107/−76
- src/Web/VKHS/Monad.hs +0/−116
- src/Web/VKHS/Types.hs +153/−51
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012, Sergey Mironov+Copyright (c) 2018, Sergey Mironov All rights reserved.
README.md view
@@ -4,40 +4,45 @@ 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.+* 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+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 @@ 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 @@ $ haskdogs - VKQ command line application ============================ @@ -130,7 +136,7 @@ $ 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 @@ 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 @@ BSD3 license -Copyright (c) 2014, Sergey Mironov <grrwlf@gmail.com>+Copyright (c) 2018, Sergey Mironov <grrwlf@gmail.com>
VKHS.cabal view
@@ -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 @@ 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 @@ 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 @@ network-uri, pipes, pipes-http,+ process, time, data-default-class, parsec,@@ -65,12 +65,25 @@ 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
app/common/Util.hs view
@@ -44,11 +44,11 @@ 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@@ -89,34 +89,6 @@ 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
app/vkq/Main.hs view
@@ -7,27 +7,85 @@ 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 APIOptions = APIOptions { a_method :: String- , a_args :: String+ , a_args :: [String] , a_pretty :: Bool } deriving(Show) @@ -74,7 +132,7 @@ <$> (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 @@ 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 @@ 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 @@ -} -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,18 +261,38 @@ 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 @@ |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 @@ |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"
src/Network/Shpider/Forms.hs view
@@ -34,6 +34,7 @@ , mkForm , gatherTitle , emptyInputs+ , gatherCaptcha ) where @@ -43,7 +44,7 @@ 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 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 @@ 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 @@ , method = m } +toForm _ = Nothing++methodLookup :: [(String, String)] -> Maybe Method methodLookup attrs = do m <- attrLookup "method" attrs case lowercase m of@@ -135,9 +152,10 @@ 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 @@ 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
src/Text/HTML/TagSoup/Parsec.hs view
@@ -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 p = try ( do t <- p return $ Just t- ) <|> ( do anyToken+ ) <|> ( do _ <- anyToken return Nothing )
src/Text/Namefilter.hs view
@@ -1,4 +1,6 @@-module Text.Namefilter +{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Text.Namefilter ( namefilter ) where
src/Web/VKHS.hs view
@@ -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 ()
src/Web/VKHS/API.hs view
@@ -3,7 +3,6 @@ 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
src/Web/VKHS/API/Base.hs view
@@ -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 -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)+-- | Short alias for the coroutine monad+type API m x a = m (R m x) a --- | 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)))+-- | Perform API call+api :: (MonadAPI m x s) => MethodName -> MethodArgs -> API m x JSON+api mname margs = raiseVK (ExecuteAPI (mname,margs)) - debug $ "> " <> (tshow url)+-- | Upload File to server+upload :: (MonadAPI m x s) => HRef -> FilePath -> API m x UploadRecord+upload href filepath = raiseVK (UploadFile (href,filepath)) - req <- ensure (requestCreateGet url (cookiesCreate ()))- (res, jar') <- requestExecute req- decodeJSON (responseBody res)+-- | 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) --- | 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)+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-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+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 --- | 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)+api1 :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s) => MethodName -- ^ API method name -> MethodArgs -- ^ API method arguments -> API m x a-apiR m0 args0 = apiRf m0 args0 Right---- | Invoke the request, in case of failure, escalate the probelm to the--- supervisor. The superwiser has a chance to change the arguments-apiHM :: 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+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 -apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)+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)
src/Web/VKHS/API/Simple.hs view
@@ -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 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 ""+ ) -getCountries :: (MonadAPI m x s) => API m x (Sized [Country])+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++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 -> do- return (Just $ Sized 0 [])- _ -> do- return Nothing- :: API m x (Maybe (Sized [WallRecord])))+ 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 -> 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++
src/Web/VKHS/API/Types.hs view
@@ -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.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 @@ 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 @@ -} +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 @@ 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)+ <*> (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") -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)+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) <> "\"" -data ErrorRecord = ErrorRecord- { er_code :: ErrorCode- , er_msg :: Text- } deriving(Show)+userUrl :: UserId -> APIUrl+userUrl (UserId x) = APIUrl $ "https://vk.com/id" <> tshow x -instance FromJSON ErrorRecord where- parseJSON = Aeson.withObject "ErrorRecord" $ \o ->- ErrorRecord- <$> (o .: "error_code")- <*> (o .: "error_msg")+printUserUrl :: UserId -> Text+printUserUrl (UserId x) = printAPIUrl $ APIUrl $ "https://vk.com/id" <> tshow x -- | Wall post representation (partial) --@@ -130,22 +171,29 @@ 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 @@ 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 @@ , 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 @@ <*> (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 @@ <$> (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,26 +343,13 @@ <*> (o .: "user_id") data OwnerUploadServer = OwnerUploadServer {- ous_upload_url :: Text+ ous_upload_url :: HRef } deriving(Show, Data, Typeable) instance FromJSON OwnerUploadServer where parseJSON = Aeson.withObject "OwnerUploadServer" $ \o -> 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")
src/Web/VKHS/Client.hs view
@@ -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.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 @@ , 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 (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_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 @@ 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 @@ -} data Cookies = Cookies { jar :: Client.CookieJar }- deriving(Show,Eq)+ deriving(Show, Read, Eq) cookiesCreate :: () -> Cookies cookiesCreate () = Cookies (Client.createCookieJar [])@@ -182,13 +160,13 @@ |_| |_| |_| |_| |_| -} -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 @@ 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 @@ } -- | 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 @@ 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)
+ src/Web/VKHS/Coroutine.hs view
@@ -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 ()+
− src/Web/VKHS/Error.hs
@@ -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-
src/Web/VKHS/Imports.hs view
@@ -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 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 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.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)+
src/Web/VKHS/Login.hs view
@@ -5,40 +5,48 @@ {-# 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] -- ^ Access rights to be requested@@ -46,24 +54,32 @@ -- ^ 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 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 @@ , ("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 @@ 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 @@ 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 @@ 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
− src/Web/VKHS/Monad.hs
@@ -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)--
src/Web/VKHS/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -5,29 +6,20 @@ {-# 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, -- returned by login procedure.@@ -68,7 +60,7 @@ 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 @@ 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 @@ 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 @@ , 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 @@ , 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 @@ 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+type MethodName = String+type MethodArgs = [(String, Text)] -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 UploadRecord = UploadRecord {+ upl_server :: Integer+ , upl_photo :: Text+ , upl_hash :: Text+ } deriving(Show, Data, Typeable) -data UserOptions = UserOptions {- u_queryString :: String- } deriving(Show)+instance FromJSON UploadRecord where+ parseJSON = Aeson.withObject "UploadRecord" $ \o ->+ UploadRecord+ <$> (o .: "server")+ <*> (o .: "photo")+ <*> (o .: "hash") -data WallOptions = WallOptions {- w_woid :: String- } deriving(Show)+data HRef = HRef { href :: Text }+ deriving(Show, Read, Eq, Data, Typeable) -data GroupOptions = GroupOptions {- g_search_string :: String- , g_output_format :: String+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+