diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Alexey Shmalko + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsreadability.cabal b/hsreadability.cabal new file mode 100644 --- /dev/null +++ b/hsreadability.cabal @@ -0,0 +1,56 @@ +name: hsreadability +version: 1.0.0.0 +synopsis: Access to the Readability API. + +description: This package provides Haskell bindings to the + API. + +license: MIT +license-file: LICENSE +author: Alexey Shmalko +maintainer: Alexey Shmalko +homepage: http://github.com/rasendubi/hsreadability +bug-reports: http://github.com/rasendubi/hsreadability/issues +category: Network APIs, Web +build-type: Simple +extra-source-files: tests/files/parser_article.json + , tests/files/confidence_response.json +cabal-version: >=1.10 + +tested-with: GHC == 7.6, GHC == 7.8 + +source-repository head + type: git + location: git://github.com/rasendubi/hsreadability.git + +library + exposed-modules: Network.Readability + , Network.Readability.Parser + , Network.Readability.Reader + , Network.Readability.Shortener + build-depends: base >=4.6 && <4.8 + , aeson >=0.6.2 && <0.9 + , text + , data-default + , http-conduit >=2.0 && <2.2 + , bytestring >=0.9 && <0.11 + , authenticate-oauth >=1.5 && <1.6 + , http-types >=0.8 && <0.9 + , xsd >= 0.1 && <0.6 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite test-hsreadability + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base >=4.6 && <4.8 + , hsreadability + , aeson >=0.6.2 && <0.9 + , text + , HUnit >=1.2 && <1.3 + , file-embed >=0.0 && <0.1 + , test-framework >=0.8 && <0.9 + , test-framework-hunit >=0.3 && < 0.4 + hs-source-dirs: tests + default-language: Haskell2010 diff --git a/src/Network/Readability.hs b/src/Network/Readability.hs new file mode 100644 --- /dev/null +++ b/src/Network/Readability.hs @@ -0,0 +1,10 @@ +-- | This module merely reexports other modules for ease of use. +module Network.Readability + ( module Network.Readability.Parser + , module Network.Readability.Reader + , module Network.Readability.Shortener + ) where + +import Network.Readability.Parser +import Network.Readability.Reader +import Network.Readability.Shortener diff --git a/src/Network/Readability/Parser.hs b/src/Network/Readability/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Readability/Parser.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module is an interface to the Readability's Parser API. +-- +-- To get more info, visit . +module Network.Readability.Parser + ( ParserToken(..) + + -- * Parse article + , Article(..) + , parse + , parseByUrl + , parseById + + -- * Article status + , ArticleStatus(..) + , Status(..) + , getContentStatus + , getContentStatusByUrl + , getContentStatusById + + -- * Confidence + , Confidence(..) + , getConfidence + ) where + +import Control.Applicative ((<$>)) + +import qualified Data.ByteString.Char8 as BS + +import Data.Text (Text) +import Data.Aeson (FromJSON, eitherDecode) +import Data.Aeson.TH (deriveFromJSON, defaultOptions, fieldLabelModifier) + +import Network.HTTP.Conduit (method, parseUrl, responseBody, responseHeaders, setQueryString, withManager, httpLbs) + +-- | This is a Readability Parser API key. +-- +-- You can get one at . +newtype ParserToken = ParserToken BS.ByteString deriving (Eq, Show) + +data Article = Article + { content :: Maybe Text -- ^ The main content of the article (in HTML) + , domain :: Maybe Text -- ^ Domain name of article host + , author :: Maybe Text + , url :: Text -- ^ URL of the article + , short_url :: Maybe Text -- ^ Shortened URL provided by Readability Shortener + , title :: Maybe Text + , excerpt :: Maybe Text + , direction :: Maybe Text -- ^ Text direction of article + , word_count :: Integer + , total_pages :: Maybe Integer -- ^ Total number of pages in article + , date_published :: Maybe Text + , dek :: Maybe Text + , lead_image_url :: Maybe Text + , next_page_id :: Maybe Text + , rendered_pages :: Maybe Int + } deriving (Show, Eq) + +$(deriveFromJSON defaultOptions ''Article) + +-- | This type represent confidence with which Readability Parser recognizes content of article. +data Confidence = Confidence + { conf_url :: Text -- ^ Article URL + , conf_confidence :: Double -- ^ Parser's confidence + } deriving (Show, Eq) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("conf_" :: String)) } ''Confidence) + +-- | Represents article status +data ArticleStatus = ArticleStatus + { as_article_id :: BS.ByteString -- ^ Article id + , as_article_status :: Status -- ^ Article status + } deriving (Show, Eq) + +data Status + = Invalid -- ^ Unable to parse this URL for some reason + | Unretrieved -- ^ Readability knows of this article but hasn't yet retrieved its content, + -- or the cache expired + | ProvidedByUser -- ^ The content of this URL has been retrieved from at least one user + | ValidatedByUsers -- ^ The content was retrieved from multiple users and is validated + | Fetched -- ^ The content of this URL was fetched manually, and it has been cached + deriving (Show, Eq) + +apiPrefix :: String +apiPrefix = "https://readability.com/api/content/v1" + +-- | Parses content of the article by URL. +-- +-- This is a shortcut for 'parse'. +parseByUrl :: ParserToken -> BS.ByteString -> Maybe Int -> IO (Either String Article) +parseByUrl token articleUrl maximumPages = parse token (Just articleUrl) Nothing maximumPages + +-- | Parses content of the article by article id. +-- +-- This is a shortcut for 'parse'. +parseById :: ParserToken -> BS.ByteString -> Maybe Int -> IO (Either String Article) +parseById token articleId maximumPages = parse token Nothing (Just articleId) maximumPages + +-- | Parses content of the given article and returns its description. +-- +-- This is a @GET@ request to @/parser@ endpoint. +parse :: ParserToken -- ^ Your Parser API token + -> Maybe BS.ByteString -- ^ The article URL + -> Maybe BS.ByteString -- ^ The article id + -> Maybe Int -- ^ The maximum number of pages to parse + -> IO (Either String Article) +parse (ParserToken token) articleUrl articleId maximumPages = readabilityRequest "/parser" params + where + params = + [ ("token", Just token) + ] + ++ maybeParam "url" articleUrl + ++ maybeParam "id" articleId + ++ maybeShowParam "max_pages" maximumPages + +-- | Gets article's status by URL. +-- +-- This functions is a shortcut for 'getContentStatus'. +getContentStatusByUrl :: ParserToken -> BS.ByteString -> IO (Maybe ArticleStatus) +getContentStatusByUrl token articleUrl = getContentStatus token (Just articleUrl) Nothing + +-- | Gets article's status by id. +-- +-- This functions is a shortcut for 'getContentStatus'. +getContentStatusById :: ParserToken -> BS.ByteString -> IO (Maybe ArticleStatus) +getContentStatusById token articleId = getContentStatus token Nothing (Just articleId) + +-- | Gets article's status. +-- +-- This is a @HEAD@ request to @/parser@ endpoint. +getContentStatus :: ParserToken -- ^ Your Parser API key + -> Maybe BS.ByteString -- ^ Article URL + -> Maybe BS.ByteString -- ^ Article id + -> IO (Maybe ArticleStatus) +getContentStatus (ParserToken token) articleUrl articleId = contentStatusRequest params + where + params = + [ ("token", Just token) + ] + ++ maybeParam "url" articleUrl + ++ maybeParam "id" articleId + +contentStatusRequest :: [(BS.ByteString, Maybe BS.ByteString)] -> IO (Maybe ArticleStatus) +contentStatusRequest params = do + query <- setQueryString params <$> parseUrl (apiPrefix ++ "/parser") + response <- withManager $ httpLbs query{ method = "HEAD" } + let headers = responseHeaders response + return $ do + article_id <- lookup "X-Article-Id" headers + article_status <- parseStatus =<< lookup "X-Article-Status" headers + return $ ArticleStatus article_id article_status + +-- | Gets parser's confidence by URL. +-- +-- This a @GET@ request to @/confidence@ +getConfidence :: BS.ByteString -- ^ Article URL + -> IO (Either String Confidence) +getConfidence article_url = readabilityRequest "/confidence" [ ("url", Just article_url) ] + +readabilityRequest :: FromJSON a => String -> [(BS.ByteString, Maybe BS.ByteString)] -> IO (Either String a) +readabilityRequest api params = do + request <- setQueryString params <$> parseUrl (apiPrefix ++ api) + response <- withManager $ httpLbs request + return $ eitherDecode $ responseBody response + +maybeShowParam :: (Show a) => BS.ByteString -> Maybe a -> [(BS.ByteString, Maybe BS.ByteString)] +maybeShowParam name = maybeParam name . Just . BS.pack . show + +maybeParam :: BS.ByteString -> Maybe BS.ByteString -> [(BS.ByteString, Maybe BS.ByteString)] +maybeParam name = maybe [] $ \x -> [(name, Just x)] + +parseStatus :: BS.ByteString -> Maybe Status +parseStatus "INVALID" = Just Invalid +parseStatus "UNRETRIEVED" = Just Unretrieved +parseStatus "PROVIDED_BY_USER" = Just ProvidedByUser +parseStatus "VALIDATED_BY_USERS" = Just ValidatedByUsers +parseStatus "FETCHED" = Just Fetched +parseStatus _ = Nothing diff --git a/src/Network/Readability/Reader.hs b/src/Network/Readability/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Network/Readability/Reader.hs @@ -0,0 +1,553 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +-- | This module is an interface to the Readability's Reader API. +-- +-- To get more info, visit . +-- +-- Before performing any request, you should receive OAuth credentials. To do that, +-- this module provides 'newOAuth' as well as 'xauth' for XAuth authorizations. +-- +-- The full XAuth authorization process will be like: +-- +-- @ +-- let auth = newAuth +-- { oauthConsumerKey = "consumer key" -- usually, your username +-- , oauthConsumerSecret = "consumer token" +-- } +-- credential <- xauth auth "username" "password" +-- @ +-- +-- Then you should pass auth and credential to any function in this module. +-- +-- It's preferable not doing authentication every single time. The best way is to +-- store received credential, so you can use it later. +-- +-- If you don't have Reader Keys, visit . +module Network.Readability.Reader + ( + -- * Authentication + -- ** OAuth + OAuth + , newOAuth + , oauthConsumerKey + , oauthConsumerSecret + , xauth + + -- ** OAuth Endoints + , oauthAuthorizeEndpoint + , oauthRequestTokenEndpoint + , oauthAccessTokenEndpoint + + -- * Article + -- ** Types + , Article(..) + -- ** Requests + , getArticle + + -- * Bookmarks + -- ** Types + , BookmarksFilters(..) + , defaultBookmarksFilters + , BookmarksResponse(..) + , BookmarksConditions(..) + , BookmarksMeta(..) + , Bookmark(..) + , BookmarkLocation(..) + , Order(..) + + -- ** Requests + , getBookmarks + , addBookmark + , getBookmark + , updateBookmark + , deleteBookmark + , getBookmarkTags + , addBookmarkTags + , deleteBookmarkTag + + -- * Tags + -- ** Types + , TagsResponse(..) + , Tag(..) + -- ** Requests + , getTags + , getTag + , deleteTag + + -- * User + -- ** Types + , User(..) + -- ** Requests + , getUser + ) where + +import Control.Applicative ((<$>), (<*>)) + +import Data.Aeson (FromJSON(..), Value(String), eitherDecode) +import Data.Aeson.TH (defaultOptions, deriveFromJSON, fieldLabelModifier) +import Data.Maybe (catMaybes) +import Data.Default (Default(def)) + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BL + +import Network.HTTP.Conduit (Response, httpLbs, parseUrl, responseBody, responseHeaders, + setQueryString, urlEncodedBody, withManager, method) +import Network.HTTP.Types (parseQuery) + +import Text.XML.XSD.DateTime (DateTime) + +import qualified Web.Authenticate.OAuth as OAuth (newOAuth) +import Web.Authenticate.OAuth (OAuth, Credential, emptyCredential, newCredential, + oauthServerName, oauthAuthorizeUri, oauthConsumerKey, oauthConsumerSecret, + oauthRequestUri, oauthAccessTokenUri, signOAuth) + +import Network.Readability.Parser (Article(..)) + +apiPrefix :: String +apiPrefix = "https://readability.com/api/rest/v1" + +-- | OAuth endpoint +oauthAuthorizeEndpoint, oauthRequestTokenEndpoint, oauthAccessTokenEndpoint :: String +oauthAuthorizeEndpoint = apiPrefix ++ "/oauth/authorize/" +oauthRequestTokenEndpoint = apiPrefix ++ "/oauth/request_token/" +oauthAccessTokenEndpoint = apiPrefix ++ "/oauth/access_token/" + +-- | Default value for OAuth datatype. You must specify at least consumer key and secret. +-- +-- Example usage: +-- +-- @ +-- myAuth = newOAuth +-- { oauthConsumerKey = "consumer key" +-- , oauthConsumerSecret = "consumer secret" +-- } +-- @ +newOAuth :: OAuth +newOAuth = OAuth.newOAuth + { oauthServerName = "www.readability.com" + , oauthAuthorizeUri = oauthAuthorizeEndpoint + , oauthRequestUri = oauthRequestTokenEndpoint + , oauthAccessTokenUri = oauthAccessTokenEndpoint + } + +-- | XAuth is used to receive OAuth token using owner's username and password directly. +-- +-- In most cases, you should do your best to support OAuth proper. +xauth :: OAuth -- ^ OAuth client + -> BS.ByteString -- ^ Owner username + -> BS.ByteString -- ^ Owner password + -> IO (Maybe Credential) -- ^ Token and secret +xauth oauth username password = do + r <- parseUrl (oauthAccessTokenUri oauth) + let bodyParams = + [ ("x_auth_username", username) + , ("x_auth_password", password) + , ("x_auth_method", "client_auth") + ] + let request = urlEncodedBody bodyParams r + signedRequest <- signOAuth oauth emptyCredential request + response <- withManager $ httpLbs signedRequest + let res = parseQuery . BL.toStrict . responseBody $ response + return $ do + token <- lookup "oauth_token" res + secret <- lookup "oauth_token_secret" res + newCredential <$> token <*> secret + +getRequest :: (FromJSON a) + => OAuth + -> Credential + -> String + -> [(BS.ByteString, Maybe BS.ByteString)] + -> IO (Either String a) +getRequest oauth cred path params = do + req <- parseUrl $ apiPrefix ++ path + signedRequest <- signOAuth oauth cred $ setQueryString params req + response <- withManager $ httpLbs signedRequest + return $ eitherDecode $ responseBody $ response + +postRequest' :: OAuth + -> Credential + -> String + -> [(BS.ByteString, BS.ByteString)] + -> IO (Response BL.ByteString) +postRequest' oauth cred path params = do + req <- parseUrl $ apiPrefix ++ path + signedRequest <- signOAuth oauth cred $ urlEncodedBody params req + withManager $ httpLbs signedRequest + +postRequest :: (FromJSON a) + => OAuth + -> Credential + -> String + -> [(BS.ByteString, BS.ByteString)] + -> IO (Either String a) +postRequest oauth cred path params = do + response <- postRequest' oauth cred path params + return $ eitherDecode $ responseBody response + +deleteRequest :: OAuth + -> Credential + -> String + -> IO (Response BL.ByteString) +deleteRequest oauth cred path = do + req <- parseUrl $ apiPrefix ++ path + signedRequest <- signOAuth oauth cred $ req{ method = "DELETE" } + withManager $ httpLbs signedRequest + +-- | Gets article by id. +-- +-- This is a @GET@ request to @\/articles\/{articleId}@ endpoint. +getArticle :: OAuth -- ^ Client OAuth + -> Credential -- ^ Access token and secret + -> BS.ByteString -- ^ Article id + -> IO (Either String Article) +getArticle oauth cred articleId = + getRequest oauth cred ("/articles/" ++ BS.unpack articleId) [] + +-- This type represents various filters for performing 'getBookmarks' request. +-- +-- Note: this type has 'Default' instance as well as 'defaultBookmarksFilters', +-- so that you don't have to type in every field. Use update record syntax like this: +-- +-- @ +-- myfilters = def { bfFavorite = Just True } +-- -- or +-- myfilters = defaultBookmarksFilters { bfFavorite = Just True } +-- @ +data BookmarksFilters = BookmarksFilters + { bfArchive :: Maybe Bool -- ^ Archieved status + , bfFavorite :: Maybe Bool + , bfDomain :: Maybe String + , bfAddedSince :: Maybe DateTime + , bfAddedUntil :: Maybe DateTime + , bfOpenedSince :: Maybe DateTime + , bfOpenedUntil :: Maybe DateTime + , bfArchivedSince :: Maybe DateTime + , bfArchivedUntil :: Maybe DateTime + , bfFavoritedSince :: Maybe DateTime + , bfFavoritedUntil :: Maybe DateTime + , bfUpdatedSince :: Maybe DateTime + , bfUpdatedUntil :: Maybe DateTime + } deriving (Show, Eq) + +instance Default BookmarksFilters where + def = BookmarksFilters + { bfArchive = def + , bfFavorite = def + , bfDomain = def + , bfAddedSince = def + , bfAddedUntil = def + , bfOpenedSince = def + , bfOpenedUntil = def + , bfArchivedSince = def + , bfArchivedUntil = def + , bfFavoritedSince = def + , bfFavoritedUntil = def + , bfUpdatedSince = def + , bfUpdatedUntil = def + } + +-- | This is a default value for 'BookmarksFilters'. All fields are set to 'Nothing'. +defaultBookmarksFilters :: BookmarksFilters +defaultBookmarksFilters = def + +bookmarkFiltersToParams :: BookmarksFilters -> [(BS.ByteString, Maybe BS.ByteString)] +bookmarkFiltersToParams BookmarksFilters{..} = catMaybes + [ boolParam "archive" bfArchive + , boolParam "favorite" bfFavorite + , stringParam "domain" bfDomain + , param "added_since" bfAddedSince + , param "added_until" bfAddedUntil + , param "opened_since" bfOpenedSince + , param "opened_until" bfOpenedUntil + , param "archived_since" bfArchivedSince + , param "archived_until" bfArchivedUntil + , param "favorited_since" bfFavoritedSince + , param "favorited_until" bfFavoritedUntil + , param "updated_since" bfUpdatedSince + , param "updated_until" bfUpdatedUntil + ] + +boolParam :: BS.ByteString -> Maybe Bool -> Maybe (BS.ByteString, Maybe BS.ByteString) +boolParam name = fmap $ (name,) . Just . bshow . fromEnum + +boolParam' :: BS.ByteString -> Maybe Bool -> Maybe (BS.ByteString, BS.ByteString) +boolParam' name = fmap $ (name,) . bshow . fromEnum + +stringParam :: BS.ByteString -> Maybe String -> Maybe (BS.ByteString, Maybe BS.ByteString) +stringParam name = fmap $ (name,) . Just . BS.pack + +param :: (Show a) => BS.ByteString -> Maybe a -> Maybe (BS.ByteString, Maybe BS.ByteString) +param name = fmap $ (name,) . Just . bshow + +param' :: (Show a) => BS.ByteString -> Maybe a -> Maybe (BS.ByteString, BS.ByteString) +param' name = fmap $ (name,) . bshow + +stringListParam :: BS.ByteString -> [String] -> Maybe (BS.ByteString, Maybe BS.ByteString) +stringListParam _ [] = Nothing +stringListParam name xs = Just . (name,) . Just . BS.intercalate "," $ fmap BS.pack xs + +bshow :: Show a => a -> BS.ByteString +bshow = BS.pack . show + +data Order + = DateAddedAsc -- ^ Sort by date added, asceding + | DateAddedDesc -- ^ Sort by date added, desceding (this is default) + | DateUpdatedAsc -- ^ Sort by date updated, asceding + | DateUpdatedDesc -- ^ Sort by date updated, desceding + deriving (Eq) + +instance Show Order where + show DateAddedAsc = "date_added" + show DateAddedDesc = "-date_added" + show DateUpdatedAsc = "date_updated" + show DateUpdatedDesc = "-date_updated" + +instance FromJSON Order where + parseJSON (String "date_added") = return DateAddedAsc + parseJSON (String "-date_added") = return DateAddedDesc + parseJSON (String "date_updated") = return DateUpdatedAsc + parseJSON (String "-date_updated") = return DateUpdatedDesc + parseJSON _ = fail "Cant't parse Order" + +data BookmarksConditions = BookmarksConditions + { bc_archive :: Maybe Int + , bc_favorite :: Maybe Int + , bc_domain :: Maybe Text + , bc_added_since :: Maybe Text + , bc_added_until :: Maybe Text + , bc_opened_since :: Maybe Text + , bc_opened_until :: Maybe Text + , bc_archived_since :: Maybe Text + , bc_archived_until :: Maybe Text + , bc_favorited_since :: Maybe Text + , bc_favorited_until :: Maybe Text + , bc_updated_since :: Maybe Text + , bc_updated_until :: Maybe Text + , bc_order :: Maybe Order + , bc_user :: Maybe Text + , bc_page :: Maybe Integer + , bc_per_page :: Maybe Integer + , bc_exclude_accessibility :: Maybe Text + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("bc_" :: String)) } ''BookmarksConditions) + +data BookmarksMeta = BookmarksMeta + { bmeta_num_pages :: Maybe Integer + , bmeta_page :: Maybe Integer + , bmeta_item_count_total :: Maybe Integer + , bmeta_item_count :: Maybe Integer + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("bmeta_" :: String)) } ''BookmarksMeta) + +data Tag = Tag + { t_text :: Text + , t_id :: Integer + , t_applied_count :: Maybe Integer + , t_bookmark_ids :: Maybe [Integer] + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("t_" :: String)) } ''Tag) + +data Bookmark = Bookmark + { b_user_id :: Integer + , b_read_percent :: Text + , b_date_updated :: Text + , b_favorite :: Bool + , b_archive :: Bool + , b_article :: Article + , b_id :: Integer + , b_date_archived :: Maybe Text + , b_date_opened :: Maybe Text + , b_date_added :: Maybe Text + , b_date_favorited :: Maybe Text + , b_article_href :: Text + , b_tags :: [Tag] + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("b_" :: String)) } ''Bookmark) + +data BookmarksResponse = BookmarksResponse + { br_conditions :: BookmarksConditions + , br_meta :: BookmarksMeta + , br_bookmarks :: [Bookmark] + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("br_" :: String)) } ''BookmarksResponse) + +-- | Get all user bookmarks. +-- +-- This is a @GET@ request to @\/bookmarks@. +getBookmarks :: OAuth + -> Credential + -> BookmarksFilters + -> Maybe Order + -> Maybe Integer -- ^ Page + -> Maybe Integer -- ^ Per page + -> Maybe Bool -- ^ Only deleted + -> [String] -- ^ Tags + -> IO (Either String BookmarksResponse) +getBookmarks oauth credential bfilter mOrder mPage mPerPage mOnlyDeleted tags = + getRequest oauth credential "/bookmarks" $ + bookmarkFiltersToParams bfilter ++ catMaybes + [ param "order" mOrder + , param "page" mPage + , param "per_page" mPerPage + , boolParam "only_deleted" mOnlyDeleted + , stringListParam "tags" tags + ] + +data BookmarkLocation = BookmarkLocation + { blLocation :: Maybe BS.ByteString + , blArticleLocation :: Maybe BS.ByteString + } deriving (Eq, Show) + +-- | Add bookmark. +-- +-- This is a @POST@ request to @/bookmarks@. +addBookmark :: OAuth + -> Credential + -> BS.ByteString -- ^ Article URL + -> Maybe Bool -- ^ Favorite + -> Maybe Bool -- ^ Archive + -> Maybe Bool -- ^ Allow duplicates + -> IO BookmarkLocation +addBookmark oauth cred articleUrl mFavorite mArchive mAllowDuplicates = do + response <- postRequest' oauth cred "/bookmarks" $ catMaybes + [ Just ("url", articleUrl) + , boolParam' "favorite" mFavorite + , boolParam' "archive" mArchive + , boolParam' "allow_duplicates" mAllowDuplicates + ] + let headers = responseHeaders response + return $ BookmarkLocation (lookup "Location" headers) (lookup "X-Article-Location" headers) + +-- | Get bookmark by id. +-- +-- This is a @GET@ request to @\/bookmarks\/{bookmarkId}@. +getBookmark :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> IO (Either String Bookmark) +getBookmark oauth cred bookmarkId = + getRequest oauth cred ("/bookmarks/" ++ show bookmarkId) [] + +-- | Update bookmark. +-- +-- This a @POST@ request to @\/bookmarks\/{bookmarkId}@. +updateBookmark :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> Maybe Bool -- ^ Favorite + -> Maybe Bool -- ^ Archive + -> Maybe Double -- ^ Read percent + -> IO (Either String Bookmark) +updateBookmark oauth cred bookmarkId mFavorite mArchive mReadPercent = + postRequest oauth cred ("/bookmarks/" ++ show bookmarkId) $ catMaybes + [ boolParam' "favorite" mFavorite + , boolParam' "archive" mArchive + , param' "read_percent" mReadPercent + ] + +-- | Delete bookmark by id. +-- +-- This is a @DELETE@ request to @\/bookmarks\/{bookmarkId}@. +deleteBookmark :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> IO (Response BL.ByteString) +deleteBookmark oauth cred bookmarkId = + deleteRequest oauth cred ("/bookmarks/" ++ show bookmarkId) + +data TagsResponse = TagsResponse { tr_tags :: [Tag] } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("tr_" :: String)) } ''TagsResponse) + +-- | Get bookmark tags +-- +-- This is a @GET@ request to @\/bookmarks\/{bookmarkId}\/tags@. +getBookmarkTags :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> IO (Either String TagsResponse) +getBookmarkTags oauth cred bookmarkId = + getRequest oauth cred ("/bookmarks/" ++ show bookmarkId ++ "/tags") [] + +-- | Add tags to bookmark. +-- +-- This is a @POST@ request to @\/bookmarks\/{bookmarkId}\/tags@. +addBookmarkTags :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> [Text] -- ^ Tags + -> IO (Either String TagsResponse) +addBookmarkTags oauth cred bookmarkId tags = + postRequest oauth cred ("/bookmarks/" ++ show bookmarkId ++ "/tags") $ + [ ("tags", T.encodeUtf8 $ T.intercalate "," tags) ] + +-- | Delete given tag from bookmark. +-- +-- This is a @DELETE@ request to @\/bookmark\/{bookmarkId}\/tags\/{tagId}@. +deleteBookmarkTag :: OAuth + -> Credential + -> Integer -- ^ Bookmark id + -> Integer -- ^ Tag id + -> IO (Response BL.ByteString) +deleteBookmarkTag oauth cred bookmarkId tagId = + deleteRequest oauth cred ("/bookmarks/" ++ show bookmarkId ++ "/tags/" ++ show tagId) + +-- | Retrieve all user tags. +-- +-- This is a @GET@ request to @/tags@. +getTags :: OAuth + -> Credential + -> IO (Either String TagsResponse) +getTags oauth cred = getRequest oauth cred "/tags" [] + +-- | Retrieve tag by id. +-- +-- This is a @GET@ request to @\/tags\/{tagId}@. +getTag :: OAuth + -> Credential + -> Integer + -> IO (Either String Tag) +getTag oauth cred tagId = getRequest oauth cred ("/tags/" ++ show tagId) [] + +-- | Delete tag by id. +-- +-- This is a @DELETE@ request to @\/tags\/{tagId}@. +deleteTag :: OAuth + -> Credential + -> Integer + -> IO (Response BL.ByteString) +deleteTag oauth cred tagId = deleteRequest oauth cred ("/tags/" ++ show tagId) + +data User = User + { u_username :: Text + , u_first_name :: Maybe Text + , u_second_name :: Maybe Text + , u_date_joined :: Maybe Text + , u_has_active_subscriptions :: Maybe Bool + , u_reading_limit :: Maybe Integer + , u_email_into_address :: Maybe Text + , u_kindle_email_address :: Maybe Text + , u_tags :: [Tag] + } deriving (Eq, Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("u_" :: String)) } ''User) + +-- | Retrieve current user info. +-- +-- This is a @GET@ request to @\/user\/_current@. +getUser :: OAuth + -> Credential + -> IO (Either String User) +getUser oauth cred = getRequest oauth cred "/user/_current" [] diff --git a/src/Network/Readability/Shortener.hs b/src/Network/Readability/Shortener.hs new file mode 100644 --- /dev/null +++ b/src/Network/Readability/Shortener.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module is an interface to the Readability's Shortener API. +-- +-- To get more info, visit . +module Network.Readability.Shortener + ( Article(..) + + -- * Shorten and retrieve URL + , ShortenerMeta(..) + , ShortenerResponse(..) + , shortenUrl + , retrieveUrl + ) where + +import qualified Data.ByteString.Char8 as BS + +import Data.Text (Text) +import Data.Aeson (eitherDecode) +import Data.Aeson.TH (deriveFromJSON, defaultOptions, fieldLabelModifier) + +import Network.HTTP.Conduit (parseUrl, responseBody, withManager, httpLbs, urlEncodedBody) + +import Network.Readability.Parser (Article(..)) + +-- | Contains main data +data ShortenerMeta = ShortenerMeta + { smeta_article :: Maybe Article + , smeta_url :: Maybe Text + , smeta_rdd_url :: Text -- ^ The shortened URL + , smeta_id :: Text -- ^ The id of shortened URL + , smeta_full_url :: Maybe Text -- ^ The Article URL + } deriving (Show) + +-- | Response from Shortener API +data ShortenerResponse = ShortenerResponse + { se_meta :: ShortenerMeta + , se_messages :: [Text] -- ^ The response messages + , se_success :: Bool + } deriving (Show) + +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("smeta_" :: String)) } ''ShortenerMeta) +$(deriveFromJSON defaultOptions{ fieldLabelModifier = drop (length ("se_" :: String)) } ''ShortenerResponse) + +apiPrefix :: String +apiPrefix = "https://readability.com/api/shortener/v1/urls" + +-- | Create a new shortened URL +-- +-- This is a @POST@ request to @/urls@. +shortenUrl :: String -> IO (Either String ShortenerResponse) +shortenUrl source_url = shortenUrlRequest $ BS.pack source_url + +shortenUrlRequest :: BS.ByteString -> IO (Either String ShortenerResponse) +shortenUrlRequest source_url = do + initRequest <- parseUrl apiPrefix + let request = urlEncodedBody [("url", source_url)] initRequest + response <- withManager $ httpLbs request + return $ eitherDecode $ responseBody response + +-- | Retrieve a single shortened URL +-- +-- This is a @GET@ request to @\/urls\/{urlId}@. +retrieveUrl :: String -> IO (Either String ShortenerResponse) +retrieveUrl = retrieveUrlRequest + +retrieveUrlRequest :: String -> IO (Either String ShortenerResponse) +retrieveUrlRequest url_id = do + request <- parseUrl (apiPrefix ++ "/" ++ url_id) + response <- withManager $ httpLbs request + return $ eitherDecode $ responseBody response diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module Main(main) where + +import Data.FileEmbed (embedFile) +import Data.Aeson (decodeStrict) + +import System.Exit (exitFailure) + +import Network.Readability.Parser + +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit + +import Test.HUnit + +main = defaultMain tests + +tests = + [ testCase "decode parser response 1" test_parser_json1 + , testCase "decode example confidence response" test_confidence_parser + ] + +test_parser_json1 = assertEqual "decode example /parser response" + (Just Article + { content = Just "
\n

