summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeyMironov <>2017-07-03 13:01:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-03 13:01:00 (GMT)
commit086343dec3970973ce70cf6ae73b479c0daee99f (patch)
tree5938f9ea8ecc52328c11ea4a149c5b7e73330eea
parenta4a3205836c9f80ef9d530b6ae18954173179907 (diff)
version 1.9.11.9.1
-rw-r--r--CHANGELOG.md4
-rw-r--r--README.md3
-rw-r--r--VKHS.cabal2
-rw-r--r--app/vkq/Main.hs11
-rw-r--r--src/Web/VKHS.hs8
-rw-r--r--src/Web/VKHS/API/Base.hs43
-rw-r--r--src/Web/VKHS/API/Simple.hs9
-rw-r--r--src/Web/VKHS/Client.hs21
-rw-r--r--src/Web/VKHS/Error.hs4
-rw-r--r--src/Web/VKHS/Types.hs4
10 files changed, 41 insertions, 68 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index fe249d6..f52281a 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,7 @@
+Version 1.9.1
+-------------
+* Fixed user photo uploading using `vkq photo`
+
Version 1.9
-----------
diff --git a/README.md b/README.md
index 6c81378..0f6fc56 100644
--- a/README.md
+++ b/README.md
@@ -30,7 +30,7 @@ ToDo
* Re-implement VK monad as a Free monad special case
* Runhaskell: handle some standard command line arguments
* Minor issues here and there. Use `git grep FIXME` to find them
-* File uploading still not functioning.
+* ~~File uploading still not functioning.~~
* Network connection timeout is not handled by the coroutine supervisor.
* Enhance the way `vkq` accepts arguments, support multy-line messages.
* Grammatical mistakes. Any corrections will be kindly accepted.
@@ -162,7 +162,6 @@ The session may look like the following:
{"response":57505}
$ vkq api "groups.search" "q=Haskell"
- $ vkq api "groups.search" "q=Haskell" --pretty
{
"response": [
30,
diff --git a/VKHS.cabal b/VKHS.cabal
index b3c0cef..b9288bf 100644
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -1,6 +1,6 @@
name: VKHS
-version: 1.9
+version: 1.9.1
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 1f9310c..d62a958 100644
--- a/app/vkq/Main.hs
+++ b/app/vkq/Main.hs
@@ -47,6 +47,8 @@ data LoginOptions = LoginOptions {
data PhotoOptions = PhotoOptions {
p_listAlbums :: Bool
, p_uploadServer :: Bool
+ , p_setUserPhoto :: Bool
+ , p_userPhoto :: String
} deriving(Show)
data Options
@@ -63,7 +65,7 @@ data Options
toMaybe :: (Functor f) => f String -> f (Maybe String)
toMaybe = fmap (\s -> if s == "" then Nothing else Just s)
--- FIXME support --version flag
+-- * FIXME support --version flag
optdesc m =
let
@@ -160,6 +162,8 @@ optdesc m =
<> 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")
+ <*> flag False True (long "set-user-photo" <> help "Set user photo")
+ <*> strOption (long "photo" <> help "User photo to set" <> value "")
))
( progDesc "Photo-related queries"))
)
@@ -251,6 +255,9 @@ cmd (Photo go PhotoOptions{..})
_ ->
error "Ivalid album"
+ |p_setUserPhoto = do
+ user <- getCurrentUser
+ setUserPhoto user p_userPhoto
+
|otherwise = do
error "invalid command line arguments"
-
diff --git a/src/Web/VKHS.hs b/src/Web/VKHS.hs
index 8425ffe..28fadb7 100644
--- a/src/Web/VKHS.hs
+++ b/src/Web/VKHS.hs
@@ -76,7 +76,7 @@ type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a
--
-- See also 'runVK' and 'defaultSupervisor`.
--
--- * FIXME Re-write using modern 'Monad.Free'
+-- * FIXME Re-write using modern 'Monad.Free'
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)
@@ -96,9 +96,9 @@ stepVK m = runContT (runReaderT (unVK (VKHS.catch m)) undefined) return
--
-- See also 'runVK'
--
--- * FIXME Store known answers in external DB (in file?) instead of LoginState
--- FIXME dictionary
--- * FIXME Handle capthas (offer running standalone apps)
+-- * FIXME Store known answers in external DB (in file?) instead of LoginState
+-- FIXME dictionary
+-- * FIXME Handle capthas (offer running standalone apps)
defaultSupervisor :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT Text IO) a
defaultSupervisor = go where
go m = do
diff --git a/src/Web/VKHS/API/Base.hs b/src/Web/VKHS/API/Base.hs
index 5eba16b..e086e8a 100644
--- a/src/Web/VKHS/API/Base.hs
+++ b/src/Web/VKHS/API/Base.hs
@@ -74,7 +74,7 @@ type API m x a = m (R m x) a
-- | Utility function to parse JSON object
--
--- * FIXME Don't raise exception, simply return `Left err`
+-- * FIXME Don't raise exception, simply return `Left err`
decodeJSON :: (MonadAPI m x s)
=> ByteString
-> API m x JSON
@@ -89,9 +89,9 @@ decodeJSON bs = do
-- <https://vk.com/dev/methods>
-- <https://vk.com/dev/json_schema>
--
--- * FIXME We currentyl use Text.unpack to encode text into strings. Use encodeUtf8
--- FIXME instead.
--- * FIXME Split into request builder and request executer
+-- * FIXME We currentyl use Text.unpack to encode text into strings. Use encodeUtf8
+-- FIXME instead.
+-- * FIXME Split into request builder and request executer
apiJ :: (MonadAPI m x s)
=> String
-- ^ API method name
@@ -212,41 +212,6 @@ apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
-> API m x a
apiH m args handler = apiHM m args (\e -> pure (handler e) :: API m x (Maybe a))
--- | 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 = do
- err <- pure $ parseJSON j
- ans <- pure $ parseJSON j
- 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)
-
-- Encode JSON back to string
jsonEncodeBS :: JSON -> ByteString
jsonEncodeBS JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson
diff --git a/src/Web/VKHS/API/Simple.hs b/src/Web/VKHS/API/Simple.hs
index 2dea388..beeba64 100644
--- a/src/Web/VKHS/API/Simple.hs
+++ b/src/Web/VKHS/API/Simple.hs
@@ -128,15 +128,13 @@ getCurrentUser = do
True -> Right (head users)
--- * FIXME fix setUserPhoto, it is not actually working
--- * FIXME move low-level upload code to API.Base
+-- * 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
+ req <- ensure $ requestUploadPhoto ous_upload_url photo_path
(res, _) <- requestExecute req
j@JSON{..} <- decodeJSON (responseBody res)
liftIO $ BS.putStrLn $ (responseBody res)
@@ -150,6 +148,3 @@ setUserPhoto UserRecord{..} photo_path = do
,("photo", upl_photo)]
PhotoSaveResult{..} <- pure resp_data
return ()
-
-
-
diff --git a/src/Web/VKHS/Client.hs b/src/Web/VKHS/Client.hs
index ff6e6f9..a56734e 100644
--- a/src/Web/VKHS/Client.hs
+++ b/src/Web/VKHS/Client.hs
@@ -34,6 +34,7 @@ import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Network.HTTP.Client ()
+import qualified Network.HTTP.Client.MultipartFormData as Multipart
import Network.HTTP.Client.Internal (setUri)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Network.HTTP.Types as Client
@@ -118,10 +119,12 @@ newtype URL_Port = URL_Port { urlp :: String }
deriving(Show)
newtype URL_Path = URL_Path { urlpath :: String }
deriving(Show)
+
+-- | URL wrapper
newtype URL = URL { uri :: Client.URI }
deriving(Show, Eq)
--- * FIXME Pack Text to ByteStrings, not to String
+-- * FIXME Pack Text to ByteStrings, not to String
buildQuery :: [(String,String)] -> URL_Query
buildQuery qis = URL_Query ("?" ++ intercalate "&" (map (\(a,b) -> (esc a) ++ "=" ++ (esc b)) qis)) where
esc x = Client.escapeURIString Client.isAllowedInURI x
@@ -136,7 +139,7 @@ urlFromString s =
Nothing -> Left (ErrorParseURL s "Client.parseURI failed")
Just u -> Right (URL u)
--- | * FIXME Convert to ByteString / Text
+-- | * FIXME Convert to ByteString / Text
splitFragments :: String -> String -> String -> [(String,String)]
splitFragments sep eqs =
filter (\(a, b) -> not (null a))
@@ -151,7 +154,7 @@ splitFragments sep eqs =
trim = rev (dropWhile (`elem` (" \t\n\r" :: String)))
where rev f = reverse . f . reverse . f
--- | * FIXME Convert to ByteString / Text
+-- | * FIXME Convert to ByteString / Text
urlFragments :: URL -> [(String,String)]
urlFragments URL{..} = splitFragments "&" "=" $ unsharp $ Client.uriFragment uri where
unsharp ('#':x) = x
@@ -216,10 +219,10 @@ requestCreatePost (FilledForm tit Shpider.Form{..}) c = do
-- | Upload the bytestring data @bs@ to the server @text_url@
--
--- * FIXME This function is not working. Looks like VK requires some other
--- FIXME method rather than urlEncodedBody.
--- * FIXME Use 'URL' rather than Text
-requestUploadPhoto :: (MonadClient m s) => Text -> ByteString -> m (Either Error Request)
+-- * FIXME Use 'URL' rather than Text. Think about
+-- https://github.com/blamario/network-uri
+--
+requestUploadPhoto :: (MonadClient m s) => Text -> String -> 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"))
@@ -229,7 +232,8 @@ requestUploadPhoto text_url bs = do
Left err -> do
return $ Left err
Right Request{..} -> do
- return $ Right $ Request ((Client.urlEncodedBody [("photo", bs)]) req) req_jar
+ req' <- Multipart.formDataBody [Multipart.partFile "photo" bs] req
+ return $ Right $ Request req' req_jar
data Response = Response {
resp :: Client.Response (Pipes.Producer ByteString IO ())
@@ -299,4 +303,3 @@ downloadFileWith url h = do
(Right Request{..}) <- requestCreateGet url (cookiesCreate ())
liftIO $ Pipes.withHTTP req cl_man $ \resp -> do
PP.foldM (\() a -> h a) (return ()) (const (return ())) (Client.responseBody resp)
-
diff --git a/src/Web/VKHS/Error.hs b/src/Web/VKHS/Error.hs
index d0966db..71fa7c7 100644
--- a/src/Web/VKHS/Error.hs
+++ b/src/Web/VKHS/Error.hs
@@ -31,8 +31,8 @@ type R t a = Result t a
-- needs to track two types: the early break @t@ and the current result @a@.
-- In order to be runnable (e.g. by 'runVK') both types are need to be the same.
--
--- * FIXME re-implement the concept using `Monad.Free` library
--- * FIMXE clean out of test/unused constructors
+-- * FIXME re-implement the concept using `Monad.Free` library
+-- * FIMXE clean out of test/unused constructors
data Result t a =
Fine a
-- ^ The normal exit of a computation
diff --git a/src/Web/VKHS/Types.hs b/src/Web/VKHS/Types.hs
index 65e3990..6698cee 100644
--- a/src/Web/VKHS/Types.hs
+++ b/src/Web/VKHS/Types.hs
@@ -100,7 +100,7 @@ newtype AppID = AppID { aid_string :: String }
-- | JSON wrapper.
--
--- * FIXME Implement full set of helper functions
+-- * FIXME Implement full set of helper functions
data JSON = JSON { js_aeson :: Aeson.Value }
deriving(Show, Data, Typeable)
@@ -138,7 +138,7 @@ data GenericOptions = GenericOptions {
-- ^ VK user name, (typically, an email). Empty string means no value is given
, l_password :: String
-- ^ VK password. Empty string means no value is given
- -- * FIXME Hide plain-text passwords
+ -- * FIXME Hide plain-text passwords
, l_access_token :: String
-- ^ Initial access token, empty means 'not set'. Has higher precedence than
-- l_access_token_file