VKHS 1.7.2 → 1.7.3
raw patch · 12 files changed
+367/−96 lines, 12 files
Files
- README.md +3/−2
- VKHS.cabal +1/−1
- app/vkq/Main.hs +44/−6
- src/Web/VKHS.hs +17/−12
- src/Web/VKHS/API/Base.hs +41/−6
- src/Web/VKHS/API/Simple.hs +81/−9
- src/Web/VKHS/API/Types.hs +122/−23
- src/Web/VKHS/Client.hs +15/−5
- src/Web/VKHS/Error.hs +17/−8
- src/Web/VKHS/Login.hs +9/−6
- src/Web/VKHS/Monad.hs +13/−17
- src/Web/VKHS/Types.hs +4/−1
README.md view
@@ -131,9 +131,10 @@ Limitations ===========-* Implicit-flow authentication, see [documentation in- Russian](http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений)+* Implicit-flow authentication, see+ [documentation in Russian](http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений) for details+* [VK API documentation](https://vk.com/dev/methods) License =======
VKHS.cabal view
@@ -1,6 +1,6 @@ name: VKHS-version: 1.7.2+version: 1.7.3 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction
app/vkq/Main.hs view
@@ -14,17 +14,20 @@ import Data.Char import Data.Text(Text(..),pack, unpack) import qualified Data.Text as Text+import Data.Text.IO(putStrLn, hPutStrLn) import qualified Data.Text.IO as Text import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS+import Data.Monoid((<>)) import Options.Applicative import qualified Sound.TagLib as TagLib import System.Environment import System.Exit-import System.IO+import System.IO(stderr) import Text.RegexPR import Text.Printf import Text.Show.Pretty+import Prelude hiding(putStrLn) import Web.VKHS import Web.VKHS.Types@@ -51,6 +54,11 @@ l_eval :: Bool } deriving(Show) +data PhotoOptions = PhotoOptions {+ p_listAlbums :: Bool+ , p_uploadServer :: Bool+ } deriving(Show)+ data Options = Login GenericOptions LoginOptions | API GenericOptions APIOptions@@ -59,6 +67,7 @@ | WallQ GenericOptions WallOptions | GroupQ GenericOptions GroupOptions | DBQ GenericOptions DBOptions+ | Photo GenericOptions PhotoOptions deriving(Show) toMaybe :: (Functor f) => f String -> f (Maybe String)@@ -154,6 +163,12 @@ <*> flag False True (long "list-cities" <> help "List known cities") )) ( progDesc "Extract generic DB information"))++ <> command "photo" (info ( Photo <$> genericOptions <*> (PhotoOptions+ <$> flag False True (long "list-albums" <> help "List Albums")+ <*> flag False True (long "upload-server" <> help "Get upload server")+ ))+ ( progDesc "Photo-related queries")) ) main :: IO ()@@ -168,7 +183,7 @@ Right _ -> do return () )`catch` (\(e::SomeException) -> do- putStrLn $ (show e)+ putStrLn $ Text.pack (show e) exitFailure ) @@ -181,14 +196,14 @@ -} -cmd :: Options -> ExceptT String IO ()+cmd :: Options -> ExceptT Text IO () -- Login cmd (Login go LoginOptions{..}) = do AccessToken{..} <- runLogin go case l_eval of- True -> liftIO $ putStrLn $ printf "export %s=%s\n" env_access_token at_access_token- False -> liftIO $ putStrLn at_access_token+ True -> liftIO $ putStrLn $ Text.pack $ printf "export %s=%s\n" env_access_token at_access_token+ False -> liftIO $ putStrLn $ Text.pack at_access_token -- API / CALL cmd (API go APIOptions{..}) = do@@ -253,7 +268,7 @@ ensureUnicode = unpack . pack Nothing -> do- io $ hPutStrLn stderr ("File " ++ f ++ " already exist, skipping")+ io $ hPutStrLn stderr ("File " <> Text.pack f <> " already exist, skipping") return () -- Download audio files@@ -299,3 +314,26 @@ |db_cities = do error "not implemented"++cmd (Photo go PhotoOptions{..})++ |p_listAlbums = do+ runAPI go $ do+ (Sized cnt als) <- getAlbums Nothing+ forM_ als $ \Album{..} -> do+ liftIO $ Text.putStrLn $ Text.concat [ tshow al_id, "\t", al_title]++ |p_uploadServer = do+ runAPI go $ do+ (Sized cnt als) <- getAlbums Nothing+ let album = [a | a <- als, al_id a == -7]+ case album of+ [a] -> do+ PhotoUploadServer{..} <- getPhotoUploadServer a+ liftIO $ Text.putStrLn pus_upload_url+ _ ->+ error "Ivalid album"++ |otherwise = do+ error "invalid command line arguments"+
src/Web/VKHS.hs view
@@ -21,6 +21,7 @@ import Data.Maybe import Data.Time import Data.Either+import Data.Monoid((<>)) import Data.Text(Text) import qualified Data.Text as Text import Control.Applicative@@ -69,9 +70,9 @@ instance ToGenericOptions State where toGenericOptions = go -initialState :: GenericOptions -> ExceptT String IO State+initialState :: (MonadIO m) => GenericOptions -> m State initialState go = State- <$> lift (Client.defaultState go)+ <$> liftIO (Client.defaultState go) <*> pure (Login.defaultState go) <*> pure (API.defaultState) <*> pure go@@ -82,7 +83,7 @@ -- | Main VK monad able to track errors, track full state @State@, set -- early exit by the means of continuation monad. See @runVK@-newtype VK r a = VK { unVK :: Guts VK (StateT State (ExceptT String IO)) r a }+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@@ -92,10 +93,10 @@ instance MonadAPI VK r State -- | Run the VK script, return final state and error status-stepVK :: VK r r -> StateT State (ExceptT String IO) r+stepVK :: VK r r -> StateT State (ExceptT Text IO) r stepVK m = runContT (runReaderT (unVK (VKHS.catch m)) undefined) return -defaultSuperviser :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT String IO) a+defaultSuperviser :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT Text IO) a defaultSuperviser = go where go m = do GenericOptions{..} <- toGenericOptions <$> get@@ -107,26 +108,30 @@ alert "UnexpectedInt (ignoring)" go (k 0) UnexpectedFormField (Form tit f) i k -> do- alert $ "While filling form " ++ (printForm "" f)+ alert $ "While filling form " <> (printForm "" f) case o_allow_interactive of True -> do v <- do- alert $ "Please, enter the correct value for input " ++ i ++ " : "+ alert $ "Please, enter the correct value for input " <> tpack i <> " : " liftIO $ getLine go (k v) False -> do- alert $ "Unable to query value for " ++ i ++ " since interactive mode is disabled"+ 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 ()) _ -> do- alert $ "Unsupervised error: " ++ res_desc+ alert $ "Unsupervised error: " <> res_desc lift $ throwError res_desc +runLogin :: GenericOptions -> ExceptT Text IO AccessToken runLogin go = do s <- initialState go evalStateT (defaultSuperviser (login >>= return . Fine)) s -runAPI :: Show b => GenericOptions -> VK (R VK b) b -> ExceptT String IO b+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@@ -138,12 +143,12 @@ modify $ modifyAPIState (\as -> as{api_access_token = l_access_token}) defaultSuperviser (m >>= return . Fine) -runVK :: Show a => GenericOptions -> VK (R VK a) a -> IO (Either String a)+runVK :: Show a => GenericOptions -> VK (R VK a) a -> IO (Either Text a) runVK go = runExceptT . runAPI go runVK_ :: Show a => GenericOptions -> VK (R VK a) a -> IO () runVK_ go = do runVK go >=> \case- Left e -> fail e+ Left e -> fail (tunpack e) Right _ -> return ()
src/Web/VKHS/API/Base.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}@@ -35,9 +36,10 @@ import Text.Printf import Web.VKHS.Types-import Web.VKHS.Client+import Web.VKHS.Client hiding (Response(..)) import Web.VKHS.Monad import Web.VKHS.Error+import Web.VKHS.API.Types import Debug.Trace @@ -71,11 +73,13 @@ -- | Invoke the request. Returns answer as JSON object . ----- 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>+-- 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 -- instead.+-- FIXME: Split into request builder and request executer apiJ :: (MonadAPI m x s) => String -- ^ API method name@@ -96,15 +100,16 @@ (URL_Path ("/method/" ++ mname)) (buildQuery (("access_token", api_access_token):margs))) - debug $ "> " ++ (show url)+ debug $ "> " <> (tshow url) req <- ensure (requestCreateGet url (cookiesCreate ())) (res, jar') <- requestExecute req parseJSON (responseBody res) --- | Invoke the request, returns answer as a Haskell datatype--- See also @apiJ@+-- | 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@@ -118,7 +123,37 @@ Left e -> terminate (JSONParseFailure' j e) +-- | Invoke the request, return answer as a Haskell datatype or @ErrorRecord@+-- object+apiE :: (Aeson.FromJSON a, MonadAPI m x s)+ => String -- ^ API method name+ -> [(String, Text)] -- ^ API method arguments+ -> API m x (Either (Response ErrorRecord) a)+apiE m args = apiJ m args >>= convert where+ convert j@JSON{..} = do+ err <- pure $ Aeson.parseEither Aeson.parseJSON js_aeson+ ans <- pure $ Aeson.parseEither Aeson.parseJSON js_aeson+ case (ans, err) of+ (Right a, _) -> return (Right a)+ (Left a, Right e) -> return (Left e)+ (Left a, Left e) -> do+ j' <- raise (JSONCovertionFailure+ (j, "apiE: " <> Text.pack m <> ": expecting either known response or error"))+ convert j'++-- | Invoke the request, returns answer or the default value in case of error+apiD :: (Aeson.FromJSON a, MonadAPI m x s)+ => a+ -> String -- ^ API method name+ -> [(String, Text)] -- ^ API method arguments+ -> API m x a+apiD def m args =+ apiE m args >>= \case+ Left err -> return def+ Right x -> return x+ -- | String version of @api@+-- Deprecated api_S :: (Aeson.FromJSON a, MonadAPI m x s) => String -> [(String, String)] -> API m x a api_S m args = api m (map (id *** tpack) args)
src/Web/VKHS/API/Simple.hs view
@@ -3,24 +3,36 @@ {-# LANGUAGE RecordWildCards #-} module Web.VKHS.API.Simple where +import Control.Monad.Trans (liftIO) import Data.List import Data.Text (Text)+import Data.Monoid((<>)) import qualified Data.Text as Text+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson import Data.Function import Web.VKHS.Types+import Web.VKHS.Monad+import Web.VKHS.Error+import Web.VKHS.Types(tshow)+import Web.VKHS.Client(requestUploadPhoto, requestExecute, responseBody, responseBodyS) import Web.VKHS.API.Base import Web.VKHS.API.Types -version = "5.44" max_count = 1000+ver = "5.44" +apiSimple def nm args = apiD def nm (("v",ver):args)+apiVer nm args = api nm (("v",ver):args)+ groupSearch :: (MonadAPI m x s) => Text -> API m x (Sized [GroupRecord]) groupSearch q = fmap (sortBy (compare `on` gr_members_count)) <$> resp_data <$> do- api "groups.search" $+ apiSimple emptyResponse "groups.search" $ [("q",q),- ("v",version), ("fields", "can_post,members_count"), ("count", tpack (show max_count))] @@ -28,18 +40,78 @@ getCountries = fmap (sortBy (compare `on` co_title)) <$> do resp_data <$> do- api "database.getCountries" $- [("v",version),- ("need_all", "1"),+ apiSimple emptyResponse "database.getCountries" $+ [("need_all", "1"), ("count", tpack (show max_count)) ] getCities :: (MonadAPI m x s) => Country -> Maybe Text -> API m x (Sized [City]) getCities Country{..} mq = resp_data <$> do- api "database.getCities" $- [("v",version),- ("country_id", tpack (show co_int)),+ apiSimple emptyResponse "database.getCities" $+ [("country_id", tpack (show co_int)), ("count", tpack (show max_count)) ] ++ maybe [] (\q -> [("q",q)]) mq++getGroupWall :: (MonadAPI m x s) => GroupRecord -> API m x (Sized [WallRecord])+getGroupWall GroupRecord{..} =+ resp_data <$> do+ apiSimple emptyResponse "wall.get" $+ [("owner_id", "-" <> tshow gr_id),+ ("count", "100")+ ]++-- TODO: Take User as argument for more type-safety+getAlbums :: (MonadAPI m x s) => Maybe Integer -> API m x (Sized [Album])+getAlbums muid =+ resp_data <$> do+ apiSimple emptyResponse "photos.getAlbums" $+ (case muid of+ Just uid -> [("owner_id", tshow uid)]+ Nothing -> [])+ <>+ [("need_system", "1")+ ]++getPhotoUploadServer :: (MonadAPI m x s) => Album -> API m x PhotoUploadServer+getPhotoUploadServer Album{..} =+ resp_data <$> do+ api "photos.getUploadServer" $+ [("album_id", tshow al_id)+ ]+++getCurrentUser :: (MonadAPI m x s) => API m x UserRecord+getCurrentUser = do+ Response{..} <- apiVer "users.get" []+ users <- pure resp_data+ case (length users == 1) of+ False -> terminate (JSONParseFailure' resp_json "getCurrentUser: expecting single UserRecord")+ 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+ photo <- liftIO $ BS.readFile photo_path+ OwnerUploadServer{..} <-+ resp_data <$> api "photos.getOwnerPhotoUploadServer"+ [("owner_id", tshow ur_id)]+ req <- ensure $ requestUploadPhoto ous_upload_url photo+ (res, _) <- requestExecute req+ j@JSON{..} <- parseJSON (responseBody res)+ liftIO $ putStrLn $ (responseBodyS 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+ return ()+++
src/Web/VKHS/API/Types.hs view
@@ -11,6 +11,8 @@ import Data.Data import Data.Time.Clock import Data.Time.Clock.POSIX+import Data.Monoid ((<>), Monoid(..))+import Control.Applicative ((<|>)) import Data.Aeson ((.=), (.:), (.:?), (.!=), FromJSON(..)) import qualified Data.Aeson as Aeson@@ -22,26 +24,30 @@ import Text.Printf import Web.VKHS.Error-import Web.VKHS.API.Base+import Web.VKHS.Types+-- import Web.VKHS.API.Base -- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений -- (in Russian) for more details data Response a = Response {- resp_json :: Aeson.Value+ resp_json :: JSON , resp_data :: a } deriving (Show, Data, Typeable) +emptyResponse :: (Monoid a) => Response a+emptyResponse = Response (JSON $ Aeson.object []) mempty+ 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 (Response a) where parseJSON j = Aeson.withObject "Response" (\o ->- Response <$> pure j <*> o .: "response") j+ Response <$> pure (JSON j) <*> (o .: "response" <|> o.: "error")) j --- Deprecated+-- | DEPRECATED, use @Sized@ instead data SizedList a = SizedList Int [a] deriving(Show, Data, Typeable) @@ -61,43 +67,75 @@ } deriving (Show, Data, Typeable) instance FromJSON MusicRecord where- parseJSON = Aeson.withObject "MusicRecord" (\o ->+ parseJSON = Aeson.withObject "MusicRecord" $ \o -> MusicRecord <$> (o .: "aid") <*> (o .: "owner_id") <*> (o .: "artist") <*> (o .: "title") <*> (o .: "duration")- <*> (o .: "url"))+ <*> (o .: "url") +{-+ - API version 5.44+ - <https://vk.com/dev/json_schema>+ -}++ data UserRecord = UserRecord- { ur_id :: Int- , ur_first_name :: String- , ur_last_name :: String- , ur_photo :: String- , ur_university :: Maybe Int- , ur_university_name :: Maybe String- , ur_faculty :: Maybe Int- , ur_faculty_name :: Maybe String- , ur_graduation :: Maybe Int+ { ur_id :: Integer+ , ur_first_name :: Text+ , ur_last_name :: Text+ , ur_deactivated :: Maybe Text+ , ur_hidden :: Maybe Integer+ -- , ur_photo :: String+ -- , ur_university :: Maybe Int+ -- , ur_university_name :: Maybe String+ -- , ur_faculty :: Maybe Int+ -- , ur_faculty_name :: Maybe String+ -- , ur_graduation :: Maybe Int } deriving (Show, Data, Typeable) +instance FromJSON UserRecord where+ parseJSON = Aeson.withObject "UserRecord" $ \o ->+ UserRecord+ <$> (o .: "id")+ <*> (o .: "first_name")+ <*> (o .: "last_name")+ <*> (o .:? "deactivated")+ <*> (o .:? "hidden") ++data ErrorRecord = ErrorRecord+ { er_code :: Int+ , er_msg :: Text+ } deriving(Show)++instance FromJSON ErrorRecord where+ parseJSON = Aeson.withObject "ErrorRecord" $ \o ->+ ErrorRecord+ <$> (o .: "error_code")+ <*> (o .: "error_msg")+ data WallRecord = WallRecord { wr_id :: Int- , wr_to_id :: Int , wr_from_id :: Int- , wr_wtext :: String- , wr_wdate :: Int+ , wr_text :: Text+ , wr_date :: Int } deriving (Show) +instance FromJSON WallRecord where+ parseJSON = Aeson.withObject "WallRecord" $ \o ->+ WallRecord+ <$> (o .: "id")+ <*> (o .: "from_id")+ <*> (o .: "text")+ <*> (o .: "date")+ publishedAt :: WallRecord -> UTCTime-publishedAt wr = posixSecondsToUTCTime $ fromIntegral $ wr_wdate wr+publishedAt wr = posixSecondsToUTCTime $ fromIntegral $ wr_date wr -{-- - API version 5.44- -} data Sized a = Sized { m_count :: Int@@ -108,6 +146,9 @@ parseJSON = Aeson.withObject "Result" (\o -> Sized <$> o .: "count" <*> o .: "items") +instance Monoid a => Monoid (Sized a) where+ mempty = Sized 0 mempty+ mappend (Sized x a) (Sized y b) = Sized (x+y) (a<>b) data Deact = Banned | Deleted | OtherDeact Text deriving(Show,Eq,Ord)@@ -129,7 +170,6 @@ "page" -> Public "event" -> Event - data GroupIsClosed = GroupOpen | GroupClosed | GroupPrivate deriving(Show,Eq,Ord,Enum) @@ -208,4 +248,63 @@ <*> (o .: "title") <*> (o .:? "area") <*> (o .:? "region")++data Album = Album {+ al_id :: Integer+, al_title :: Text+} deriving(Show)++instance FromJSON Album where+ parseJSON = Aeson.withObject "Album" $ \o ->+ Album+ <$> (o .: "id")+ <*> (o .: "title")++data PhotoUploadServer = PhotoUploadServer {+ pus_upload_url :: Text+ , pus_user_id :: Text+ , pus_album_id :: Text+} deriving(Show)++instance FromJSON PhotoUploadServer where+ parseJSON = Aeson.withObject "PhotoUploadServer" $ \o ->+ PhotoUploadServer+ <$> (o .: "upload_url")+ <*> (o .: "album_id")+ <*> (o .: "user_id")++data OwnerUploadServer = OwnerUploadServer {+ ous_upload_url :: Text+ } 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")++++data PhotoSaveResult = PhotoSaveResult {+ photo_hash :: Text+ , photo_src :: Text+ } deriving(Show, Data, Typeable)++instance FromJSON PhotoSaveResult where+ parseJSON = Aeson.withObject "PhotoSaveResult" $ \o ->+ PhotoSaveResult+ <$> (o .: "photo_hash")+ <*> (o .: "photo_src")
src/Web/VKHS/Client.hs view
@@ -22,9 +22,8 @@ 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@@ -183,7 +182,7 @@ requestCreateGet :: (MonadClient m s) => URL -> Cookies -> m (Either Error Request) requestCreateGet URL{..} Cookies{..} = do- case setUri def uri of+ case setUri Client.defaultRequest uri of Left exc -> do return $ Left $ ErrorSetURL (URL uri) (show exc) Right r -> do@@ -192,7 +191,6 @@ return $ Right $ Request { req = r'{ Client.redirectCount = 0- , Client.checkStatus = \_ _ _ -> Nothing }, req_jar = jar }@@ -209,6 +207,18 @@ Right Request{..} -> do return $ Right $ Request (Client.urlEncodedBody (map (BS.pack *** BS.pack) $ Map.toList inputs) req) req_jar +requestUploadPhoto :: (MonadClient m s) => Text -> ByteString -> 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"))+ Just uri -> do+ r <- requestCreateGet (URL uri) (cookiesCreate ())+ case r of+ Left err -> do+ return $ Left err+ Right Request{..} -> do+ return $ Right $ Request ((Client.urlEncodedBody [("photo", bs)]) req) req_jar+ data Response = Response { resp :: Client.Response (Pipes.Producer ByteString IO ()) , resp_body :: ByteString@@ -252,7 +262,7 @@ ClientState{..} <- toClientState <$> get clk <- liftIO $ do clk <- Clock.getTime Clock.Realtime- let interval_ns = timeSpecAsNanoSecs (clk `diffTimeSpec` cl_last_execute)+ let interval_ns = toNanoSecs (clk `diffTimeSpec` cl_last_execute) when (interval_ns < cl_minimum_interval_ns) $ do threadDelay (fromInteger $ (cl_minimum_interval_ns - interval_ns) `div` 1000); -- convert ns to us return clk
src/Web/VKHS/Error.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Web.VKHS.Error where@@ -6,6 +7,8 @@ import Web.VKHS.Client (Response, Request, URL) import qualified Web.VKHS.Client as Client import Data.ByteString.Char8 (ByteString, unpack)+import Data.Text (Text)+import Data.Monoid ((<>)) data Error = ETimeout | EClient Client.Error deriving(Show, Eq)@@ -34,20 +37,26 @@ | 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)) data ResultDescription a = DescFine a | DescError String deriving(Show) -describeResult :: (Show a) => Result t a -> String-describeResult (Fine a) = "Fine " ++ show a-describeResult (UnexpectedInt e k) = "UnexpectedInt " ++ (show e)-describeResult (UnexpectedBool e k) = "UnexpectedBool " ++ (show e)-describeResult (UnexpectedURL e k) = "UnexpectedURL " ++ (show e)-describeResult (UnexpectedRequest e k) = "UnexpectedRequest " ++ (show e)+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 " ++ (show bs)-describeResult (JSONParseFailure' JSON{..} s) = "JSONParseFailure' " ++ (show s) ++ " JSON: " ++ (take 1000 $ show js_aeson)+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)
src/Web/VKHS/Login.hs view
@@ -24,6 +24,9 @@ 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 @@ -65,8 +68,8 @@ data RobotAction = DoGET URL Cookies | DoPOST FilledForm Cookies deriving(Show) -printAction :: String -> RobotAction -> String-printAction prefix (DoGET url jar) = prefix ++ " GET " ++ (show url)+printAction :: String -> RobotAction -> Text+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@@ -94,11 +97,12 @@ ])) return (DoGET u (cookiesCreate ())) -printForm :: String -> Shpider.Form -> String+printForm :: String -> Shpider.Form -> Text printForm prefix Shpider.Form{..} = let telln x = tell (x ++ "\n") in+ tpack $ execWriter $ do telln $ prefix ++ "Form #" ++ " (" ++ (show method) ++ ") Action " ++ action forM_ (Map.toList inputs) $ \(input,value) -> do@@ -154,11 +158,11 @@ title = Shpider.gatherTitle tags forms = map (Form title) (Shpider.gatherForms tags) dumpResponseBody "latest.html" res- debug ("< 0 Title: " ++ title)+ debug ("< 0 Title: " <> tpack title) case (responseRedirect res) of Just url -> do- debug $ "< 0 Fragments: " ++ show (urlFragments url)+ debug $ "< 0 Fragments: " <> tshow (urlFragments url) maybe (return $ Left $ DoGET url jar) (\x -> return $ Right x) $ do let frg = (urlFragments url) at_access_token <- lookup "access_token" frg@@ -184,7 +188,6 @@ go a = do req <- actionRequest a res <- analyzeResponse req- -- trace (show res) $ do case res of Left a' -> go a' Right at -> return at
src/Web/VKHS/Monad.hs view
@@ -26,6 +26,10 @@ 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.Error import Web.VKHS.Types import Web.VKHS.Client hiding(Error)@@ -57,6 +61,10 @@ err r undefined +-- | Request to the Superviser to log certain @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 @@ -72,26 +80,14 @@ (Right u) -> return u (Left e) -> raise (\k -> UnexpectedURL e k) --- instance EnsureVK (Either Client.Error Request) Request where--- ensure m = m >>= \x ->--- case x of--- (Right u) -> return u--- (Left e) -> raiseError (\k -> UnexpectedRequest e k)---- instance EnsureVK (Either Client.Error URL) URL where--- ensure m = m >>= \x ->--- case x of--- (Right u) -> return u--- (Left e) -> raiseError (\k -> UnexpectedURL e k)---debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => String -> m ()+debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m () debug str = do GenericOptions{..} <- gets toGenericOptions when o_verbose $ do- liftIO $ hPutStrLn stderr str+ liftIO $ Text.hPutStrLn stderr str -alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => String -> m ()+alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => Text -> m () alert str = do- liftIO $ hPutStrLn stderr str+ liftIO $ Text.hPutStrLn stderr str+
src/Web/VKHS/Types.hs view
@@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} 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 as Text@@ -94,7 +97,7 @@ data JSON = JSON { js_aeson :: Aeson.Value }- deriving(Show)+ deriving(Show, Data, Typeable) data Form = Form { form_title :: String