diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.4 +version: 0.5 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -58,7 +58,6 @@ Pinboard.ApiRequest Pinboard.ApiTypes Pinboard.Client - Pinboard.Client.Internal Pinboard.Client.Error Pinboard.Client.Types Pinboard.Client.Util diff --git a/src/Pinboard/Api.hs b/src/Pinboard/Api.hs --- a/src/Pinboard/Api.hs +++ b/src/Pinboard/Api.hs @@ -33,11 +33,12 @@ getNote, ) where -import Pinboard.Client.Internal (pinboardJson) +import Pinboard.Client (pinboardJson) import Pinboard.Client.Types (Pinboard) import Control.Applicative ((<$>)) import Data.Text (Text) import Data.Time (UTCTime) +import Pinboard.Client.Types (ResultFormatType (..)) import Pinboard.ApiTypes import Pinboard.ApiRequest @@ -48,7 +49,7 @@ :: Maybe [Tag] -- ^ filter by up to three tags -> Maybe Count -- ^ number of results to return. Default is 15, max is 100 -> Pinboard Posts -getPostsRecent tags count = pinboardJson $ getPostsRecentRequest tags count +getPostsRecent tags count = pinboardJson $ getPostsRecentRequest FormatJson tags count -- | posts/all : Returns all bookmarks in the user's account. getPostsAll @@ -59,7 +60,7 @@ -> Maybe ToDateTime -- ^ return only bookmarks created before this time -> Maybe Meta -- ^ include a change detection signature for each bookmark -> Pinboard [Post] -getPostsAll tags start results fromdt todt meta = pinboardJson $ getPostsAllRequest tags start results fromdt todt meta +getPostsAll tags start results fromdt todt meta = pinboardJson $ getPostsAllRequest FormatJson tags start results fromdt todt meta -- | posts/get : Returns one or more posts on a single day matching the arguments. -- If no date or url is given, date of most recent bookmark will be used. @@ -68,18 +69,18 @@ -> Maybe Date -- ^ return results bookmarked on this day -> Maybe Url -- ^ return bookmark for this URL -> Pinboard Posts -getPostsForDate tags date url = pinboardJson $ getPostsForDateRequest tags date url +getPostsForDate tags date url = pinboardJson $ getPostsForDateRequest FormatJson tags date url -- | posts/dates : Returns a list of dates with the number of posts at each date. getPostsDates :: Maybe [Tag] -- ^ filter by up to three tags -> Pinboard PostDates -getPostsDates tags = pinboardJson $ getPostsDatesRequest tags +getPostsDates tags = pinboardJson $ getPostsDatesRequest FormatJson tags -- | posts/update : Returns the most recent time a bookmark was added, updated or deleted. getPostsMRUTime :: Pinboard UTCTime -getPostsMRUTime = fromUpdateTime <$> pinboardJson getPostsMRUTimeRequest +getPostsMRUTime = fromUpdateTime <$> pinboardJson (getPostsMRUTimeRequest FormatJson) -- | posts/suggest : Returns a list of popular tags and recommended tags for a given URL. -- Popular tags are tags used site-wide for the url; @@ -87,13 +88,13 @@ getSuggestedTags :: Url -> Pinboard [Suggested] -getSuggestedTags url = pinboardJson $ getSuggestedTagsRequest url +getSuggestedTags url = pinboardJson $ getSuggestedTagsRequest FormatJson url -- | posts/delete : Delete an existing bookmark. deletePost :: Url -> Pinboard () -deletePost url = fromDoneResult <$> (pinboardJson $ deletePostRequest url) +deletePost url = fromDoneResult <$> (pinboardJson $ deletePostRequest FormatJson url) -- | posts/add : Add a bookmark addPost @@ -106,7 +107,7 @@ -> Maybe Shared -- ^ Make bookmark public. Default is "yes" unless user has enabled the "save all bookmarks as private" user setting, in which case default is "no" -> Maybe ToRead -- ^ Marks the bookmark as unread. Default is "no" -> Pinboard () -addPost url descr ext tags ctime repl shared toread = fromDoneResult <$> (pinboardJson $ addPostRequest url descr ext tags ctime repl shared toread) +addPost url descr ext tags ctime repl shared toread = fromDoneResult <$> (pinboardJson $ addPostRequest FormatJson url descr ext tags ctime repl shared toread) -- TAGS ---------------------------------------------------------------------- @@ -115,14 +116,14 @@ -- times they were used. getTags :: Pinboard TagMap -getTags = fromJsonTagMap <$> (pinboardJson $ getTagsRequest) +getTags = fromJsonTagMap <$> (pinboardJson $ getTagsRequest FormatJson ) -- | tags/delete : Delete an existing tag. deleteTag :: Tag -> Pinboard () -deleteTag tag = fromDoneResult <$> (pinboardJson $ deleteTagRequest tag) +deleteTag tag = fromDoneResult <$> (pinboardJson $ deleteTagRequest FormatJson tag) -- | tags/rename : Rename an tag, or fold it in to an existing tag @@ -130,7 +131,7 @@ :: Old -- ^ note: match is not case sensitive -> New -- ^ if empty, nothing will happen -> Pinboard () -renameTag old new = fromDoneResult <$> (pinboardJson $ renameTagRequest old new) +renameTag old new = fromDoneResult <$> (pinboardJson $ renameTagRequest FormatJson old new) -- USER ---------------------------------------------------------------------- @@ -138,12 +139,12 @@ -- | user/secret : Returns the user's secret RSS key (for viewing private feeds) getUserSecretRssKey :: Pinboard Text -getUserSecretRssKey = fromTextResult <$> (pinboardJson $ getUserSecretRssKeyRequest) +getUserSecretRssKey = fromTextResult <$> (pinboardJson $ getUserSecretRssKeyRequest FormatJson ) -- | user/api_token : Returns the user's API token (for making API calls without a password) getUserApiToken :: Pinboard Text -getUserApiToken = fromTextResult <$> (pinboardJson $ getUserApiTokenRequest) +getUserApiToken = fromTextResult <$> (pinboardJson $ getUserApiTokenRequest FormatJson ) -- NOTES --------------------------------------------------------------------- @@ -151,11 +152,11 @@ -- | notes/list : Returns a list of the user's notes (note text detail is not included) getNoteList :: Pinboard NoteList -getNoteList = pinboardJson $ getNoteListRequest +getNoteList = pinboardJson $ getNoteListRequest FormatJson -- | notes/id : Returns an individual user note. The hash property is a 20 character long sha1 hash of the note text. getNote :: NoteId -> Pinboard Note -getNote noteid = pinboardJson $ getNoteRequest noteid +getNote noteid = pinboardJson $ getNoteRequest FormatJson noteid diff --git a/src/Pinboard/ApiRequest.hs b/src/Pinboard/ApiRequest.hs --- a/src/Pinboard/ApiRequest.hs +++ b/src/Pinboard/ApiRequest.hs @@ -9,7 +9,7 @@ -- Portability : POSIX -- -- These request builders allow you to build request params which can --- sent via Pinboard.Client.Internal, in the case you need more control +-- sent via Pinboard.Client, in the case you need more control -- for how the response should be processed over what Pinboard.Api provides. module Pinboard.ApiRequest @@ -42,34 +42,40 @@ import Data.Text (unwords) import Data.Maybe (catMaybes) import Pinboard.ApiTypes +import Pinboard.Client.Types (ResultFormatType (..)) + -- POSTS --------------------------------------------------------------------- -- | posts/recent : Returns a list of the user's most recent posts, filtered by tag. getPostsRecentRequest - :: Maybe [Tag] -- ^ filter by up to three tags + :: ResultFormatType + -> Maybe [Tag] -- ^ filter by up to three tags -> Maybe Count -- ^ number of results to return. Default is 15, max is 100 -> PinboardRequest -getPostsRecentRequest tags count = PinboardRequest path params +getPostsRecentRequest fmt tags count = PinboardRequest path params where path = "posts/recent" - params = catMaybes [ Tag . unwords <$> tags + params = catMaybes [ Just (Format fmt) + , Tag . unwords <$> tags , Count <$> count ] -- | posts/all : Returns all bookmarks in the user's account. getPostsAllRequest - :: Maybe [Tag] -- ^ filter by up to three tags + :: ResultFormatType + -> Maybe [Tag] -- ^ filter by up to three tags -> Maybe StartOffset -- ^ offset value (default is 0) -> Maybe NumResults -- ^ number of results to return. Default is all -> Maybe FromDateTime -- ^ return only bookmarks created after this time -> Maybe ToDateTime -- ^ return only bookmarks created before this time -> Maybe Meta -- ^ include a change detection signature for each bookmark -> PinboardRequest -getPostsAllRequest tags start results fromdt todt meta = +getPostsAllRequest fmt tags start results fromdt todt meta = PinboardRequest path params where path = "posts/all" - params = catMaybes [ Tag . unwords <$> tags + params = catMaybes [ Just (Format fmt) + , Tag . unwords <$> tags , Start <$> start , Results <$> results , FromDateTime <$> fromdt @@ -80,60 +86,68 @@ -- | posts/get : Returns one or more posts on a single day matching the arguments. -- If no date or url is given, date of most recent bookmark will be used. getPostsForDateRequest - :: Maybe [Tag] -- ^ filter by up to three tags + :: ResultFormatType + -> Maybe [Tag] -- ^ filter by up to three tags -> Maybe Date -- ^ return results bookmarked on this day -> Maybe Url -- ^ return bookmark for this URL -> PinboardRequest -getPostsForDateRequest tags date url = PinboardRequest path params +getPostsForDateRequest fmt tags date url = PinboardRequest path params where path = "posts/get" - params = catMaybes [ Tag . unwords <$> tags + params = catMaybes [ Just (Format fmt) + , Tag . unwords <$> tags , Date <$> date , Url <$> url ] -- | posts/dates : Returns a list of dates with the number of posts at each date. getPostsDatesRequest - :: Maybe [Tag] -- ^ filter by up to three tags + :: ResultFormatType + -> Maybe [Tag] -- ^ filter by up to three tags -> PinboardRequest -getPostsDatesRequest tags = PinboardRequest path params +getPostsDatesRequest fmt tags = PinboardRequest path params where path = "posts/dates" - params = catMaybes [ Tag . unwords <$> tags ] + params = catMaybes [ Just (Format fmt) + , Tag . unwords <$> tags ] -- | posts/update : Returns the most recent time a bookmark was added, updated or deleted. getPostsMRUTimeRequest - :: PinboardRequest -getPostsMRUTimeRequest = PinboardRequest path params + :: ResultFormatType + -> PinboardRequest +getPostsMRUTimeRequest fmt = PinboardRequest path params where path = "posts/update" - params = [] + params = [Format fmt] -- | posts/suggest : Returns a list of popular tags and recommended tags for a given URL. -- Popular tags are tags used site-wide for the url; -- Recommended tags are drawn from the user's own tags. getSuggestedTagsRequest - :: Url + :: ResultFormatType + -> Url -> PinboardRequest -getSuggestedTagsRequest url = PinboardRequest path params +getSuggestedTagsRequest fmt url = PinboardRequest path params where path = "posts/suggest" - params = [ Url url ] + params = [ Format fmt, Url url ] -- | posts/delete : Delete an existing bookmark. deletePostRequest - :: Url + :: ResultFormatType + -> Url -> PinboardRequest -deletePostRequest url = PinboardRequest path params +deletePostRequest fmt url = PinboardRequest path params where path = "posts/delete" - params = [Url url] + params = [Format fmt, Url url] -- | posts/add : Add a bookmark addPostRequest - :: Url -- ^ the URL of the item + :: ResultFormatType + -> Url -- ^ the URL of the item -> Description -- ^ Title of the item. This field is unfortunately named 'description' for backwards compatibility with the delicious API -> Maybe Extended -- ^ Description of the item. Called 'extended' for backwards compatibility with delicious API -> Maybe [Tag] -- ^ List of up to 100 tags @@ -142,11 +156,12 @@ -> Maybe Shared -- ^ Make bookmark public. Default is "yes" unless user has enabled the "save all bookmarks as private" user setting, in which case default is "no" -> Maybe ToRead -- ^ Marks the bookmark as unread. Default is "no" -> PinboardRequest -addPostRequest url descr ext tags ctime repl shared toread = +addPostRequest fmt url descr ext tags ctime repl shared toread = PinboardRequest path params where path = "posts/add" - params = catMaybes [ Just $ Url url + params = catMaybes [ Just (Format fmt) + , Just $ Url url , Just $ Description descr , Extended <$> ext , Tags . unwords <$> tags @@ -161,69 +176,76 @@ -- | tags/get : Returns a full list of the user's tags along with the number of -- times they were used. getTagsRequest - :: PinboardRequest -getTagsRequest = PinboardRequest path params + :: ResultFormatType + -> PinboardRequest +getTagsRequest fmt = PinboardRequest path params where path = "tags/get" - params = [] + params = [Format fmt] -- | tags/delete : Delete an existing tag. deleteTagRequest - :: Tag + :: ResultFormatType + -> Tag -> PinboardRequest -deleteTagRequest tag = PinboardRequest path params +deleteTagRequest fmt tag = PinboardRequest path params where path = "tags/delete" - params = [Tag tag] + params = [Format fmt, Tag tag] -- | tags/rename : Rename an tag, or fold it in to an existing tag renameTagRequest - :: Old -- ^ note: match is not case sensitive + :: ResultFormatType + -> Old -- ^ note: match is not case sensitive -> New -- ^ if empty, nothing will happen -> PinboardRequest -renameTagRequest old new = PinboardRequest path params +renameTagRequest fmt old new = PinboardRequest path params where path = "tags/rename" - params = [Old old, New new] + params = [Format fmt, Old old, New new] -- USER ---------------------------------------------------------------------- -- | user/secret : Returns the user's secret RSS key (for viewing private feeds) getUserSecretRssKeyRequest - :: PinboardRequest -getUserSecretRssKeyRequest = PinboardRequest path params + :: ResultFormatType + -> PinboardRequest +getUserSecretRssKeyRequest fmt = PinboardRequest path params where path = "user/secret" - params = [] + params = [Format fmt] -- | user/api_token : Returns the user's API token (for making API calls without a password) getUserApiTokenRequest - :: PinboardRequest -getUserApiTokenRequest = PinboardRequest path params + :: ResultFormatType + -> PinboardRequest +getUserApiTokenRequest fmt = PinboardRequest path params where path = "user/api_token" - params = [] + params = [Format fmt] -- NOTES --------------------------------------------------------------------- -- | notes/list : Returns a list of the user's notes (note text detail is not included) getNoteListRequest - :: PinboardRequest -getNoteListRequest = PinboardRequest path params + :: ResultFormatType + -> PinboardRequest +getNoteListRequest fmt = PinboardRequest path params where path = "notes/list" - params = [] + params = [Format fmt] -- | notes/id : Returns an individual user note. The hash property is a 20 character long sha1 hash of the note text. getNoteRequest - :: NoteId + :: ResultFormatType + -> NoteId -> PinboardRequest -getNoteRequest noteid = PinboardRequest path params +getNoteRequest fmt noteid = PinboardRequest path params where path = "notes" noteid - params = [] + params = [Format fmt] diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs --- a/src/Pinboard/ApiTypes.hs +++ b/src/Pinboard/ApiTypes.hs @@ -23,7 +23,6 @@ import System.Locale (defaultTimeLocale) import qualified Data.HashMap.Strict as HM - -- * Posts data Posts = Posts { diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -1,41 +1,230 @@ --- | +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +------------------------------------------------------------------------------ +-- | -- Module : Pinboard.Client --- Copyright : (c) Jon Schoning +-- Copyright : (c) Jon Schoning, 2015 -- Maintainer : jonschoning@gmail.com -- Stability : experimental -- Portability : POSIX --- --- @ --- import Pinboard --- --- main :: IO () --- main = do --- let config = fromApiToken "api token" --- result <- runPinboardJson config $ getPostsRecent Nothing Nothing --- case result of --- Right details -> print details --- Left pinboardError -> print pinboardError --- @ +------------------------------------------------------------------------------ + module Pinboard.Client ( - -- * Client - -- | Executes the methods defined in Pinboard.Api - runPinboardJson - -- | Create a default PinboardConfig using the supplied apiToken - , fromApiToken + -- * Config + fromApiToken -- | The PinboardConfig provides authentication via apiToken , PinboardConfig (..) - -- * Client Dependencies + -- * Monadic, Json + , runPinboardJson + , pinboardJson + -- * Single + , runPinboardSingleRaw + , runPinboardSingleRawBS + , runPinboardSingleJson + -- * Sending + , sendPinboardRequest + , sendPinboardRequestBS + -- * Connections + , connOpenRaw + , connOpen + , connClose + , connFail + -- * JSON Streams + ,parseJSONResponseStream + ,parseJSONFromStream + -- * Status Codes + ,checkStatusCode + -- * Error Helpers + ,addErrMsg + ,createParserErr + ,httpStatusPinboardError + -- * Client Dependencies , module Pinboard.Client.Error , module Pinboard.Client.Types , module Pinboard.Client.Util ) where -import Pinboard.Client.Internal + +import Control.Applicative ((<$>)) +import Control.Exception (catch, SomeException, try, bracket) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Reader (ask, runReaderT) +import Control.Monad.Trans.Either (runEitherT, hoistEither) +import Data.ByteString.Char8 (pack) +import Data.Monoid ((<>)) +import Data.Aeson (parseJSON, json', FromJSON) +import Data.Aeson.Types (parseEither) +import Network.Http.Client (Request, Connection, Method (GET), baselineContextSSL, + buildRequest, closeConnection, concatHandler, concatHandler', + getStatusCode, http, openConnectionSSL, receiveResponse, sendRequest, + setHeader, emptyBody, Response, StatusCode) +import Network (withSocketsDo) +import Network.HTTP.Types (urlEncode) +import OpenSSL (withOpenSSL) +import System.IO.Streams (InputStream) +import System.IO.Streams.Attoparsec (parseFromStream) + import Pinboard.Client.Types import Pinboard.Client.Error import Pinboard.Client.Util -import Data.ByteString.Char8(pack) +import qualified Data.ByteString as S +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + + +-- | Create a default PinboardConfig using the supplied apiToken fromApiToken :: String -> PinboardConfig fromApiToken token = PinboardConfig { debug = False, apiToken = pack token } + +-------------------------------------------------------------------------------- +-- | Execute computations from Pinboard.Api w/ json deserialization +runPinboardJson + :: FromJSON a + => PinboardConfig + -> Pinboard a + -> IO (Either PinboardError a) +runPinboardJson config requests = withOpenSSL $ + bracket connOpen connClose (either (connFail ConnectionFailure) go) + where go conn = runReaderT (runEitherT requests) (config, conn) + `catch` connFail UnknownErrorType + +-- | Create a Pinboard value from a PinboardRequest w/ json deserialization +pinboardJson :: FromJSON a => PinboardRequest -> Pinboard a +pinboardJson req = do + (config, conn) <- ask + (_, result) <- liftIO $ sendPinboardRequest (ensureResultFormatType FormatJson req) config conn parseJSONResponseStream + hoistEither result + + +-------------------------------------------------------------------------------- + +runPinboardSingleRaw + :: PinboardConfig + -> PinboardRequest + -> (Response -> InputStream S.ByteString -> IO a) + -> IO (Either PinboardError a) +runPinboardSingleRaw config req handler = withOpenSSL $ + bracket connOpen connClose (either (connFail ConnectionFailure) go) + where go conn = (Right <$> sendPinboardRequest req config conn handler) + `catch` connFail UnknownErrorType + +runPinboardSingleRawBS + :: PinboardConfig + -> PinboardRequest + -> IO (Either PinboardError S.ByteString) +runPinboardSingleRawBS config req = runPinboardSingleRaw config req concatHandler' + +runPinboardSingleJson + :: FromJSON a + => PinboardConfig + -> PinboardRequest + -> IO (Either PinboardError a) +runPinboardSingleJson config = runPinboardJson config . pinboardJson + + +-------------------------------------------------------------------------------- + +sendPinboardRequest + :: PinboardRequest + -> PinboardConfig + -> Connection + -> (Response -> InputStream S.ByteString -> IO a) + -> IO a +sendPinboardRequest PinboardRequest{..} PinboardConfig{..} conn handler = do + let url = S.concat [ T.encodeUtf8 requestPath + , "?" + , paramsToByteString $ ("auth_token", urlEncode False apiToken) : encodeParams requestParams ] + req <- buildReq url + sendRequest conn req emptyBody + receiveResponse conn handler + + +sendPinboardRequestBS + :: PinboardRequest + -> PinboardConfig + -> Connection + -> IO (Response, S.ByteString) +sendPinboardRequestBS request config conn = sendPinboardRequest request config conn handler + where handler response responseInputStream = do resultBS <- concatHandler response responseInputStream + return (response, resultBS) + +-------------------------------------------------------------------------------- + +buildReq :: S.ByteString -> IO Request +buildReq url = buildRequest $ do + http GET ("/v1/" <> url) + setHeader "Connection" "Keep-Alive" + setHeader "User-Agent" "pinboard.hs/0.4" + +-------------------------------------------------------------------------------- + +parseJSONResponseStream + :: FromJSON a + => Response + -> InputStream S.ByteString + -> IO (Response, Either PinboardError a) +parseJSONResponseStream response stream = + (response,) <$> either (return . Left . addErrMsg (toText response)) + (const $ parseJSONFromStream stream) + (checkStatusCode $ getStatusCode response) + + +parseJSONFromStream + :: FromJSON a + => InputStream S.ByteString + -> IO (Either PinboardError a) +parseJSONFromStream s = do + r <- parseFromStream (parseEither parseJSON <$> json') s + return $ either (Left . createParserErr . toText) Right r + `catch` connFail ParseFailure + +-------------------------------------------------------------------------------- + +checkStatusCode :: StatusCode -> Either PinboardError () +checkStatusCode = \case + 200 -> Right () + 400 -> httpStatusPinboardError BadRequest + 401 -> httpStatusPinboardError UnAuthorized + 402 -> httpStatusPinboardError RequestFailed + 403 -> httpStatusPinboardError Forbidden + 404 -> httpStatusPinboardError NotFound + 429 -> httpStatusPinboardError TooManyRequests + c | c >= 500 -> httpStatusPinboardError PinboardServerError + _ -> httpStatusPinboardError UnknownHTTPCode + +-------------------------------------------------------------------------------- + +httpStatusPinboardError :: PinboardErrorHTTPCode -> Either PinboardError a +httpStatusPinboardError err = Left $ defaultPinboardError + { errorType = HttpStatusFailure + , errorHTTP = Just err } + +addErrMsg :: T.Text -> PinboardError -> PinboardError +addErrMsg msg err = err {errorMsg = msg} + +createParserErr :: T.Text -> PinboardError +createParserErr msg = PinboardError ParseFailure msg Nothing Nothing Nothing + +-------------------------------------------------------------------------------- + + +connOpenRaw :: IO Connection +connOpenRaw = withSocketsDo $ do + ctx <- baselineContextSSL + openConnectionSSL ctx "api.pinboard.in" 443 + +connOpen :: IO (Either SomeException Connection) +connOpen = try connOpenRaw + +connClose :: Either a Connection -> IO () +connClose = either (const $ return ()) closeConnection + +connFail :: PinboardErrorType -> SomeException -> IO (Either PinboardError b) +connFail e msg = return $ Left $ PinboardError e (toText msg) Nothing Nothing Nothing + + diff --git a/src/Pinboard/Client/Internal.hs b/src/Pinboard/Client/Internal.hs deleted file mode 100644 --- a/src/Pinboard/Client/Internal.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} - ------------------------------------------------------------------------------- --- | --- Module : Pinboard.Client.Internal --- Copyright : (c) Jon Schoning, 2015 --- Maintainer : jonschoning@gmail.com --- Stability : experimental --- Portability : POSIX ------------------------------------------------------------------------------- - -module Pinboard.Client.Internal - ( - -- * Monadic - pinboardJson - , runPinboardJson - -- * Single - , runPinboardSingleRaw - , runPinboardSingleRawBS - , runPinboardSingleJson - -- * Sending - , sendPinboardRequest - , sendPinboardRequestBS - -- * Connections - , connOpenRaw - , connOpen - , connClose - , connFail - -- * JSON Streams - ,parseJSONResponseStream - ,parseJSONFromStream - -- * Status Codes - ,checkStatusCode - -- * Error Helpers - ,addErrMsg - ,createParserErr - ,httpStatusPinboardError - ) where - - -import Control.Applicative ((<$>)) -import Control.Exception (catch, SomeException, try, bracket) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Reader (ask, runReaderT) -import Control.Monad.Trans.Either (runEitherT, hoistEither) -import Data.Monoid ((<>)) -import Data.Aeson (parseJSON, json', FromJSON) -import Data.Aeson.Types (parseEither) -import Network.Http.Client (Request, Connection, Method (GET), baselineContextSSL, - buildRequest, closeConnection, concatHandler, concatHandler', - getStatusCode, http, openConnectionSSL, receiveResponse, sendRequest, - setHeader, emptyBody, Response, StatusCode) -import Network (withSocketsDo) -import Network.HTTP.Types (urlEncode) -import OpenSSL (withOpenSSL) -import System.IO.Streams (InputStream) -import System.IO.Streams.Attoparsec (parseFromStream) - -import Pinboard.Client.Error (PinboardError (..), - PinboardErrorHTTPCode (..), - PinboardErrorType (..), - defaultPinboardError) -import Pinboard.Client.Types (Pinboard, - PinboardConfig (..), - PinboardRequest (..), - Param (..)) -import Pinboard.Client.Util (encodeParams, paramsToByteString, toText) - -import qualified Data.ByteString as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T - - -pinboardJson :: FromJSON a => PinboardRequest -> Pinboard a -pinboardJson req = do - let reqJson = req { requestParams = Format "json" : requestParams req } - (config, conn) <- ask - (_, result) <- liftIO $ sendPinboardRequest reqJson config conn parseJSONResponseStream - hoistEither result - -runPinboardJson - :: FromJSON a - => PinboardConfig - -> Pinboard a - -> IO (Either PinboardError a) -runPinboardJson config requests = withOpenSSL $ - bracket connOpen connClose (either (connFail ConnectionFailure) go) - where go conn = runReaderT (runEitherT requests) (config, conn) - `catch` connFail UnknownErrorType - --------------------------------------------------------------------------------- - -runPinboardSingleRaw - :: PinboardConfig - -> PinboardRequest - -> (Response -> InputStream S.ByteString -> IO a) - -> IO (Either PinboardError a) -runPinboardSingleRaw config req handler = withOpenSSL $ - bracket connOpen connClose (either (connFail ConnectionFailure) go) - where go conn = (Right <$> sendPinboardRequest req config conn handler) - `catch` connFail UnknownErrorType - -runPinboardSingleRawBS - :: PinboardConfig - -> PinboardRequest - -> IO (Either PinboardError S.ByteString) -runPinboardSingleRawBS config req = runPinboardSingleRaw config req concatHandler' - -runPinboardSingleJson - :: FromJSON a - => PinboardConfig - -> PinboardRequest - -> IO (Either PinboardError a) -runPinboardSingleJson config = runPinboardJson config . pinboardJson - - --------------------------------------------------------------------------------- - -sendPinboardRequest - :: PinboardRequest - -> PinboardConfig - -> Connection - -> (Response -> InputStream S.ByteString -> IO a) - -> IO a -sendPinboardRequest PinboardRequest{..} PinboardConfig{..} conn handler = do - let url = S.concat [ T.encodeUtf8 requestPath - , "?" - , paramsToByteString $ ("auth_token", urlEncode False apiToken) : encodeParams requestParams ] - req <- buildReq url - sendRequest conn req emptyBody - receiveResponse conn handler - - -sendPinboardRequestBS - :: PinboardRequest - -> PinboardConfig - -> Connection - -> IO (Response, S.ByteString) -sendPinboardRequestBS request config conn = sendPinboardRequest request config conn handler - where handler response responseInputStream = do resultBS <- concatHandler response responseInputStream - return (response, resultBS) - --------------------------------------------------------------------------------- - -buildReq :: S.ByteString -> IO Request -buildReq url = buildRequest $ do - http GET ("/v1/" <> url) - setHeader "Connection" "Keep-Alive" - setHeader "User-Agent" "pinboard.hs/0.4" - --------------------------------------------------------------------------------- - -parseJSONResponseStream - :: FromJSON a - => Response - -> InputStream S.ByteString - -> IO (Response, Either PinboardError a) -parseJSONResponseStream response stream = - (response,) <$> either (return . Left . addErrMsg (toText response)) - (const $ parseJSONFromStream stream) - (checkStatusCode $ getStatusCode response) - - -parseJSONFromStream - :: FromJSON a - => InputStream S.ByteString - -> IO (Either PinboardError a) -parseJSONFromStream s = do - r <- parseFromStream (parseEither parseJSON <$> json') s - return $ either (Left . createParserErr . toText) Right r - `catch` connFail ParseFailure - --------------------------------------------------------------------------------- - -checkStatusCode :: StatusCode -> Either PinboardError () -checkStatusCode = \case - 200 -> Right () - 400 -> httpStatusPinboardError BadRequest - 401 -> httpStatusPinboardError UnAuthorized - 402 -> httpStatusPinboardError RequestFailed - 403 -> httpStatusPinboardError Forbidden - 404 -> httpStatusPinboardError NotFound - 429 -> httpStatusPinboardError TooManyRequests - c | c >= 500 -> httpStatusPinboardError PinboardServerError - _ -> httpStatusPinboardError UnknownHTTPCode - --------------------------------------------------------------------------------- - -httpStatusPinboardError :: PinboardErrorHTTPCode -> Either PinboardError a -httpStatusPinboardError err = Left $ defaultPinboardError - { errorType = HttpStatusFailure - , errorHTTP = Just err } - -addErrMsg :: T.Text -> PinboardError -> PinboardError -addErrMsg msg err = err {errorMsg = msg} - -createParserErr :: T.Text -> PinboardError -createParserErr msg = PinboardError ParseFailure msg Nothing Nothing Nothing - --------------------------------------------------------------------------------- - - -connOpenRaw :: IO Connection -connOpenRaw = withSocketsDo $ do - ctx <- baselineContextSSL - openConnectionSSL ctx "api.pinboard.in" 443 - -connOpen :: IO (Either SomeException Connection) -connOpen = try connOpenRaw - -connClose :: Either a Connection -> IO () -connClose = either (const $ return ()) closeConnection - -connFail :: PinboardErrorType -> SomeException -> IO (Either PinboardError b) -connFail e msg = return $ Left $ PinboardError e (toText msg) Nothing Nothing Nothing - - diff --git a/src/Pinboard/Client/Types.hs b/src/Pinboard/Client/Types.hs --- a/src/Pinboard/Client/Types.hs +++ b/src/Pinboard/Client/Types.hs @@ -10,6 +10,7 @@ ( Pinboard , PinboardRequest (..) , PinboardConfig (..) + , ResultFormatType (..) , Param (..) , ParamsBS ) where @@ -46,7 +47,10 @@ ------------------------------------------------------------------------------ -data Param = Format Text +data ResultFormatType = FormatJson | FormatXml + deriving (Show, Eq) + +data Param = Format ResultFormatType | Tag Text | Tags Text | Old Text diff --git a/src/Pinboard/Client/Util.hs b/src/Pinboard/Client/Util.hs --- a/src/Pinboard/Client/Util.hs +++ b/src/Pinboard/Client/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} -- | -- Module : Pinboard.Client.Util -- Copyright : (c) Jon Schoning, 2015 @@ -15,6 +16,7 @@ , paramToName , paramToText , encodeParams + , ensureResultFormatType ) where import Data.Monoid (Monoid, mconcat, mempty, (<>)) @@ -22,7 +24,7 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import Pinboard.Client.Types (PinboardConfig (..), Param (..), ParamsBS) +import Pinboard.Client.Types (PinboardRequest (..), PinboardConfig (..), ResultFormatType (..), Param (..), ParamsBS) import Network.HTTP.Types(urlEncode) ------------------------------------------------------------------------------ @@ -65,13 +67,20 @@ return ( T.encodeUtf8 k , (urlEncode True . T.encodeUtf8 ) v ) +ensureResultFormatType :: ResultFormatType -> PinboardRequest -> PinboardRequest +ensureResultFormatType fmt req = + if hasFormat then req else req { requestParams = Format fmt : params } + where params = requestParams req + hasFormat = Format fmt `elem` params + paramToText :: Param -> (Text, Text) paramToText (Tag a) = ("tag", a) paramToText (Tags a) = ("tags", a) paramToText (Old a) = ("old", a) paramToText (New a) = ("new", a) -paramToText (Format a) = ("format", a) +paramToText (Format FormatJson) = ("format", "json") +paramToText (Format FormatXml) = ("format", "xml") paramToText (Count a) = ("count", toText a) paramToText (Start a) = ("start", toText a) paramToText (Results a) = ("results", toText a)