summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeyMironov <>2017-05-20 18:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-05-20 18:30:00 (GMT)
commit12e70f69e9336d01cfdda9bd0cd5ccebd08faf6b (patch)
tree95f354f55cff79612f629596ecd658c15ebdc506
parent2790da159bdfaea2cc891ff12ed6783c9cc1af88 (diff)
version 1.7.31.7.3
-rw-r--r--README.md5
-rw-r--r--VKHS.cabal2
-rw-r--r--app/vkq/Main.hs50
-rw-r--r--src/Web/VKHS.hs29
-rw-r--r--src/Web/VKHS/API/Base.hs47
-rw-r--r--src/Web/VKHS/API/Simple.hs90
-rw-r--r--src/Web/VKHS/API/Types.hs145
-rw-r--r--src/Web/VKHS/Client.hs20
-rw-r--r--src/Web/VKHS/Error.hs25
-rw-r--r--src/Web/VKHS/Login.hs15
-rw-r--r--src/Web/VKHS/Monad.hs30
-rw-r--r--src/Web/VKHS/Types.hs5
12 files changed, 367 insertions, 96 deletions
diff --git a/README.md b/README.md
index 18521fe..a460ff3 100644
--- a/README.md
+++ b/README.md
@@ -131,9 +131,10 @@ invalid or captcha is required.
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
=======
diff --git a/VKHS.cabal b/VKHS.cabal
index e6c3119..69e232f 100644
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -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
diff --git a/app/vkq/Main.hs b/app/vkq/Main.hs
index 459bdde..6795c53 100644
--- a/app/vkq/Main.hs
+++ b/app/vkq/Main.hs
@@ -14,17 +14,20 @@ import Data.List
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 @@ data LoginOptions = LoginOptions {
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 @@ data Options
| 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 @@ opts m =
<*> 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 @@ main = ( do
Right _ -> do
return ()
)`catch` (\(e::SomeException) -> do
- putStrLn $ (show e)
+ putStrLn $ Text.pack (show e)
exitFailure
)
@@ -181,14 +196,14 @@ main = ( do
-}
-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 @@ cmd (Music go@GenericOptions{..} mo@MusicOptions{..})
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 @@ cmd (DBQ go (DBOptions{..}))
|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"
+
diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs
index bf932e5..adcb5c2 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -21,6 +21,7 @@ import Data.List
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 API.ToAPIState State where
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 @@ 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 (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 MonadLogin (VK r) r State
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 @@ defaultSuperviser = go where
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 @@ runAPI go@GenericOptions{..} m = do
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 ()
diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs
index 68e01d6..7cfeda6 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -35,9 +36,10 @@ import qualified Data.Aeson.Encode.Pretty as Aeson
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 @@ parseJSON bs = do
-- | 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 @@ apiJ mname (map (id *** tunpack) -> margs) = do
(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 @@ api m args = do
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)
diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs
index cc8ee1e..0a56187 100644
--- a/src/Web/VKHS/API/Simple.hs
+++ b/src/Web/VKHS/API/Simple.hs
@@ -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 :: (MonadAPI m x s) => API m x (Sized [Country])
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 ()
+
+
+
diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs
index f86b23e..4c0a599 100644
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -11,6 +11,8 @@ import Data.Typeable
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 Data.Text
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 @@ data MusicRecord = MusicRecord
} 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 @@ instance FromJSON a => FromJSON (Sized a) where
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 @@ instance FromJSON GroupType where
"page" -> Public
"event" -> Event
-
data GroupIsClosed = GroupOpen | GroupClosed | GroupPrivate
deriving(Show,Eq,Ord,Enum)
@@ -209,3 +249,62 @@ instance FromJSON City where
<*> (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")
+
diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs
index 2139028..0f9ebb9 100644
--- a/src/Web/VKHS/Client.hs
+++ b/src/Web/VKHS/Client.hs
@@ -22,9 +22,8 @@ import Data.Map (Map)
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 @@ data Request = Request {
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 @@ requestCreateGet URL{..} Cookies{..} = do
return $ Right $ Request {
req = r'{
Client.redirectCount = 0
- , Client.checkStatus = \_ _ _ -> Nothing
},
req_jar = jar
}
@@ -209,6 +207,18 @@ requestCreatePost (FilledForm tit Shpider.Form{..}) c = do
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 @@ requestExecute Request{..} = do
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
diff --git a/src/Web/VKHS/Error.hs b/src/Web/VKHS/Error.hs
index 9e9b144..fb93c54 100644
--- a/src/Web/VKHS/Error.hs
+++ b/src/Web/VKHS/Error.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Web.VKHS.Error where
@@ -6,6 +7,8 @@ import Web.VKHS.Types
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 @@ data Result t a =
| 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)
diff --git a/src/Web/VKHS/Login.hs b/src/Web/VKHS/Login.hs
index 48703b9..f7e2811 100644
--- a/src/Web/VKHS/Login.hs
+++ b/src/Web/VKHS/Login.hs
@@ -24,6 +24,9 @@ import qualified Data.Map as Map
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 @@ class (MonadIO m, MonadClient m s, ToLoginState s, MonadVK m r) => MonadLogin m
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 @@ initialAction = do
]))
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 @@ analyzeResponse (res, jar) = do
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 @@ login = initialAction >>= go where
go a = do
req <- actionRequest a
res <- analyzeResponse req
- -- trace (show res) $ do
case res of
Left a' -> go a'
Right at -> return at
diff --git a/src/Web/VKHS/Monad.hs b/src/Web/VKHS/Monad.hs
index 6454ab0..06e6a44 100644
--- a/src/Web/VKHS/Monad.hs
+++ b/src/Web/VKHS/Monad.hs
@@ -26,6 +26,10 @@ import System.IO
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 @@ terminate r = do
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 @@ instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Erro
(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
+
diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs
index b077cb4..2fe8a16 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -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 @@ newtype AppID = AppID { aid_string :: String }
data JSON = JSON { js_aeson :: Aeson.Value }
- deriving(Show)
+ deriving(Show, Data, Typeable)
data Form = Form {
form_title :: String