pinboard 0.1 → 0.2

raw patch · 5 files changed

+144/−87 lines, 5 filesdep +networkPVP ok

version bump matches the API change (PVP)

Dependencies added: network

API changes (from Hackage documentation)

Files

• pinboard.cabal +2/−1
• src/Pinboard/ApiTypes.hs +1/−1
• src/Pinboard/Client.hs +3/−3
• src/Pinboard/Client/Error.hs +1/−0
• src/Pinboard/Client/Internal.hs +137/−82

@@ -1,5 +1,5 @@ name:                pinboard-version:             0.1+version:             0.2 synopsis:            Access to the Pinboard API license:             MIT license-file:        LICENSE@@ -42,6 +42,7 @@                      , http-types                      , io-streams                      , mtl >= 2.1.3.1+                     , network                      , old-locale                      , random >= 1.1                      , text

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  -- |--- Module      : Pinboard.Types+-- Module      : Pinboard.ApiTypes -- Copyright   : (c) Jon Schoning, 2015 -- Maintainer  : jonschoning@gmail.com -- Stability   : experimental

@@ -35,7 +35,7 @@ import Pinboard.Client.Types import Pinboard.Client.Error import Pinboard.Client.Util-import Data.ByteString (ByteString)+import Data.ByteString.Char8(pack) -fromApiToken :: ByteString -> PinboardConfig-fromApiToken token = PinboardConfig { debug = False, apiToken = token }+fromApiToken :: String -> PinboardConfig+fromApiToken token = PinboardConfig { debug = False, apiToken = pack token }

@@ -31,6 +31,7 @@ ------------------------------------------------------------------------------ data PinboardErrorType =         ConnectionFailure+        | HttpStatusFailure         | ParseFailure         | UnknownErrorType            deriving Show

@@ -1,5 +1,8 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TupleSections #-}+ ------------------------------------------------------------------------------ -- |  -- Module      : Pinboard.Client.Internal@@ -11,48 +14,73 @@  module Pinboard.Client.Internal     ( -      runPinboardSingleRaw+      -- * Monadic+      pinboardJson+    , runPinboardJson+      -- * Single+    , runPinboardSingleRaw     , runPinboardSingleRawBS     , runPinboardSingleJson-    , runPinboardJson-    , pinboardJson+      -- * 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              (when)-import           Control.Monad.IO.Class     (MonadIO (liftIO))-import           Control.Monad.Reader       (ask, runReaderT)-import           Control.Monad.Trans.Either (left, runEitherT, right)-import           Data.Aeson                 (FromJSON, Value(..), eitherDecodeStrict)-import           Data.Monoid                ((<>))+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-import           Network.Http.Client        (Connection, Method (GET),-                                             baselineContextSSL, buildRequest,-                                             closeConnection, concatHandler, concatHandler', -                                             getStatusCode, http,-                                             openConnectionSSL,-                                             receiveResponse, sendRequest,-                                             setHeader, emptyBody, Response)-import Network.HTTP.Types(urlEncode)-import           OpenSSL                    (withOpenSSL)-import           System.IO.Streams          (InputStream)-import           Pinboard.Client.Error  (PinboardError (..),-                                             PinboardErrorHTTPCode (..),-                                             PinboardErrorType (..),-                                             defaultPinboardError)-import           Pinboard.Client.Types  (Pinboard,-                                             PinboardConfig (..),-                                             PinboardRequest (..),-                                             Param (..))-import           Pinboard.Client.Util    (encodeParams, paramsToByteString, toText) --------------------------------------------------------------------------------- +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@@ -63,6 +91,8 @@   where go conn = runReaderT (runEitherT requests) (config, conn)                    `catch` connFail UnknownErrorType +--------------------------------------------------------------------------------+ runPinboardSingleRaw     :: PinboardConfig            -> PinboardRequest@@ -86,55 +116,9 @@     -> IO (Either PinboardError a) runPinboardSingleJson config = runPinboardJson config . pinboardJson --------------------------------------------------------------------------------- -connOpenRaw :: IO Connection-connOpenRaw = 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- -------------------------------------------------------------------------------- -pinboardJson :: FromJSON a => PinboardRequest -> Pinboard a-pinboardJson req = do -  (config, conn)  <- ask-  result <- liftIO (sendPinboardRequestBS reqJson config conn)-  handleResultBS (debug config) result-  where-    reqJson =  req { requestParams = Format "json" : requestParams req }-    handleDecodeError dbg resultBS msg = do-      when dbg $ liftIO $ print (eitherDecodeStrict resultBS :: Either String Value)-      left $ PinboardError ParseFailure (T.pack msg) Nothing Nothing Nothing -    handleResultBS dbg (response, resultBS) =-          case getStatusCode response of-            200 -> either (handleDecodeError dbg resultBS) right (eitherDecodeStrict resultBS)-            code | code >= 400 ->-                     let pinboardError err = left $ defaultPinboardError { errorMsg = toText resultBS, errorHTTP = Just err } in-                     case code of-                      400 -> pinboardError BadRequest-                      401 -> pinboardError UnAuthorized-                      402 -> pinboardError RequestFailed-                      403 -> pinboardError Forbidden-                      404 -> pinboardError NotFound-                      429 -> pinboardError TooManyRequests-                      500 -> pinboardError PinboardServerError-                      502 -> pinboardError PinboardServerError-                      503 -> pinboardError PinboardServerError-                      504 -> pinboardError PinboardServerError-                      _   -> pinboardError UnknownHTTPCode-            _ -> left defaultPinboardError----------------------------------------------------------------------------------- sendPinboardRequest       :: PinboardRequest        -> PinboardConfig @@ -148,12 +132,8 @@    req <- buildReq url    sendRequest conn req emptyBody    receiveResponse conn handler-  where-    buildReq url = buildRequest $ do-      http GET ("/v1/" <> url)-      setHeader "Connection" "Keep-Alive"  -      setHeader "User-Agent" "pinboard.hs/0.1"   + sendPinboardRequestBS    :: PinboardRequest    -> PinboardConfig @@ -162,4 +142,79 @@ 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.2"  ++--------------------------------------------------------------------------------++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+