VKHS 0.1.6 → 0.2.0

raw patch · 9 files changed

+239/−84 lines, 9 filesdep +optparse-applicativedep ~fclabelsnew-component:exe:vkqPVP ok

version bump matches the API change (PVP)

Dependencies added: optparse-applicative

Dependency ranges changed: fclabels

API changes (from Hackage documentation)

Files

• VKHS.cabal +9/−4
• src/Test/API.hs +6/−5
• src/VKQ.hs +74/−0
• src/Web/VKHS.hs +1/−0
• src/Web/VKHS/API.hs +17/−3
• src/Web/VKHS/API/JSON.hs +3/−2
• src/Web/VKHS/Curl.hs +1/−1
• src/Web/VKHS/Login.hs +50/−34
• src/Web/VKHS/Types.hs +78/−35

@@ -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 

@@ -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

@@ -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+

@@ -82,3 +82,4 @@ import Web.VKHS.Types import Web.VKHS.Login import Web.VKHS.API+

@@ -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:+--+-- <http://vk.com/developers.php?oid=-1&p=%D0%9E%D0%BF%D0%B8%D1%81%D0%B0%D0%BD%D0%B8%D0%B5_%D0%BC%D0%B5%D1%82%D0%BE%D0%B4%D0%BE%D0%B2_API>+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

@@ -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+

@@ -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

@@ -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 

@@ -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