pinboard 0.4 → 0.5

raw patch · 8 files changed

+313/−310 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• pinboard.cabal +1/−2
• src/Pinboard/Api.hs +17/−16
• src/Pinboard/ApiRequest.hs +68/−46
• src/Pinboard/ApiTypes.hs +0/−1
• src/Pinboard/Client.hs +211/−22
• src/Pinboard/Client/Internal.hs +0/−220
• src/Pinboard/Client/Types.hs +5/−1
• src/Pinboard/Client/Util.hs +11/−2

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

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

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

@@ -23,7 +23,6 @@ import System.Locale       (defaultTimeLocale) import qualified Data.HashMap.Strict as HM - -- * Posts  data Posts = Posts {

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

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

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

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