I'm idling outside Diamante's, [snip] ...

" + , domain = Just "www.gq.com" + , author = Just "Rafi Kohan" + , url = "http://www.gq.com/sports/profiles/201202/david-diamante-interview-cigar-lounge-brooklyn-new-jersey-nets?currentPage=all" + , short_url = Just "http://rdd.me/g3jcb1sr" + , title = Just "Blowing Smoke with Boxing's Big Voice" + , excerpt = Just "I'm idling outside Diamante's, a cigar lounge in Fort Greene, waiting for David Diamante, and soon I smell him coming. It's late January but warm. A motorcycle growls down the Brooklyn side street,…" + , direction = Just "ltr" + , word_count = 2892 + , total_pages = Just 1 + , date_published = Nothing + , dek = Just "Announcer David Diamante, the new voice of the New Jersey (soon Brooklyn) Nets, has been calling boxing matches for years. On the side, he owns a cigar lounge in the heart of Brooklyn. We talk with Diamante about his new gig and the fine art of cigars" + , lead_image_url = Just "http://www.gq.com/images/entertainment/2012/02/david-diamante/diamante-628.jpg" + , next_page_id = Nothing + , rendered_pages = Just 1 + }) + (decodeStrict $(embedFile "tests/files/parser_article.json")) + +-- readability examples provide invalid JSON for this case +-- .7 in examples should be 0.7 +test_confidence_parser = assertEqual "decode example /confidence response" + (Just Confidence + { conf_url = "http://www.gq.com/article/12" + , conf_confidence = 0.7 + }) + (decodeStrict $(embedFile "tests/files/confidence_response.json")) diff --git a/tests/files/confidence_response.json b/tests/files/confidence_response.json new file mode 100644 --- /dev/null +++ b/tests/files/confidence_response.json @@ -0,0 +1,4 @@ +{ + "url": "http://www.gq.com/article/12", + "confidence": 0.7 +} diff --git a/tests/files/parser_article.json b/tests/files/parser_article.json new file mode 100644 --- /dev/null +++ b/tests/files/parser_article.json @@ -0,0 +1,17 @@ +{ + "content": "
\n

I'm idling outside Diamante's, [snip] ...

", + "domain": "www.gq.com", + "author": "Rafi Kohan", + "url": "http://www.gq.com/sports/profiles/201202/david-diamante-interview-cigar-lounge-brooklyn-new-jersey-nets?currentPage=all", + "short_url": "http://rdd.me/g3jcb1sr", + "title": "Blowing Smoke with Boxing's Big Voice", + "excerpt": "I'm idling outside Diamante's, a cigar lounge in Fort Greene, waiting for David Diamante, and soon I smell him coming. It's late January but warm. A motorcycle growls down the Brooklyn side street,…", + "direction": "ltr", + "word_count": 2892, + "total_pages": 1, + "date_published": null, + "dek": "Announcer David Diamante, the new voice of the New Jersey (soon Brooklyn) Nets, has been calling boxing matches for years. On the side, he owns a cigar lounge in the heart of Brooklyn. We talk with Diamante about his new gig and the fine art of cigars", + "lead_image_url": "http://www.gq.com/images/entertainment/2012/02/david-diamante/diamante-628.jpg", + "next_page_id": null, + "rendered_pages": 1 +}