diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -1,7 +1,7 @@ name: VKHS -version: 0.2.0 -synopsis: Provides access to Vkontakte social network +version: 0.3.0 +synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction with the user during Implicit-flow authentication. @@ -29,7 +29,8 @@ 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 exposed-modules: Web.VKHS Web.VKHS.API - Web.VKHS.API.JSON + Web.VKHS.API.Aeson + Web.VKHS.API.Types Web.VKHS.Curl Web.VKHS.Login Web.VKHS.Types @@ -51,5 +52,13 @@ template-haskell ==2.8.*, transformers ==0.3.*, fclabels >=1.1.4 && <1.1.6, - optparse-applicative >=0.4 && <0.6 + optparse-applicative >=0.4 && <0.6, + aeson >= 0.6 && < 0.7, + filepath, + directory, + regexpr, + pretty-show, + vector, + text + diff --git a/src/VKQ.hs b/src/VKQ.hs --- a/src/VKQ.hs +++ b/src/VKQ.hs @@ -1,13 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Main where import Control.Monad +import Control.Monad.Error +import Data.Aeson as A import Data.Label.Abstract +import Data.Typeable +import Data.Data +import Data.List +import Data.Maybe +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as U import Network.Protocol.Uri.Query import Options.Applicative +import System.Directory import System.Exit +import System.FilePath +import System.Environment import System.IO import Text.Printf +import Text.PFormat (pformat) +import Text.Namefilter (namefilter) +import Text.Show.Pretty as PP import Web.VKHS +import Web.VKHS.Curl +import Web.VKHS.API.Aeson as A +import Web.VKHS.API as STR data Options = Options { verb :: Verbosity @@ -17,6 +39,9 @@ data CmdOptions = Login LoginOptions | Call CallOptions + | Music MusicOptions + | UserQ UserOptions + | WallQ WallOptions deriving(Show) data LoginOptions = LoginOptions @@ -25,50 +50,228 @@ , password :: String } deriving(Show) -data CallOptions = CallOptions +data CallOptions = CO { accessToken :: String + , parse :: Bool , method :: String , args :: String } deriving(Show) +data MusicOptions = MO + { accessToken_m :: String + , list_music :: Bool + , search_string :: String + , name_format :: String + , output_format :: String + , out_dir :: String + , records_id :: [String] + } deriving(Show) + +data UserOptions = UO + { accessToken_u :: String + , queryString :: String + } deriving(Show) + +data WallOptions = WO + { accessToken_w :: String + , oid :: String + } deriving(Show) + loginOptions :: Parser CmdOptions loginOptions = Login <$> (LoginOptions - <$> argument str (metavar "APPID" & help "Application identifier (provided to you by vk.com)") + <$> strOption (metavar "APPID" & short 'a' & value "3128877" & help "Application ID, defaults to VKHS" ) <*> 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 +opts m = + let access_token_flag = strOption (short 'a' & m & metavar "ACCESS_TOKEN" & + help "Access token. Honores VKQ_ACCESS_TOKEN environment variable") + in 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)" )) + ( progDesc "Login and print access token (also prints user_id and expiriration time)" )) + & command "call" (info (Call <$> (CO + <$> access_token_flag + <*> switch (long "preparse" & short 'p' & help "Preparse into Aeson format") + <*> argument str (metavar "METHOD" & help "Method name") + <*> argument str (metavar "PARAMS" & help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]"))) + ( progDesc "Call VK API method" )) + & command "music" (info ( Music <$> (MO + <$> access_token_flag + <*> switch (long "list" & short 'l' & help "List music files") + <*> strOption + ( metavar "STR" + & long "query" & short 'q' & value [] & help "Query string") + <*> strOption + ( metavar "FORMAT" + & short 'f' + & value "%o_%i %u\t%t" + & help "Listing format, supported tags: %i %o %a %t %d %u" + ) + <*> strOption + ( metavar "FORMAT" + & short 'F' + & value "%a - %t" + & help "FileName format, supported tags: %i %o %a %t %d %u" + ) + <*> strOption (metavar "DIR" & short 'o' & help "Output directory" & value "") + <*> arguments str (metavar "RECORD_ID" & help "Download records") + )) + ( progDesc "List or download music files")) + & command "user" (info ( UserQ <$> (UO + <$> access_token_flag + <*> strOption (long "query" & short 'q' & help "String to query") + )) + ( progDesc "Extract various user information")) + & command "wall" (info ( WallQ <$> (WO + <$> access_token_flag + <*> strOption (long "id" & short 'i' & help "Owner id") + )) + ( progDesc "Extract wall information")) ) +api_ :: (A.FromJSON a) => Env CallEnv -> String -> [(String,String)] -> IO a +api_ a b c = do + r <- A.api' a b c + case r of + Right x -> return x + Left e -> hPutStrLn stderr e >> exitFailure + +api_str :: Env CallEnv -> String -> [(String,String)] -> IO String +api_str a b c = do + r <- STR.api a b c + case r of + Right x -> return (U.toString x) + Left e -> hPutStrLn stderr e >> exitFailure + +mr_format :: String -> MusicRecord -> String +mr_format s mr = pformat '%' + [ ('i', show . aid) + , ('o', show . owner_id) + , ('a', namefilter . artist) + , ('t', namefilter . title) + , ('d', show . duration) + , ('u', url) + ] s mr + ifeither e fl fr = either fl fr e errexit e = hPutStrLn stderr e >> exitFailure +checkRight (Left e) = hPutStrLn stderr e >> exitFailure +checkRight (Right a) = return a + +main :: IO () +main = do + m <- maybe (idm) (value) <$> lookupEnv "VKQ_ACCESS_TOKEN" + execParser (info (opts m) idm) >>= cmd + cmd :: Options -> IO () + +-- Login 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 +-- Call user-specified API +cmd (Options v (Call (CO act pp mn args))) = do let e = (envcall act) { verbose = v } - ea <- api e mn (fw (keyValues "," "=") args) - ifeither ea errexit putStrLn + let s = fw (keyValues "," "=") args + case pp of + False -> do + ea <- api_str e mn s + putStrLn (show ea) + True -> do + (ea :: A.Value) <- api_ e mn s + putStrLn $ PP.ppShow ea -main :: IO () -main = execParser (info opts idm) >>= cmd +-- Query audio files +cmd (Options v (Music mo@(MO act _ q@(_:_) fmt _ _ _))) = do + let e = (envcall act) { verbose = v } + Response (SL len ms) <- api_ e "audio.search" [("q",q)] + forM_ ms $ \m -> do + printf "%s\n" (mr_format fmt m) + printf "total %d\n" len + +-- List audio files +cmd (Options v (Music mo@(MO act True [] fmt _ _ _))) = do + let e = (envcall act) { verbose = v } + (Response ms) <- api_ e "audio.get" [] + forM_ ms $ \m -> do + printf "%s\n" (mr_format fmt m) +cmd (Options v (Music mo@(MO act False [] _ ofmt odir []))) = do + errexit "Music record ID is not specified (see --help)" + +-- Download audio files +cmd (Options v (Music mo@(MO act False [] _ ofmt odir rid))) = do + let e = (envcall act) { verbose = v } + Response ms <- api_ e "audio.getById" [("audios", concat $ intersperse "," rid)] + forM_ ms $ \m -> do + (fp, h) <- openFileMR odir ofmt m + r <- vk_curl_file e (url m) $ \ bs -> do + BS.hPut h bs + checkRight r + printf "%d_%d\n" (owner_id m) (aid m) + printf "%s\n" (title m) + printf "%s\n" fp + +cmd (Options v (UserQ uo@(UO act qs))) = do + let e = (envcall act) { verbose = v } + print qs + ea <- A.api e "users.search" [("q",qs),("fields","uid,first_name,last_name,photo,education")] + putStrLn $ show ea + -- ae <- checkRight ea + -- processUQ uo ae + +-- List wall messages +cmd (Options v (WallQ mo@(WO act wid))) = do + let e = (envcall act) { verbose = v } + (Response (SL len ws)) <- api_ e "wall.get" [("owner_id",wid)] + forM_ ws $ \w -> do + putStrLn (show $ wdate w) + putStrLn (wtext w) + printf "total %d\n" len + +type NameFormat = String + +openFileMR :: FilePath -> NameFormat -> MusicRecord -> IO (FilePath, Handle) +openFileMR [] _ m = do + let (_,ext) = splitExtension (url m) + temp <- getTemporaryDirectory + (fp,h) <- openBinaryTempFile temp ("vkqmusic"++ext) + return (fp,h) +openFileMR dir fmt m = do + let (_,ext) = splitExtension (url m) + let name = mr_format fmt m + let name' = replaceExtension name ext + let fp = (dir name') + h <- openBinaryFile fp WriteMode + return (fp,h) + +-- data Collection a = MC { +-- response :: [a] +-- } deriving (Show,Data,Typeable) + +-- processMC :: MusicOptions -> Collection MusicRecord -> IO () +-- processMC (MO _ _ _) (MC r) = do +-- forM_ r $ \m -> do +-- printf "%d_%d|%s|%s|%s\n" (owner_id m) (aid m) (artist m) (title m) (url m) + +-- processMC (MO _ rid False) (MC r) = do +-- print r + +-- parseUsers :: JSValue -> Maybe [JSValue] +-- parseUsers (JSObject (JSONObject [("response",(JSArray a))])) = Just a +-- parseUsers _ = Nothing + +-- processUQ :: UserOptions -> JSValue -> IO () +-- processUQ (UO _ _) j = do + -- let (Just u) = parseUsers j + -- a <- fromJS (u !! 1) + -- print $ show (a :: UserRecord) + -- print $ show $ j + 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 @@ -9,7 +9,8 @@ import Control.Monad.Error import Data.Label -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.UTF8 as U +import qualified Data.ByteString as BS import Network.Curlhs.Core @@ -35,12 +36,9 @@ -- ^ API method name -> [(String, String)] -- ^ API method parameters (name-value pairs) - -> IO (Either String String) + -> IO (Either String BS.ByteString) 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",(access_token . sub) e):mp) - in runErrorT $ do - r <- ErrorT $ vk_curl e (tell [CURLOPT_URL uri]) - (_,b) <- ErrorT $ return $ parseResponse r - return b + let uri = showUri $ (\f -> f $ toUri $ printf "https://api.vk.com/method/%s" mn) $ + set query $ bw params (("access_token",(access_token . sub) e):mp) + in vk_curl_payload e (tell [CURLOPT_URL $ U.fromString uri]) diff --git a/src/Web/VKHS/API/Aeson.hs b/src/Web/VKHS/API/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Web/VKHS/API/Aeson.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.VKHS.API.Aeson + ( api + , api' + , module Web.VKHS.API.Types + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Writer +import Control.Monad.Error + +import Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.Aeson (FromJSON, (.:), (.:?)) +import Data.Aeson.Generic as AG +import Data.ByteString.Lazy as BS +import Data.Typeable +import Data.Data +import Data.Vector as V (head, tail, toList) + +import Web.VKHS.Types +import Web.VKHS.API.Types +import qualified Web.VKHS.API as Base + +instance (FromJSON a) => FromJSON (Response a) where + parseJSON (A.Object v) = do + a <- v .: "response" + x <- A.parseJSON a + return (Response x) + +parseGeneric a = + case AG.fromJSON a of + A.Success a -> return a + A.Error s -> fail $ "parseGeneric fails:" ++ s + +instance FromJSON MusicRecord where + parseJSON = parseGeneric + +instance FromJSON WallRecord where + parseJSON (Object o) = + WR <$> (o .: "id") + <*> (o .: "to_id") + <*> (o .: "from_id") + <*> (o .: "text") + <*> (o .: "date") + +instance (FromJSON a) => FromJSON (SizedList [a]) where + parseJSON (A.Array v) = do + n <- A.parseJSON (V.head v) + t <- A.parseJSON (A.Array (V.tail v)) + return (SL n t) + +api' :: (A.FromJSON a) => Env CallEnv -> String -> [(String,String)] -> IO (Either String a) +api' e mn mp = runErrorT $ do + e <- ErrorT (Base.api e mn mp) + let check (Just x) = return x + check (Nothing) = fail $ "AESON: error parsing JSON: " ++ show e + check $ A.decode $ BS.fromStrict e + +api :: Env CallEnv -> String -> [(String,String)] -> IO (Either String A.Value) +api = api' + diff --git a/src/Web/VKHS/API/JSON.hs b/src/Web/VKHS/API/JSON.hs deleted file mode 100644 --- a/src/Web/VKHS/API/JSON.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Web.VKHS.API.JSON - ( api - ) where - -import Control.Monad -import Control.Monad.Trans -import Control.Monad.Writer -import Control.Monad.Error - -import Text.JSON as J - -import Web.VKHS.Types -import qualified Web.VKHS.API as Base - -liftR (Ok a) = return a -liftR (Error s) = fail s - -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/API/Types.hs b/src/Web/VKHS/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/VKHS/API/Types.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Web.VKHS.API.Types where + +import Data.Typeable +import Data.Data +import Data.Text + +data Response a = Response a + deriving(Show) + +data SizedList a = SL Int a + +data MusicRecord = MR + { aid :: Int + , owner_id :: Int + , artist :: String + , title :: String + , duration :: Int + , url :: String + } deriving (Show, Data, Typeable) + + +data UserRecord = UR + { uid :: Int + , first_name :: String + , last_name :: String + , photo :: String + , university :: Maybe Int + , university_name :: Maybe String + , faculty :: Maybe Int + , faculty_name :: Maybe String + , graduation :: Maybe Int + } deriving(Show,Data,Typeable) + + +data WallRecord = WR + { wid :: Int + , to_id :: Int + , from_id :: Int + , wtext :: String + , wdate :: Int + } deriving(Show) + + 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 @@ -1,22 +1,36 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Web.VKHS.Curl (vk_curl) where +module Web.VKHS.Curl + ( vk_curl + , vk_curl_file + , vk_curl_payload + , pack + , unpack + ) where -import Prelude hiding (catch) +import Data.IORef (newIORef, readIORef, atomicModifyIORef) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS (c2w, w2c) + +import Control.Applicative import Control.Exception (catch,bracket) import Control.Concurrent (threadDelay) import Control.Monad.Writer -import Data.IORef (newIORef, readIORef, atomicModifyIORef) -import qualified Data.ByteString.UTF8 as U + import Network.Curlhs.Core +import Prelude hiding (catch) + +import System.IO + import Web.VKHS.Types -import qualified Data.ByteString.Char8 as BS --- | Generic request sender. Uses delay to prevent application from being --- blocked for flooding -vk_curl :: Env a -> Writer [CURLoption] () -> IO (Either String String) +pack = BS.pack . map BS.c2w +unpack = map BS.w2c . BS.unpack + +-- | Generic request sender. Returns whole HTTP answer as a ByteString +vk_curl :: Env a -> Writer [CURLoption] () -> IO (Either String BS.ByteString) vk_curl e w = do let askE x = return (x e) v <- askE verbose @@ -33,13 +47,130 @@ [ CURLOPT_HEADER True , CURLOPT_WRITEFUNCTION (Just $ memwrite) , CURLOPT_SSL_VERIFYPEER False - , CURLOPT_USERAGENT $ BS.pack a + , CURLOPT_USERAGENT $ BS.pack $ map BS.c2w a , CURLOPT_VERBOSE (v == Debug ) ] ++ (execWriter w); curl_easy_perform curl; - threadDelay (1000 * d); -- delay in microseconds + threadDelay (1000 * d); -- convert ms to us b <- readIORef buff ; - return (Right $ U.toString b) ; + return (Right b) ; + } `catch` + (\(e::CURLcode) -> return $ Left ("CURL error: " ++ (show e))) + +scanPattern pat s = + let (_,o,x,n) = BS.foldl' check (False, BS.empty, BS.empty, BS.empty) s + in (BS.reverse o, x, BS.reverse n) + where + check (False, old, st, new) b + | BS.length st < BS.length pat = (False, old, st`BS.snoc`b, new) + | st == pat = (True, old, st, b`BS.cons`new) + | otherwise = (False, (BS.head st)`BS.cons`old, (BS.tail st)`BS.snoc`b, new) + check (True, old, st, new) b = (True, old, st, b`BS.cons`new) + +cutheader :: BS.ByteString -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +cutheader buf new = + let + buf' = BS.append buf new + overfill = BS.length buf' >= 1024 + (_,p,t) = scanPattern (BS.pack $ map BS.c2w "\r\n\r\n") buf' + in case (overfill, BS.null t) of + (True, True) -> Nothing + (False, True) -> Just (buf', t) + (_, False) -> Just (buf', t) + +data State = Pending BS.ByteString | Working BS.ByteString | FailNoHeader + +process :: State -> BS.ByteString -> State +process s@(Pending b) bs = + case cutheader b bs of + Nothing -> FailNoHeader + Just (b', t) + | BS.null t -> (Pending b') + | otherwise -> (Working t) +process s@(Working _) bs = (Working bs) +process s _ = s + +-- | Downloads the file and saves it on disk +vk_curl_file + :: Env a + -- ^ User environment + -> String + -- ^ URL + -> (BS.ByteString -> IO ()) + -- ^ File write handler + -> IO (Either String ()) +vk_curl_file e url cb = do + let askE x = return (x e) + v <- askE verbose + a <- askE useragent + d <- askE delay_ms + do + sr <- newIORef =<< (Pending <$> pure BS.empty) + + bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do { + let + filewrite bs = do + s' <- atomicModifyIORef sr (\s -> let s' = process s bs in (s',s')) + case s' of + FailNoHeader -> return CURL_WRITEFUNC_FAIL + Pending b -> return CURL_WRITEFUNC_OK + Working t -> do + cb t + return CURL_WRITEFUNC_OK + in + curl_easy_setopt curl $ + [ CURLOPT_HEADER True + , CURLOPT_WRITEFUNCTION (Just $ filewrite) + , CURLOPT_SSL_VERIFYPEER False + , CURLOPT_USERAGENT $ BS.pack $ map BS.c2w a + , CURLOPT_VERBOSE (v == Debug) + , CURLOPT_URL (BS.pack $ map BS.c2w url) + ]; + + curl_easy_perform curl; + threadDelay (1000 * d); -- convert ms to us + s <- readIORef sr; + case s of + Working _ -> return $ Right () + _ -> return $ Left "HTTP header detection failure" + } `catch` + (\(e::CURLcode) -> return $ Left ("CURL error: " ++ (show e))) + + +-- | Return HTTP payload, ignore headers +vk_curl_payload :: Env a -> Writer [CURLoption] () -> IO (Either String BS.ByteString) +vk_curl_payload e w = do + let askE x = return (x e) + v <- askE verbose + a <- askE useragent + d <- askE delay_ms + do + sr <- newIORef (BS.empty, Pending BS.empty) + + bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do { + let + writer bs = do + atomicModifyIORef sr (\(buff,s) -> let s' = process s bs ; paired x =(x,x) in + case s' of + FailNoHeader -> paired (buff,s') + Pending b -> paired (buff,s') + Working t -> paired (BS.append buff t,s')) + return CURL_WRITEFUNC_OK + + in + curl_easy_setopt curl $ + [ CURLOPT_HEADER True + , CURLOPT_WRITEFUNCTION (Just $ writer) + , CURLOPT_SSL_VERIFYPEER False + , CURLOPT_USERAGENT $ BS.pack $ map BS.c2w a + , CURLOPT_VERBOSE (v == Debug) + ] ++ (execWriter w); + curl_easy_perform curl; + threadDelay (1000 * d); -- convert ms to us + (buff,s) <- readIORef sr; + case s of + Working _ -> return $ Right buff + _ -> return $ Left "HTTP header detection failure" } `catch` (\(e::CURLcode) -> return $ Left ("CURL error: " ++ (show e))) 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 @@ -17,7 +17,7 @@ import Control.Monad.Writer import qualified Control.Monad.State as S -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString as BS import Data.List import Data.String import Data.Char @@ -40,7 +40,7 @@ import System.IO import Web.VKHS.Types -import Web.VKHS.Curl +import Web.VKHS.Curl as VKHS -- Test applications: -- @@ -129,8 +129,8 @@ -- | 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) + c' = (VKHS.pack $ bw cookie $ map toShort $ bw gather c ) + u' = (VKHS.pack $ showUri u) in do e <- ask s <- liftEIO $ vk_curl e $ do @@ -138,14 +138,14 @@ tell [CURLOPT_COOKIE c'] when ((not . BS.null) u') $ do tell [CURLOPT_URL u'] - liftVK (return $ parseResponse s) + liftVK (return $ parseResponse $ VKHS.unpack 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) + c' = (VKHS.pack $ bw cookie $ map toShort $ bw gather c ) + p' = (VKHS.pack $ bw params $ M.toList $ inputs f) + u' = (VKHS.pack $ action f) in do e <- ask s <- liftEIO $ vk_curl e $ do @@ -155,7 +155,7 @@ tell [CURLOPT_URL u'] tell [CURLOPT_POST True] tell [CURLOPT_COPYPOSTFIELDS p'] - liftVK (return $ parseResponse s) + liftVK (return $ parseResponse $ VKHS.unpack s) -- | Splits parameters into 3 categories: -- 1)without a value, 2)filled from user dictionary, 3)with default values