VKHS (empty) → 0.0.1
raw patch · 7 files changed
+401/−0 lines, 7 filesdep +basedep +bimapdep +bytestringsetup-changed
Dependencies added: base, bimap, bytestring, containers, curlhs, failure, mtl, parsec, safe, split, tagsoup, tagsoup-parsec, template-haskell, transformers, utf8-string
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- VKHS.cabal +49/−0
- src/Web/VKHS.hs +9/−0
- src/Web/VKHS/Api.hs +25/−0
- src/Web/VKHS/Login.hs +227/−0
- src/Web/VKHS/Types.hs +59/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Sergey Mironov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Sergey Mironov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ VKHS.cabal view
@@ -0,0 +1,49 @@+-- Initial vk.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/++name: VKHS+version: 0.0.1+synopsis: Provides access to VkontakteAPI (Popular Russian social network)+description:+ Library written in Haskell provides access to Vkontakte API methods (popular+ Russian social network).++ Internally, library uses small curl-based HTTP automata and tagsoup for jumping+ over relocations and submitting various 'Yes I agree' forms.++license: BSD3+license-file: LICENSE+author: Sergey Mironov+maintainer: ierton@gmail.com+copyright: Copyright (c) 2012, Sergey Mironov+category: Web+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: https://github.com/ierton/vkhs.git++library+ hs-source-dirs: src+ exposed-modules: Web.VKHS+ Web.VKHS.Types+ Web.VKHS.Login+ Web.VKHS.Api++ build-depends: base ==4.5.*,+ containers ==0.4.*,+ tagsoup-parsec ==0.0.*,+ tagsoup ==0.12.*,+ mtl ==2.1.*,+ failure ==0.2.*,+ bytestring ==0.9.*,+ curlhs ==0.0.*,+ safe ==0.3.*,+ parsec ==3.1.*,+ split ==0.2.*,+ utf8-string ==0.3.*,+ bimap ==0.2.*,+ template-haskell ==2.7.*,+ transformers ==0.3.*+
+ src/Web/VKHS.hs view
@@ -0,0 +1,9 @@+module Web.VKHS+ ( module Web.VKHS.Login+ , module Web.VKHS.Types+ , module Web.VKHS.Api+ ) where++import Web.VKHS.Types+import Web.VKHS.Login+import Web.VKHS.Api
+ src/Web/VKHS/Api.hs view
@@ -0,0 +1,25 @@+module Web.VKHS.Api where++import Control.Monad.Writer++import Data.Label+import qualified Data.ByteString.Char8 as BS++import Network.Curlhs.Core++import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Protocol.Uri.Query++import Text.Printf++import Web.VKHS.Types+import Web.VKHS.Curl++api :: Env -> AccessToken -> String -> Parameters -> IO (Either String String)+api e (at,_,_) 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)+ in vk_curl e $ do+ tell [CURLOPT_URL uri]+
+ src/Web/VKHS/Login.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE FlexibleContexts #-}++module Web.VKHS.Login+ ( login+ , Env(..)+ , env+ , AccessRight(..)+ , Verbosity(..)+ ) where++import Prelude hiding ((.), id, catch)++import Control.Applicative+import Control.Category+import Control.Exception+import Control.Failure+import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.Writer+import qualified Control.Monad.State as S++import qualified Data.ByteString.Char8 as BS+import Data.List+import Data.String+import Data.Char+import Data.Monoid+import Data.Either+import Data.Label+import qualified Data.Map as M+import Data.Maybe+import Data.Typeable++import Network.Curlhs.Core+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Protocol.Uri.Query+import Network.Protocol.Cookie as C+import Network.Shpider.Forms++import Text.HTML.TagSoup+import Text.Printf+import System.IO++import Web.VKHS.Types+import Web.VKHS.Curl++-- Test applications: +--+-- pirocheck+-- ID 3115622+-- Key IOmaB10C1v7RoMiM6Lnu+--+-- pirofetch+-- ID 3082266+-- Key <lost>++type Url = String+type Email = String+type Uid = String+type Password = String+type Body = String++toarg :: [AccessRight] -> String+toarg = intercalate "," . map (map toLower . show)++-- | Gathers login information into Env data set. +env :: String + -- ^ Client ID (provided by Application registration form)+ -> String+ -- ^ User email, able to authenticate the user+ -> String+ -- ^ User password+ -> [AccessRight]+ -- ^ 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"+ [ ("email",email) , ("pass",pwd) ]+ cid+ 500+ ar++vk_start_action :: ClientId -> [AccessRight] -> Action+vk_start_action cid ac = OpenUrl start_url mempty where+ start_url = (\f -> f $ toUri "http://oauth.vk.com/authorize") + $ set query $ bw params+ [ ("client_id", cid)+ , ("scope", toarg ac)+ , ("redirect_uri", "http://oauth.vk.com/blank.html")+ , ("display", "wap")+ , ("response_type", "token")+ ]++type FilledForm = Form++type VK a = ReaderT Env (ErrorT String IO) a++runVK :: Env -> VK a -> IO (Either String a)+runVK e vk = runErrorT (runReaderT vk e)++liftVK :: IO (Either String a) -> VK a+liftVK m = liftIO m >>= either fail return++dbgVK :: Verbosity -> IO () -> VK ()+dbgVK v act = ask >>= \e -> do+ if v > (verbose e) then return ()+ else liftIO $ act++when_debug = dbgVK Debug+when_trace = dbgVK Trace++type Page = (Http Response, Body)++-- | Browser action+data Action = OpenUrl Uri Cookies | SendForm Form Cookies+ deriving (Show)++-- | Url assotiated with Action+actionUri :: Action -> Uri+actionUri (OpenUrl u _) = u+actionUri (SendForm f _) = toUri . action $ f++liftEIO act = (liftIO act) >>= either fail return++-- | Send a get-request to the server+vk_get :: Uri -> Cookies -> VK Page+vk_get u c = let+ c' = (BS.pack $ bw cookie $ map toShort $ bw gather c )+ u' = (BS.pack $ showUri u)+ in do+ e <- ask+ s <- liftEIO $ vk_curl e $ do+ when ((not . BS.null) c') $ do+ tell [CURLOPT_COOKIE c']+ when ((not . BS.null) u') $ do+ tell [CURLOPT_URL u']+ liftVK (return $ parseResponse s)++-- | Send a form to the server.+vk_post :: FilledForm -> Cookies -> VK Page+vk_post f c = let+ c' = (BS.pack $ bw cookie $ map toShort $ bw gather c )+ p' = (BS.pack $ bw params $ M.toList $ inputs f)+ u' = (BS.pack $ action f)+ in do+ e <- ask+ s <- liftEIO $ vk_curl e $ do+ when ((not . BS.null) c') $ do+ tell [CURLOPT_COOKIE c']+ when ((not . BS.null) u') $ do+ tell [CURLOPT_URL u']+ tell [CURLOPT_POST True]+ tell [CURLOPT_COPYPOSTFIELDS p']+ liftVK (return $ parseResponse s)+ +-- | Splits parameters into 3 categories:+-- 1)without a value, 2)filled from user dictionary, 3)with default values+split_inputs :: [(String,String)]+ -- ^ User dictionary+ -> M.Map String String+ -- ^ Form fields with default values (default is valid if non-zero)+ -> (M.Map String (), M.Map String String, M.Map String String)+split_inputs d m =+ let (b,g) = M.mapEitherWithKey (match_field d) m+ in (b, M.map (either id id) g, snd (M.mapEither id g))+ where+ match_field d k a+ | not (null a) = maybe ((Right . Left) a) (Right . Right) u+ | otherwise = maybe (Left ()) (Right . Right) u+ where u = lookup k d++vk_fill_form :: Form -> VK FilledForm+vk_fill_form f = ask >>= \e -> do+ let (bad,good,user) = split_inputs (formdata 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+vk_move :: Action -> VK (Page, Cookies)+vk_move (OpenUrl u c) = do+ (h,b) <- (vk_get u c)+ return ((h,b),c`mappend`(get setCookies h))+vk_move (SendForm f c) = do+ f' <- vk_fill_form f+ (h,b) <- (vk_post f' c)+ return ((h,b),c`mappend`(get setCookies h))++uri_fragment :: Http Response -> Maybe AccessToken+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?)"+ where+ l = get location h+ f = parseTags >>> gatherForms $ b+ a = uri_fragment h++vk_dump_page :: Int -> Uri -> Page -> IO ()+vk_dump_page n u (h,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)++-- | Executes login procedure. AccessToken is returned 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+ 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+ case a of+ Right act' -> do+ loop (n+1) act'+ Left at -> do+ return at+
+ src/Web/VKHS/Types.hs view
@@ -0,0 +1,59 @@+module Web.VKHS.Types where++-- | 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.+type AccessToken = (String,String,String)++-- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений+-- (in Russian) for more details++-- | Access rigth to request from VK.+-- See API docs http://vk.com/developers.php?oid=-1&p=Права_доступа_приложений (in+-- Russian) for details+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)++-- | Verbosity level. Setting Debug results in dumping *html files+data Verbosity = Normal | Trace | Debug+ deriving(Enum,Eq,Ord,Show)++type ClientId = String++-- | VKHS environment+data Env = Env+ { verbose :: Verbosity+ -- ^ Verbosity level+ , useragent :: String+ -- ^ User agent identifier. Has an affordable default.+ , formdata :: [(String,String)]+ -- ^ A dictionary used for filling forms+ , clientId :: ClientId+ -- ^ Application ID provided by vk.com+ , delay_ms :: Int+ -- ^ Delay in milliseconds. Set after each request to prevent application+ -- from being blocked for flooding.+ , ac_rights :: [AccessRight]+ -- ^ Access rights to request+ }+ deriving (Show)+