packages feed

VKHS 1.6.1 → 1.6.2

raw patch · 9 files changed

+174/−134 lines, 9 files

Files

VKHS.cabal view
@@ -1,6 +1,6 @@  name:                VKHS-version:             1.6.1+version:             1.6.2 synopsis:            Provides access to Vkontakte social network via public API description:     Provides access to Vkontakte API methods. Library requires no interaction@@ -29,6 +29,8 @@                      Web.VKHS.Error                      Web.VKHS.API                      Web.VKHS.API.Types+                     Web.VKHS.API.Base+                     Web.VKHS.API.Simple    build-depends:     base >=4.6 && <5,                      containers,
app/vkq/Main.hs view
@@ -28,7 +28,6 @@ import Web.VKHS.Client as Client import Web.VKHS.Monad hiding (catch) import Web.VKHS.API as API-import Web.VKHS.API.Types as API  import Util @@ -133,7 +132,7 @@       <*> strOption         ( metavar "FORMAT"         <> short 'F'-        <> value "%o_%i %U\t%t"+        <> value "%i %m %n %u"         <> help ("Output format, supported tags:" ++ (listTags gr_tags))         )       ))@@ -176,7 +175,9 @@  -- API cmd (API go APIOptions{..}) = do-  runAPI go (apiJ a_method (splitFragments "," "=" a_args))+  runAPI go $ do+    x <- apiJ a_method (splitFragments "," "=" a_args)+    liftIO $ putStrLn $ show x   return ()  cmd (Music go@GenericOptions{..} mo@MusicOptions{..})@@ -184,7 +185,7 @@   -- Query music files   |not (null m_search_string) = do     runAPI go $ do-      API.Response _ (SizedList len ms) <- api "audio.search" [("q",m_search_string)]+      API.Response _ (SizedList len ms) <- api "audio.search" [("q",m_search_string), ("count", "1000")]       forM_ ms $ \m -> do         io $ printf "%s\n" (mr_format m_output_format m)       io $ printf "total %d\n" len@@ -240,12 +241,7 @@      runAPI go $ do -      API.Response _ (Many cnt (grs :: [GroupRecord])) <--        api "groups.search"-          [("q",g_search_string),-           ("v","5.44"),-           ("fields", "can_post,members_count"),-           ("count", "1000")]+      (Sized cnt grs) <- runGroupSearch g_search_string        forM_ grs $ \gr -> do         liftIO $ printf "%s\n" (gr_format g_output_format gr)
src/Web/VKHS.hs view
@@ -62,16 +62,21 @@   <*> pure go  +-- Intermediate alias+type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a++-- | 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 (EitherT String IO)) r a }   deriving(MonadIO, Functor, Applicative, Monad, MonadState State, MonadReader (r -> VK r r) , MonadCont)  instance MonadClient (VK r) State instance MonadVK (VK r) r instance MonadLogin (VK r) r State-instance API.MonadAPI (VK r) r State--type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a+-- instance MonadAPI (VK r) r State+instance MonadAPI VK r State +-- | Run the VK script, return final state and error status runVK :: VK r r -> StateT State (EitherT String IO) r runVK m = runContT (runReaderT (unVK (catch m)) undefined) return
src/Web/VKHS/API.hs view
@@ -1,117 +1,11 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-} -module Web.VKHS.API where--import Data.List-import Data.Maybe-import Data.Time-import Data.Either-import Control.Category ((>>>))-import Control.Applicative-import Control.Monad-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Cont--import Data.ByteString.Char8 (ByteString)-import Data.ByteString.Lazy (fromStrict)-import qualified Data.ByteString.Char8 as BS--import Data.Aeson ((.=), (.:))-import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Types as Aeson--import Text.Printf--import Web.VKHS.Types-import Web.VKHS.Client-import Web.VKHS.Monad-import Web.VKHS.Error--import Debug.Trace--data APIState = APIState {-    api_access_token :: String-  } deriving (Show)--defaultState = APIState {-    api_access_token = []-  }--class ToGenericOptions s => ToAPIState s where-  toAPIState :: s -> APIState-  modifyAPIState :: (APIState -> APIState) -> (s -> s)--class (MonadIO m, MonadClient m s, ToAPIState s, MonadVK m r) => MonadAPI m r s | m -> s---- | 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 BS.ByteString)--- api e mn mp =---   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 uri])---type API m x a = m (R m x) a--parseJSON :: (MonadAPI (m (R m x)) (R m x) s)-    => ByteString-    -> API m x JSON-parseJSON bs = do-  case Aeson.decode (fromStrict bs) of-    Just js -> return (JSON js)-    Nothing -> raise (JSONParseFailure bs)--apiJ :: (MonadAPI (m (R m x)) (R m x) s)-    => String-    -- ^ API method name-    -> [(String, String)]-    -- ^ API method arguments-    -> API m x JSON-apiJ mname margs = do-  GenericOptions{..} <- gets toGenericOptions-  APIState{..} <- gets toAPIState-  let protocol = (case o_use_https of-                    True -> "https"-                    False -> "http")-  url <- ensure $ pure-        (urlCreate-          (URL_Protocol protocol)-          (URL_Host o_api_host)-          (Just (URL_Port (show o_port)))-          (URL_Path ("/method/" ++ mname))-          (buildQuery (("access_token", api_access_token):margs)))--  debug $ "> " ++ (show url)--  req <- ensure (requestCreateGet url (cookiesCreate ()))-  (res, jar') <- requestExecute req-  parseJSON (responseBody res)---api :: (Aeson.FromJSON a, MonadAPI (m (R m x)) (R m x) s)-    => String-    -- ^ API method name-    -> [(String, String)]-    -- ^ API method arguments-    -> API m x a-api m args = do-  j@JSON{..} <- apiJ m args-  case Aeson.parseEither Aeson.parseJSON js_aeson of-    Right a -> return a-    Left e -> terminate (JSONParseFailure' j e)+module Web.VKHS.API (+    module Web.VKHS.API.Base+  , module Web.VKHS.API.Types+  , module Web.VKHS.API.Simple+  , module Web.VKHS.API+  ) where +import Web.VKHS.API.Base+import Web.VKHS.API.Types+import Web.VKHS.API.Simple
+ src/Web/VKHS/API/Base.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++module Web.VKHS.API.Base where++import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Category ((>>>))+import Control.Applicative+import Control.Monad+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Cont++import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (fromStrict)+import qualified Data.ByteString.Char8 as BS++import Data.Aeson ((.=), (.:))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson++import Text.Printf++import Web.VKHS.Types+import Web.VKHS.Client+import Web.VKHS.Monad+import Web.VKHS.Error++import Debug.Trace++data APIState = APIState {+    api_access_token :: String+  } deriving (Show)++defaultState = APIState {+    api_access_token = []+  }++class ToGenericOptions s => ToAPIState s where+  toAPIState :: s -> APIState+  modifyAPIState :: (APIState -> APIState) -> (s -> s)++-- | Class of monads able to run VK API calls. @m@ - the monad itself, @x@ -+-- type of early error, @s@ - type of state (see alse @ToAPIState@)+class (MonadIO (m (R m x)), MonadClient (m (R m x)) s, ToAPIState s, MonadVK (m (R m x)) (R m x)) =>+  MonadAPI m x s | m -> s++type API m x a = m (R m x) a++-- | Utility function to parse JSON object+parseJSON :: (MonadAPI m x s)+    => ByteString+    -> API m x JSON+parseJSON bs = do+  case Aeson.decode (fromStrict bs) of+    Just js -> return (JSON js)+    Nothing -> raise (JSONParseFailure bs)++-- | 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>+apiJ :: (MonadAPI m x s)+    => String+    -- ^ API method name+    -> [(String, String)]+    -- ^ API method arguments+    -> API m x JSON+apiJ mname margs = do+  GenericOptions{..} <- gets toGenericOptions+  APIState{..} <- gets toAPIState+  let protocol = (case o_use_https of+                    True -> "https"+                    False -> "http")+  url <- ensure $ pure+        (urlCreate+          (URL_Protocol protocol)+          (URL_Host o_api_host)+          (Just (URL_Port (show o_port)))+          (URL_Path ("/method/" ++ mname))+          (buildQuery (("access_token", api_access_token):margs)))++  debug $ "> " ++ (show 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@+api :: (Aeson.FromJSON a, MonadAPI m x s)+    => String+    -- ^ API method name+    -> [(String, String)]+    -- ^ API method arguments+    -> API m x a+api m args = do+  j@JSON{..} <- apiJ m args+  case Aeson.parseEither Aeson.parseJSON js_aeson of+    Right a -> return a+    Left e -> terminate (JSONParseFailure' j e)+
+ src/Web/VKHS/API/Simple.hs view
@@ -0,0 +1,18 @@+module Web.VKHS.API.Simple where++import Data.List+import Data.Function+import Web.VKHS.API.Base+import Web.VKHS.API.Types++runGroupSearch :: (MonadAPI m x s) => String -> API m x (Sized [GroupRecord])+runGroupSearch q =+  fmap (sortBy (compare `on` gr_members_count)) <$>+  resp_data <$> do+  api "groups.search"+    [("q",q),+     ("v","5.44"),+     ("fields", "can_post,members_count"),+     ("count", "1000")]++
src/Web/VKHS/API/Types.hs view
@@ -1,6 +1,8 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-}  module Web.VKHS.API.Types where@@ -19,6 +21,9 @@  import Text.Printf +import Web.VKHS.Error+import Web.VKHS.API.Base+ -- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений -- (in Russian) for more details @@ -94,14 +99,14 @@  - API version 5.44  -} -data Many a = Many {+data Sized a = Sized {     m_count :: Int   , m_items :: a-  } deriving (Show)+  } deriving (Show, Functor) -instance FromJSON a => FromJSON (Many a) where+instance FromJSON a => FromJSON (Sized a) where   parseJSON = Aeson.withObject "Result" (\o ->-    Many <$> o .: "count" <*> o .: "items")+    Sized <$> o .: "count" <*> o .: "items")   data Deact = Banned | Deleted | OtherDeact Text@@ -169,7 +174,6 @@       <*> (o .: "photo_200")       <*> (fmap (==(1::Int)) <$> (o .:? "can_post"))       <*> (o .:? "members_count")-  groupURL :: GroupRecord -> String groupURL GroupRecord{..} = "https://vk.com/" ++ urlify gr_type ++ (show gr_id) where
src/Web/VKHS/Error.hs view
@@ -10,13 +10,23 @@ data Error = ETimeout | EClient Client.Error   deriving(Show, Eq) +-- | Alias for Result type R t a = Result t a +-- | Result with continuation. @t@ represents the continuation monad, which+-- needs to track two types: the 'early break' type and the 'current result'+-- type. In the end both types are the same. data Result t a =     Fine a+  -- ^ The normal exit of a computation   | UnexpectedInt Error (Int -> t (R t a) (R t a))+  -- ^ Invalid integer value. It is possible for client to set a correct URL and+  -- continue   | UnexpectedBool Error (Bool -> t (R t a) (R t a))+  -- ^ Invalid boolean value. It is possible for client to set a correct URL and+  -- continue   | UnexpectedURL Client.Error (URL -> t (R t a) (R t a))+  -- ^ Invalid URL. It is possible for client to set a correct URL and continue   | UnexpectedRequest Client.Error (Request -> t (R t a) (R t a))   | UnexpectedResponse Client.Error (Response -> t (R t a) (R t a))   | UnexpectedFormField Form String (String -> t (R t a) (R t a))
src/Web/VKHS/Monad.hs view
@@ -39,6 +39,7 @@  -- instance (Monad m) => MonadVK (VKT m r) r +-- | Store early exit handler in the reader monad, run the computation @m@ catch :: (MonadVK m r) => m r -> m r catch m = do   callCC $ \k -> do