diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -41,16 +41,3 @@ [Pinboard.ApiTypes](https://hackage.haskell.org/package/pinboard/docs/Pinboard-ApiTypes.html) Pinboard Data Structures returned by the Api - -## Windows - -This package relies on HsOpenSSL which requires a binary distribution of openssl - -In order for this install to go smoothly one must install a binary distribution of openssl from here: - - http://slproweb.com/products/Win32OpenSSL.html - -and link during the cabal install process like this (assuing default install directories): - - cabal install HsOpenSSL --extra-include-dirs="c:/OpenSSL-Win32/include" --extra-lib-dirs="c:/OpenSSL-Win32" - diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,16 @@ +__v0.7.5__ + +replacing/removing io-streams in favor of http-client + +__v0.6.5__ + +compatability with both time < 1.5 and time >= 1.5 + +__v0.6.4__ + +add ability to update a post directly from a Post record (save an existing post) + +__v0.6.3__ + +add ToJson instances +add pretty print function diff --git a/pinboard.cabal b/pinboard.cabal --- a/pinboard.cabal +++ b/pinboard.cabal @@ -1,5 +1,5 @@ name: pinboard -version: 0.6.5 +version: 0.7.5 synopsis: Access to the Pinboard API license: MIT license-file: LICENSE @@ -31,7 +31,7 @@ > Left pinboardError -> print pinboardError . Extra-Source-Files: - README.md CHANGELOG.md + README.md changelog.md library hs-source-dirs: src build-depends: base >=4.6 && < 5.0 @@ -39,14 +39,12 @@ , bytestring , containers , either - , haskell-src-exts - , HsOpenSSL - , http-streams , http-types - , io-streams + , http-client + , http-client-tls , mtl >= 2.1.3.1 - , network , old-locale + , network , random >= 1.1 , text , time diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs --- a/src/Pinboard/ApiTypes.hs +++ b/src/Pinboard/ApiTypes.hs @@ -21,8 +21,8 @@ import Data.Time (UTCTime) import Data.Time.Calendar (Day) -import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Pretty +-- import Language.Haskell.Exts.Parser +-- import Language.Haskell.Exts.Pretty import qualified Data.HashMap.Strict as HM import qualified Data.Vector as V @@ -284,15 +284,13 @@ parseJSON (Object o) = ToUpdateTime <$> (o .: "update_time") parseJSON _ = error "bad parse" --- * Pretty - -prettyString :: String -> String -prettyString s = case parseExp s of - ParseOk x -> prettyPrint x - ParseFailed{} -> s +-- prettyString :: String -> String +-- prettyString s = case parseExp s of +-- ParseOk x -> prettyPrint x +-- ParseFailed{} -> s -pretty :: Show a => a -> String -pretty = prettyString . show +-- pretty :: Show a => a -> String +-- pretty = prettyString . show -- * Aliases diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs --- a/src/Pinboard/Client.hs +++ b/src/Pinboard/Client.hs @@ -27,16 +27,15 @@ , runPinboardSingleJson -- * Sending , sendPinboardRequest - , sendPinboardRequestBS - -- * Connections - , connOpenRaw - , connOpen - , connClose - , connFail - -- * JSON Streams - ,parseJSONResponseStream - ,parseJSONFromStream + -- * Manager (http-client) + , mgrOpenRaw + , mgrOpen + , mgrFail + -- * JSON Handling + ,parseJSONResponse + ,decodeJSONResponse -- * Status Codes + ,checkStatusCodeResponse ,checkStatusCode -- * Error Helpers ,addErrMsg @@ -55,23 +54,21 @@ 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 Data.Aeson (FromJSON, eitherDecodeStrict') + import Network (withSocketsDo) import Network.HTTP.Types (urlEncode) -import OpenSSL (withOpenSSL) -import System.IO.Streams (InputStream) -import System.IO.Streams.Attoparsec (parseFromStream) +import Network.HTTP.Types.Status (statusCode) +import Network.HTTP.Client +import Network.HTTP.Client.TLS + + import Pinboard.Client.Types import Pinboard.Client.Error import Pinboard.Client.Util -import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -89,16 +86,16 @@ :: PinboardConfig -> Pinboard a -> IO (Either PinboardError a) -runPinboard config requests = withOpenSSL $ - bracket connOpen connClose (either (connFail ConnectionFailure) go) - where go conn = runReaderT (runEitherT requests) (config, conn) - `catch` connFail UnknownErrorType +runPinboard config requests = + bracket mgrOpen return (either (mgrFail ConnectionFailure) go) + where go mgr = runReaderT (runEitherT requests) (config, mgr) + `catch` mgrFail 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 + (config, mgr) <- ask + result <- liftIO $ sendPinboardRequest (ensureResultFormatType FormatJson req) config mgr parseJSONResponse hoistEither result @@ -107,18 +104,22 @@ runPinboardSingleRaw :: PinboardConfig -> PinboardRequest - -> (Response -> InputStream S.ByteString -> IO a) + -> (Response LBS.ByteString -> 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 +runPinboardSingleRaw config req handler = + bracket mgrOpen return (either (mgrFail ConnectionFailure) go) + where go mgr = (Right <$> sendPinboardRequest req config mgr handler) + `catch` mgrFail UnknownErrorType runPinboardSingleRawBS :: PinboardConfig -> PinboardRequest - -> IO (Either PinboardError S.ByteString) -runPinboardSingleRawBS config req = runPinboardSingleRaw config req concatHandler' + -> IO (Either PinboardError LBS.ByteString) +runPinboardSingleRawBS config req = do + res <- runPinboardSingleRaw config req id + return $ do + r <- res + responseBody r <$ checkStatusCodeResponse r runPinboardSingleJson :: FromJSON a @@ -133,60 +134,53 @@ sendPinboardRequest :: PinboardRequest -> PinboardConfig - -> Connection - -> (Response -> InputStream S.ByteString -> IO a) + -> Manager + -> (Response LBS.ByteString -> a) -> IO a -sendPinboardRequest PinboardRequest{..} PinboardConfig{..} conn handler = do - let url = S.concat [ T.encodeUtf8 requestPath +sendPinboardRequest PinboardRequest{..} PinboardConfig{..} man handler = do + let url = T.concat [ 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) + , T.decodeUtf8 $ paramsToByteString $ ("auth_token", urlEncode False apiToken) : encodeParams requestParams ] + req <- buildReq $ T.unpack url + res <- httpLbs req man + return $ handler res -------------------------------------------------------------------------------- -buildReq :: S.ByteString -> IO Request -buildReq url = buildRequest $ do - http GET ("/v1/" <> url) - setHeader "Connection" "Keep-Alive" - setHeader "User-Agent" "pinboard.hs/0.6.5" +buildReq :: String -> IO Request +buildReq url = do + req <- parseUrl $ "https://api.pinboard.in/v1/" <> url + return $ req + { requestHeaders = [("User-Agent","pinboard.hs/0.7.5")] + , checkStatus = \_ _ _ -> Nothing + } -------------------------------------------------------------------------------- -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) +parseJSONResponse + :: (FromJSON a) + => Response LBS.ByteString + -> Either PinboardError a +parseJSONResponse response = + either (Left . addErrMsg (toText (responseBody response))) + (const $ decodeJSONResponse (responseBody response)) + (checkStatusCodeResponse response) -parseJSONFromStream +decodeJSONResponse :: 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 + => LBS.ByteString + -> Either PinboardError a +decodeJSONResponse s = + let r = eitherDecodeStrict' (LBS.toStrict s) + in either (Left . createParserErr . toText) Right r -------------------------------------------------------------------------------- -checkStatusCode :: StatusCode -> Either PinboardError () +checkStatusCodeResponse :: Response a -> Either PinboardError () +checkStatusCodeResponse = checkStatusCode . statusCode . responseStatus + +checkStatusCode :: Int -> Either PinboardError () checkStatusCode = \case 200 -> Right () 400 -> httpStatusPinboardError BadRequest @@ -214,18 +208,14 @@ -------------------------------------------------------------------------------- -connOpenRaw :: IO Connection -connOpenRaw = withSocketsDo $ do - ctx <- baselineContextSSL - openConnectionSSL ctx "api.pinboard.in" 443 - -connOpen :: IO (Either SomeException Connection) -connOpen = try connOpenRaw +mgrOpenRaw :: IO Manager +mgrOpenRaw = withSocketsDo . newManager + $ managerSetProxy (proxyEnvironment Nothing) tlsManagerSettings -connClose :: Either a Connection -> IO () -connClose = either (const $ return ()) closeConnection +mgrOpen :: IO (Either SomeException Manager) +mgrOpen = try mgrOpenRaw -connFail :: PinboardErrorType -> SomeException -> IO (Either PinboardError b) -connFail e msg = return $ Left $ PinboardError e (toText msg) Nothing Nothing Nothing +mgrFail :: PinboardErrorType -> SomeException -> IO (Either PinboardError b) +mgrFail 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 @@ -19,14 +19,14 @@ import Control.Monad.Trans.Either (EitherT) import Data.ByteString (ByteString) import Data.Text (Text) -import Network.Http.Client (Connection) +import Network.HTTP.Client (Manager) import Pinboard.Client.Error (PinboardError (..)) import Data.Time.Calendar(Day) import Data.Time.Clock(UTCTime) ------------------------------------------------------------------------------ -type Pinboard = EitherT PinboardError (ReaderT (PinboardConfig, Connection) IO) +type Pinboard = EitherT PinboardError (ReaderT (PinboardConfig, Manager) IO) ------------------------------------------------------------------------------