VKHS 1.9 → 1.9.1

raw patch · 10 files changed

+41/−68 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• README.md +1/−2
• VKHS.cabal +1/−1
• app/vkq/Main.hs +9/−2
• src/Web/VKHS.hs +4/−4
• src/Web/VKHS/API/Base.hs +4/−39
• src/Web/VKHS/API/Simple.hs +2/−7
• src/Web/VKHS/Client.hs +12/−9
• src/Web/VKHS/Error.hs +2/−2
• src/Web/VKHS/Types.hs +2/−2

@@ -1,3 +1,7 @@+Version 1.9.1+-------------+* Fixed user photo uploading using `vkq photo`+ Version 1.9 ----------- 

@@ -30,7 +30,7 @@ * 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 @@     {"response":57505}      $ vkq api "groups.search" "q=Haskell"-		$ vkq api "groups.search" "q=Haskell" --pretty     {         "response": [             30,

@@ -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

@@ -47,6 +47,8 @@ data PhotoOptions = PhotoOptions {     p_listAlbums :: Bool   , p_uploadServer :: Bool+  , p_setUserPhoto :: Bool+  , p_userPhoto :: String   } deriving(Show)  data Options@@ -63,7 +65,7 @@ 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 @@     <> 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 @@       _ ->         error "Ivalid album" +  |p_setUserPhoto = do+    user <- getCurrentUser+    setUserPhoto user p_userPhoto+   |otherwise = do     error "invalid command line arguments"-

@@ -76,7 +76,7 @@ -- -- 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 @@ -- -- 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

@@ -74,7 +74,7 @@  -- | 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 @@ -- <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@@ -211,41 +211,6 @@     -> (ErrorRecord -> Maybe a)     -> 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

@@ -128,15 +128,13 @@       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 @@       ,("photo", upl_photo)]   PhotoSaveResult{..} <- pure resp_data   return ()---

@@ -34,6 +34,7 @@ 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 @@   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 @@     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 @@         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 @@  -- | 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 @@         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 @@   (Right Request{..}) <- requestCreateGet url (cookiesCreate ())   liftIO $ Pipes.withHTTP req cl_man $ \resp -> do       PP.foldM (\() a -> h a) (return ()) (const (return ())) (Client.responseBody resp)-

@@ -31,8 +31,8 @@ -- 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

@@ -100,7 +100,7 @@  -- | 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 @@   -- ^ 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