diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -1,10 +1,10 @@ name: VKHS -version: 0.1.6 -synopsis: Provides access to Vkontakte social network, popular in Russia +version: 0.2.0 +synopsis: Provides access to Vkontakte social network description: Provides access to Vkontakte API methods. Library requires no interaction - with user during Implicit-flow authentication. + with the user during Implicit-flow authentication. license: BSD3 license-file: LICENSE @@ -20,6 +20,10 @@ type: git location: https://github.com/ierton/vkhs.git +executable vkq + hs-source-dirs: src + main-is: VKQ.hs + library hs-source-dirs: src other-modules: Test.Debug, Test.Data, Test.API, Network.Shpider.Forms, Network.Protocol.Uri, Network.Protocol.Mime, Network.Protocol.Http, Network.Protocol.Cookie, Network.Protocol.Uri.Remap, Network.Protocol.Uri.Query, Network.Protocol.Uri.Printer, Network.Protocol.Uri.Path, Network.Protocol.Uri.Parser, Network.Protocol.Uri.Encode, Network.Protocol.Uri.Data, Network.Protocol.Uri.Chars, Network.Protocol.Http.Status, Network.Protocol.Http.Printer, Network.Protocol.Http.Parser, Network.Protocol.Http.Headers, Network.Protocol.Http.Data @@ -46,5 +50,6 @@ bimap ==0.2.*, template-haskell ==2.8.*, transformers ==0.3.*, - fclabels >=1.1.4 + fclabels >=1.1.4 && <1.1.6, + optparse-applicative >=0.4 && <0.6 diff --git a/src/Test/API.hs b/src/Test/API.hs --- a/src/Test/API.hs +++ b/src/Test/API.hs @@ -1,16 +1,17 @@ module Test.API where -import Web.VKHS.Login -import Web.VKHS.API +import Web.VKHS import Text.Printf -- | Almost working example. Just set correct values for client_id/login/password print_user_info = do let e = env "3213232" "user@example.com" "password" [Photos,Audio,Groups] - (Right at) <- login e - (Right ans) <- api e{verbose = Debug} at "users.get" [ + r <- login e{verbose = Debug} + print r + let (Right (at,_,_)) = r + ans <- api (callEnv e{verbose = Debug} at) "users.get" [ ("uids","911727") , ("fields","first_name,last_name,nickname,screen_name") , ("name_case","nom") ] - putStrLn ans + print ans diff --git a/src/VKQ.hs b/src/VKQ.hs new file mode 100644 --- /dev/null +++ b/src/VKQ.hs @@ -0,0 +1,74 @@ +module Main where + +import Control.Monad +import Data.Label.Abstract +import Network.Protocol.Uri.Query +import Options.Applicative +import System.Exit +import System.IO +import Text.Printf +import Web.VKHS + +data Options = Options + { verb :: Verbosity + , cmdOpts :: CmdOptions + } deriving(Show) + +data CmdOptions + = Login LoginOptions + | Call CallOptions + deriving(Show) + +data LoginOptions = LoginOptions + { appid :: String + , username :: String + , password :: String + } deriving(Show) + +data CallOptions = CallOptions + { accessToken :: String + , method :: String + , args :: String + } deriving(Show) + +loginOptions :: Parser CmdOptions +loginOptions = Login <$> (LoginOptions + <$> argument str (metavar "APPID" & help "Application identifier (provided to you by vk.com)") + <*> argument str (metavar "USER" & help "User name or email") + <*> argument str (metavar "PASS" & help "User password")) + +callOptions :: Parser CmdOptions +callOptions = Call <$> (CallOptions + <$> argument str (metavar "ACCESS_TOKEN" & help "access_token") + <*> argument str (metavar "METHOD" & help "Method to call") + <*> argument str (metavar "PARAMS" & help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]")) + +opts :: Parser Options +opts = Options + <$> flag Normal Debug (long "verbose" & help "Be verbose") + <*> subparser ( + command "login" (info loginOptions + ( progDesc "Login into vk.com (see --help for details); Print access_token (among user_id and expiration time) on success" )) + & command "call" (info callOptions + ( progDesc "call VK API method (see --help for details)" )) + ) + +ifeither e fl fr = either fl fr e + +errexit e = hPutStrLn stderr e >> exitFailure + +cmd :: Options -> IO () +cmd (Options v (Login (LoginOptions a u p))) = do + let e = (env a u p allAccess) { verbose = v } + ea <- login e + ifeither ea errexit $ \(at,uid,expin) -> do + printf "%s %s %s\n" at uid expin + +cmd (Options v (Call (CallOptions act mn args))) = do + let e = (envcall act) { verbose = v } + ea <- api e mn (fw (keyValues "," "=") args) + ifeither ea errexit putStrLn + +main :: IO () +main = execParser (info opts idm) >>= cmd + diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs --- a/src/Web/VKHS.hs +++ b/src/Web/VKHS.hs @@ -82,3 +82,4 @@ import Web.VKHS.Types import Web.VKHS.Login import Web.VKHS.API + diff --git a/src/Web/VKHS/API.hs b/src/Web/VKHS/API.hs --- a/src/Web/VKHS/API.hs +++ b/src/Web/VKHS/API.hs @@ -1,5 +1,6 @@ module Web.VKHS.API ( api + , envcall ) where import Control.Monad @@ -21,10 +22,23 @@ import Web.VKHS.Types import Web.VKHS.Curl -api :: Env -> AccessToken -> String -> Parameters -> IO (Either String String) -api e (at,_,_) mn mp = +envcall :: String -> Env CallEnv +envcall at = mkEnv (CallEnv at) + +-- | Invoke the request. Return answer (normally, string representation of +-- JSON data). See documentation: +-- +-- +api :: Env CallEnv + -- ^ the VKHS environment + -> String + -- ^ API method name + -> [(String, String)] + -- ^ API method parameters (name-value pairs) + -> IO (Either String String) +api e mn mp = let uri = BS.pack $ showUri $ (\f -> f $ toUri $ printf "https://api.vk.com/method/%s" mn) $ - set query $ bw params (("access_token",at):mp) + set query $ bw params (("access_token",(access_token . sub) e):mp) in runErrorT $ do r <- ErrorT $ vk_curl e (tell [CURLOPT_URL uri]) (_,b) <- ErrorT $ return $ parseResponse r diff --git a/src/Web/VKHS/API/JSON.hs b/src/Web/VKHS/API/JSON.hs --- a/src/Web/VKHS/API/JSON.hs +++ b/src/Web/VKHS/API/JSON.hs @@ -15,5 +15,6 @@ liftR (Ok a) = return a liftR (Error s) = fail s -api :: Env -> AccessToken -> String -> [(String,String)] -> IO (Either String JSValue) -api e a mn mp = runErrorT $ ErrorT (Base.api e a mn mp) >>= liftR . J.decode +api :: Env CallEnv -> String -> [(String,String)] -> IO (Either String JSValue) +api e mn mp = runErrorT $ ErrorT (Base.api e mn mp) >>= liftR . J.decode + diff --git a/src/Web/VKHS/Curl.hs b/src/Web/VKHS/Curl.hs --- a/src/Web/VKHS/Curl.hs +++ b/src/Web/VKHS/Curl.hs @@ -16,7 +16,7 @@ -- | Generic request sender. Uses delay to prevent application from being -- blocked for flooding -vk_curl :: Env -> Writer [CURLoption] () -> IO (Either String String) +vk_curl :: Env a -> Writer [CURLoption] () -> IO (Either String String) vk_curl e w = do let askE x = return (x e) v <- askE verbose diff --git a/src/Web/VKHS/Login.hs b/src/Web/VKHS/Login.hs --- a/src/Web/VKHS/Login.hs +++ b/src/Web/VKHS/Login.hs @@ -2,10 +2,7 @@ module Web.VKHS.Login ( login - , Env(..) , env - , AccessRight(..) - , Verbosity(..) ) where import Prelude hiding ((.), id, catch) @@ -73,17 +70,16 @@ -- ^ User password -> [AccessRight] -- ^ Access rights to request - -> Env -env cid email pwd ar = Env - Normal - "Mozilla/5.0 (X11; Linux x86_64; rv:12.0) Gecko/20120702 Firefox/12.0" + -> Env LoginEnv +env cid email pwd ar = mkEnv + (LoginEnv [ ("email",email) , ("pass",pwd) ] - cid - 500 ar + cid + ) -vk_start_action :: ClientId -> [AccessRight] -> Action -vk_start_action cid ac = OpenUrl start_url mempty where +vk_start_action :: ClientId -> [AccessRight] -> ActionHist +vk_start_action cid ac = AH [] $ OpenUrl start_url mempty where start_url = (\f -> f $ toUri "http://oauth.vk.com/authorize") $ set query $ bw params [ ("client_id", cid) @@ -95,9 +91,9 @@ type FilledForm = Form -type VK a = ReaderT Env (ErrorT String IO) a +type VK a = ReaderT (Env LoginEnv) (ErrorT String IO) a -runVK :: Env -> VK a -> IO (Either String a) +runVK :: Env LoginEnv -> VK a -> IO (Either String a) runVK e vk = runErrorT (runReaderT vk e) liftVK :: IO (Either String a) -> VK a @@ -114,8 +110,14 @@ type Page = (Http Response, Body) -- | Browser action + +type Hist = [[String]] + +data ActionHist = AH Hist Action + deriving(Show) + data Action = OpenUrl Uri Cookies | SendForm Form Cookies - deriving (Show) + deriving (Show) -- | Url assotiated with Action actionUri :: Action -> Uri @@ -160,7 +162,7 @@ split_inputs :: [(String,String)] -- ^ User dictionary -> M.Map String String - -- ^ Form fields with default values (default is valid if non-zero) + -- ^ Fields with default values (default doesn't exist if zero string) -> (M.Map String (), M.Map String String, M.Map String String) split_inputs d m = let (b,g) = M.mapEitherWithKey (match_field d) m @@ -171,14 +173,17 @@ | otherwise = maybe (Left ()) (Right . Right) u where u = lookup k d +inputs_to_fill :: Form -> [String] +inputs_to_fill f = let (inps,_,_) = split_inputs [] (inputs f) in M.keys inps + vk_fill_form :: Form -> VK FilledForm vk_fill_form f = ask >>= \e -> do - let (bad,good,user) = split_inputs (formdata e) (inputs f) + let (bad,good,user) = split_inputs ((formdata . sub) e) (inputs f) when (not $ M.null bad) (fail $ "Unmatched form parameters: " ++ (show bad)) return f { inputs = good } --- | Executes an action, returns Web-server's answer, adjusts cookies --- Cookie management algorithm is very primitive: just merging +-- | Execute an action, return Web-server's answer and adjusted cookies. Cookie +-- management is very primitive: it's no more than merging old and new ones vk_move :: Action -> VK (Page, Cookies) vk_move (OpenUrl u c) = do (h,b) <- (vk_get u c) @@ -192,36 +197,47 @@ uri_fragment = get location >=> pure . get fragment >=> pure . fw (keyValues "&" "=") >=> \f -> do (\a b c -> (a,b,c)) <$> lookup "access_token" f <*> lookup "user_id" f <*> lookup "expires_in" f --- | Suggests new action -vk_analyze :: (Page,Cookies) -> VK (Either AccessToken Action) -vk_analyze ((h,b),c) - | isJust a = return $ Left (fromJust a) - | isJust l = return $ Right $ OpenUrl (fromJust l) c - | (not . null) f = return $ Right $ SendForm (head f) c - | otherwise = fail "HTML processing failure (new design of VK login dialog?)" +-- | Suggest new action +vk_analyze :: Hist -> (Page,Cookies) -> VK (Either AccessToken (Action,Hist)) +vk_analyze hist ((h,b),c) + | isJust a = return $ Left (fromJust a) + | isJust l = return $ Right (OpenUrl (fromJust l) c, hist) + | not (null fs) && not (is `elem` hist) + = return $ Right (SendForm f c, is:hist) + | not (null fs) && (is `elem` hist) + = fail $ "Invalid password/Form containig following inputs already seen: " ++ (show is) + | not gs = fail $ "HTTP error: status " ++ (show s) + | otherwise = fail $ "HTML processing failure (new design of VK login dialog?)" where + gs = s`elem` [OK,Created,Found,SeeOther,Accepted,Continue] + s = get status h l = get location h - f = parseTags >>> gatherForms $ b + fs = parseTags >>> gatherForms $ b + f = head fs + is = inputs_to_fill f a = uri_fragment h vk_dump_page :: Int -> Uri -> Page -> IO () -vk_dump_page n u (h,b) = +vk_dump_page n u (h,b) + | (>0) . length . filter (isAlpha) $ b = let name = printf "%02d-%s.html" n (showAuthority (get authority u)) in bracket (openFile name WriteMode) (hClose) $ \f -> do hPutStrLn f b hPutStrLn stderr $ "dumped: name " ++ (name) ++ " size " ++ (show $ length b) + | otherwise = return () --- | Start login procedure, return AccessToken on success -login :: Env -> IO (Either String AccessToken) -login e = runVK e $ loop 0 (vk_start_action (clientId e) (ac_rights e)) where - loop n act = do +-- | Execute login procedure, return (Right AccessToken) on success +login :: Env LoginEnv -> IO (Either String AccessToken) +login e@(Env (LoginEnv _ acr cid) _ _ _) = + runVK e $ loop [0..] (vk_start_action cid acr) where + loop (n:ns) (AH h act) = do when_trace $ printf "VK => %02d %s" n (show act) ans@(p,c) <- vk_move act when_debug $ vk_dump_page n (actionUri act) p - a <- vk_analyze ans + a <- vk_analyze h ans case a of - Right act' -> do - loop (n+1) act' + Right (act',h') -> do + loop ns (AH h' act') Left at -> do return at diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs --- a/src/Web/VKHS/Types.hs +++ b/src/Web/VKHS/Types.hs @@ -10,49 +10,92 @@ -- | Access rigth to request from VK. data AccessRight - = Notify -- Пользователь разрешил отправлять ему уведомления. - | Friends -- Доступ к друзьям. - | Photos -- Доступ к фотографиям. - | Audio -- Доступ к аудиозаписям. - | Video -- Доступ к видеозаписям. - | Docs -- Доступ к документам. - | Notes -- Доступ заметкам пользователя. - | Pages -- Доступ к wiki-страницам. - | Status -- Доступ к статусу пользователя. - | Offers -- Доступ к предложениям (устаревшие методы). - | Questions -- Доступ к вопросам (устаревшие методы). - | Wall -- Доступ к обычным и расширенным методам работы со стеной. - -- Внимание, данное право доступа недоступно для сайтов (игнорируется при попытке авторизации). - | Groups -- Доступ к группам пользователя. - | Messages -- (для Standalone-приложений) Доступ к расширенным методам работы с сообщениями. - | Notifications -- Доступ к оповещениям об ответах пользователю. - | Stats -- Доступ к статистике групп и приложений пользователя, администратором которых он является. - | Ads -- Доступ к расширенным методам работы с рекламным API. - | Offline -- Доступ к API в любое время со стороннего сервера. - deriving(Show) + = Notify -- Пользователь разрешил отправлять ему уведомления. + | Friends -- Доступ к друзьям. + | Photos -- Доступ к фотографиям. + | Audio -- Доступ к аудиозаписям. + | Video -- Доступ к видеозаписям. + | Docs -- Доступ к документам. + | Notes -- Доступ заметкам пользователя. + | Pages -- Доступ к wiki-страницам. + | Status -- Доступ к статусу пользователя. + | Offers -- Доступ к предложениям (устаревшие методы). + | Questions -- Доступ к вопросам (устаревшие методы). + | Wall -- Доступ к обычным и расширенным методам работы со стеной. + -- Внимание, данное право доступа недоступно для сайтов (игнорируется при попытке авторизации). + | Groups -- Доступ к группам пользователя. + | Messages -- (для Standalone-приложений) Доступ к расширенным методам работы с сообщениями. + | Notifications -- Доступ к оповещениям об ответах пользователю. + | Stats -- Доступ к статистике групп и приложений пользователя, администратором которых он является. + | Ads -- Доступ к расширенным методам работы с рекламным API. + | Offline -- Доступ к API в любое время со стороннего сервера. + deriving(Show) +allAccess :: [AccessRight] +allAccess = + [ + -- Notify + Friends + , Photos + , Audio + , Video + , Docs + , Notes + -- , Pages + , Status + , Offers + , Questions + , Wall + , Groups + , Messages + , Notifications + , Stats + -- , Ads + -- , Offline + ] + -- See API docs http://vk.com/developers.php?oid=-1&p=Права_доступа_приложений (in -- Russian) for details -- | Verbosity level. Debug will dump *html and output curl log data Verbosity = Normal | Trace | Debug - deriving(Enum,Eq,Ord,Show) + deriving(Enum,Eq,Ord,Show) type ClientId = String +data LoginEnv = LoginEnv + { formdata :: [(String,String)] + -- ^ Dictionary containig forms input/value + , ac_rights :: [AccessRight] + -- ^ Access rights, required by later API calls + , clientId :: ClientId + -- ^ Application ID provided by vk.com + } deriving(Show) + +data CallEnv = CallEnv + { access_token :: String + -- ^ Access token, the result of login operation + } deriving(Show) + -- | VKHS environment -data Env = Env { verbose :: Verbosity - -- ^ Verbosity level - , useragent :: String - -- ^ User agent identifier, defaults to Mozilla Firefox - , formdata :: [(String,String)] - -- ^ Dictionary containig forms input/value - , clientId :: ClientId - -- ^ Application ID provided by vk.com - , delay_ms :: Int - -- ^ Delay after each transaction, in milliseconds. Library uses it for - -- preventing application from being banned for flooding. - , ac_rights :: [AccessRight] - -- ^ Access rights, required by later API calls - } deriving (Show) +data Env subenv = Env + { sub :: subenv + , verbose :: Verbosity + -- ^ Verbosity level + , useragent :: String + -- ^ User agent identifier, defaults to Mozilla Firefox + , delay_ms :: Int + -- ^ Delay after each transaction, in milliseconds. Library uses it for + -- preventing application from being banned for flooding. + } deriving (Show) + +mkEnv :: s -> Env s +mkEnv x = Env + x + Normal + "Mozilla/5.0 (X11; Linux x86_64; rv:12.0) Gecko/20120702 Firefox/12.0" + 500 + +callEnv :: Env a -> String -> Env CallEnv +callEnv (Env _ a b c) at = Env (CallEnv at) a b c