Browse Source

init

master
Jon Schoning 7 years ago
commit
f3e6f74b6d
  1. 9
      .gitignore
  2. 21
      LICENSE
  3. 4
      Setup.lhs
  4. 46
      pinboard.cabal
  5. 18
      src/Web/Pinboard.hs
  6. 41
      src/Web/Pinboard/Api.hs
  7. 59
      src/Web/Pinboard/ApiTypes.hs
  8. 22
      src/Web/Pinboard/Client.hs
  9. 52
      src/Web/Pinboard/Client/Error.hs
  10. 159
      src/Web/Pinboard/Client/Internal.hs
  11. 49
      src/Web/Pinboard/Client/Types.hs
  12. 84
      src/Web/Pinboard/Client/Util.hs

9
.gitignore

@ -0,0 +1,9 @@
dist
.cabal-sandbox
cabal.sandbox.config
/src/Web/.DS_Store
.DS_Store
/tests.aux
/tests.hp
/tests.prof
/tests.ps

21
LICENSE

@ -0,0 +1,21 @@
The MIT License (MIT)
Copyright (c) 2015 Jon Schoning
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.

4
Setup.lhs

@ -0,0 +1,4 @@
#! /usr/bin/env runhaskell
> import Distribution.Simple
> main = defaultMain

46
pinboard.cabal

@ -0,0 +1,46 @@
name: pinboard
version: 0.0.0.1
synopsis: Pinboard API for Haskell
license: MIT
license-file: LICENSE
author: Jon Schoning
maintainer: jonschoning@gmail.com
copyright: Copyright (c) 2015 Jon Schoning
homepage: https://github.com/jonschoning/pinboard
bug-reports: https://github.com/jonschoning/pinboard/issues
category: Web
build-type: Simple
cabal-version: >=1.10
Description:
library
hs-source-dirs: src
build-depends: HsOpenSSL
, aeson
, base >=4.6 && <4.8
, bytestring
, either
, http-streams
, io-streams
, mtl >= 2.1.3.1
, random >= 1.1
, text
, time
, transformers
, unordered-containers
default-language: Haskell2010
other-modules:
exposed-modules:
Web.Pinboard
Web.Pinboard.Api
Web.Pinboard.ApiTypes
Web.Pinboard.Client
Web.Pinboard.Client.Internal
Web.Pinboard.Client.Error
Web.Pinboard.Client.Types
Web.Pinboard.Client.Util
ghc-options: -Wall -O2 -rtsopts
source-repository head
type: git
location: git://github.com/jonschoning/pinboard.git

18
src/Web/Pinboard.hs

@ -0,0 +1,18 @@
-------------------------------------------
-- |
-- Module : Web.Pinboard
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
--
module Web.Pinboard (
module Web.Pinboard.Client
, module Web.Pinboard.Api
, module Web.Pinboard.ApiTypes
) where
import Web.Pinboard.Client
import Web.Pinboard.Api
import Web.Pinboard.ApiTypes

41
src/Web/Pinboard/Api.hs

@ -0,0 +1,41 @@
{-# LANGUAGE OverloadedStrings #-}
-------------------------------------------
-- |
-- Module : Web.Pinboard.Api
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
--
-- < https://pinboard.in/api/ >
module Web.Pinboard.Api
(
Tag,
Count,
getPostsRecent
) where
import Web.Pinboard.Client.Internal (pinboardJson)
import Web.Pinboard.Client.Types (Pinboard, PinboardRequest (..))
import Web.Pinboard.Client.Util (toText, getParams)
import Web.Pinboard.ApiTypes
import Control.Applicative ((<$>))
import Data.Text (Text, intercalate)
------------------------------------------------------------------------------
type Tag = Text
type Count = Int
-- | Returns a list of the user's most recent posts, filtered by tag.
getPostsRecent
:: 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 (PinboardRequest url params)
where
url = "posts/recent"
params = getParams
[ ("tag", intercalate "," <$> tags)
, ("count", toText <$> count) ]

59
src/Web/Pinboard/ApiTypes.hs

@ -0,0 +1,59 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Web.Pinboard.Types
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
module Web.Pinboard.ApiTypes where
import Prelude hiding(words)
import Control.Applicative ((<$>), (<*>))
import Data.Aeson (FromJSON (parseJSON),
Value (Object), (.:))
import Data.Text (Text, words)
import Data.Time (UTCTime)
data Posts = Posts {
postsDate :: UTCTime
, postsUser :: Text
, posts :: [Post]
} deriving (Show, Eq)
instance FromJSON Posts where
parseJSON (Object o) =
Posts <$> o .: "date"
<*> o .: "user"
<*> o .: "posts"
parseJSON _ = error "bad parse"
data Post = Post {
postHref :: Text
, postDescription :: Text
, postExtended :: Text
, postMeta :: Text
, postHash :: Text
, postTime :: UTCTime
, postShared :: Bool
, postToread :: Bool
, postTags :: [Text]
} deriving (Show, Eq)
instance FromJSON Post where
parseJSON (Object o) =
Post <$> o .: "href"
<*> o .: "description"
<*> o .: "extended"
<*> o .: "meta"
<*> o .: "hash"
<*> o .: "time"
<*> (boolFromYesNo <$> o .: "shared")
<*> (boolFromYesNo <$> o .: "toread")
<*> (words <$> o .: "tags")
parseJSON _ = error "bad parse"
boolFromYesNo :: Text -> Bool
boolFromYesNo "yes" = True
boolFromYesNo _ = False

22
src/Web/Pinboard/Client.hs

@ -0,0 +1,22 @@
-- |
-- Module : Web.Pinboard.Client
-- Copyright : (c) Jon Schoning
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
--
-- Convenience module containing re-exports from other modules
--
module Web.Pinboard.Client
(
runPinboardJson
, PinboardConfig (..)
, module Web.Pinboard.Client.Error
, module Web.Pinboard.Client.Types
, module Web.Pinboard.Client.Util
) where
import Web.Pinboard.Client.Internal
import Web.Pinboard.Client.Types
import Web.Pinboard.Client.Error
import Web.Pinboard.Client.Util

52
src/Web/Pinboard/Client/Error.hs

@ -0,0 +1,52 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Web.Pinboard.Client.Error
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
module Web.Pinboard.Client.Error
( defaultPinboardError
, PinboardErrorHTTPCode (..)
, PinboardErrorType (..)
, PinboardErrorCode (..)
, PinboardError (..)
) where
import Data.Text (Text)
import Data.Monoid(mempty)
------------------------------------------------------------------------------
data PinboardErrorHTTPCode =
BadRequest -- ^ 400
| UnAuthorized -- ^ 401
| RequestFailed -- ^ 402
| Forbidden -- ^ 403
| NotFound -- ^ 404
| PinboardServerError -- ^ (>=500)
| UnknownHTTPCode -- ^ All other codes
deriving Show
------------------------------------------------------------------------------
data PinboardErrorType =
ConnectionFailure
| ParseFailure
| UnknownErrorType
deriving Show
------------------------------------------------------------------------------
data PinboardErrorCode =
UnknownError
deriving Show
------------------------------------------------------------------------------
data PinboardError = PinboardError {
errorType :: PinboardErrorType
, errorMsg :: Text
, errorCode :: Maybe PinboardErrorCode
, errorParam :: Maybe Text
, errorHTTP :: Maybe PinboardErrorHTTPCode
} deriving Show
defaultPinboardError :: PinboardError
defaultPinboardError = PinboardError UnknownErrorType mempty Nothing Nothing Nothing

159
src/Web/Pinboard/Client/Internal.hs

@ -0,0 +1,159 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
------------------------------------------------------------------------------
-- |
-- Module : Web.Pinboard.Client.Internal
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
------------------------------------------------------------------------------
module Web.Pinboard.Client.Internal
(
runPinboardSingleRaw
, runPinboardSingleRawBS
, runPinboardSingleJson
, runPinboardJson
, pinboardJson
, sendPinboardRequestBS
) 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 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 OpenSSL (withOpenSSL)
import System.IO.Streams (InputStream)
import Web.Pinboard.Client.Error (PinboardError (..),
PinboardErrorHTTPCode (..),
PinboardErrorType (..),
defaultPinboardError)
import Web.Pinboard.Client.Types (Pinboard,
PinboardConfig (..),
PinboardRequest (..))
import Web.Pinboard.Client.Util (paramsToByteString, toText)
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
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 { queryParams = ("format", "json") : queryParams 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
500 -> pinboardError PinboardServerError
502 -> pinboardError PinboardServerError
503 -> pinboardError PinboardServerError
504 -> pinboardError PinboardServerError
_ -> pinboardError UnknownHTTPCode
_ -> left defaultPinboardError
--------------------------------------------------------------------------------
sendPinboardRequest
:: PinboardRequest
-> PinboardConfig
-> Connection
-> (Response -> InputStream S.ByteString -> IO a)
-> IO a
sendPinboardRequest PinboardRequest{..} PinboardConfig{..} conn handler = do
let url = S.concat [ T.encodeUtf8 endpoint , "?" , paramsToByteString $ ("auth_token", apiToken) : queryParams ]
req <- buildReq url
sendRequest conn req emptyBody
receiveResponse conn handler
where
buildReq url = buildRequest $ do
http GET ("/v1/" <> url)
setHeader "Connection" "Keep-Alive"
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)

49
src/Web/Pinboard/Client/Types.hs

@ -0,0 +1,49 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Web.Pinboard.Client.Types
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
module Web.Pinboard.Client.Types
( Pinboard
, PinboardRequest (..)
, PinboardConfig (..)
, mkParams
, mkConfig
) where
import Control.Monad.Reader (ReaderT)
import Control.Monad.Trans.Either (EitherT)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Network.Http.Client (Connection)
import Web.Pinboard.Client.Error (PinboardError (..))
import Data.Monoid(mempty)
------------------------------------------------------------------------------
type Pinboard = EitherT PinboardError (ReaderT (PinboardConfig, Connection) IO)
------------------------------------------------------------------------------
type Params = [(ByteString, ByteString)]
------------------------------------------------------------------------------
data PinboardRequest = PinboardRequest
{ endpoint :: Text -- ^ Endpoint of PinboardRequest
, queryParams :: Params -- ^ Query Parameters of PinboardRequest
} deriving Show
------------------------------------------------------------------------------
data PinboardConfig = PinboardConfig
{ apiToken :: ByteString
, debug :: Bool
} deriving Show
------------------------------------------------------------------------------
mkParams :: Params
mkParams = mempty
mkConfig :: PinboardConfig
mkConfig = PinboardConfig { debug = False, apiToken = mempty }

84
src/Web/Pinboard/Client/Util.hs

@ -0,0 +1,84 @@
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Web.Pinboard.Client.Util
-- Copyright : (c) Jon Schoning, 2015
-- Maintainer : jonschoning@gmail.com
-- Stability : experimental
-- Portability : POSIX
module Web.Pinboard.Client.Util
( -- * Utils
fromSeconds
, toSeconds
, paramsToByteString
, toText
, toTextLower
, getParams
, (</>)
) where
import Data.ByteString (ByteString)
import Data.Monoid (Monoid, mconcat, mempty, (<>))
import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
------------------------------------------------------------------------------
-- | Conversion from a `Show` constrained type to `Text`
toText
:: Show a
=> a
-> Text
toText = T.pack . show
------------------------------------------------------------------------------
-- | Conversion from a `Show` constrained type to lowercase `Text`
toTextLower
:: Show a
=> a
-> Text
toTextLower = T.toLower . T.pack . show
------------------------------------------------------------------------------
-- | Conversion of a key value pair to a query parameterized string
paramsToByteString
:: (Monoid m, IsString m)
=> [(m, m)]
-> m
paramsToByteString [] = mempty
paramsToByteString ((x,y) : []) = x <> "=" <> y
paramsToByteString ((x,y) : xs) =
mconcat [ x, "=", y, "&" ] <> paramsToByteString xs
------------------------------------------------------------------------------
-- | Forward slash interspersion on `Monoid` and `IsString`
-- constrained types
(</>)
:: (Monoid m, IsString m)
=> m
-> m
-> m
m1 </> m2 = m1 <> "/" <> m2
------------------------------------------------------------------------------
-- | Convert an `Integer` to a `UTCTime`
fromSeconds
:: Integer
-> UTCTime
fromSeconds = posixSecondsToUTCTime . fromInteger
------------------------------------------------------------------------------
-- | Convert a `UTCTime` to a `Integer`
toSeconds
:: UTCTime
-> Integer
toSeconds = read . takeWhile (/='.') . show . utcTimeToPOSIXSeconds
------------------------------------------------------------------------------
-- | Retrieve and encode the optional parameters
getParams
:: [(ByteString, Maybe Text)]
-> [(ByteString, ByteString)]
getParams xs = [ (x, T.encodeUtf8 y) | (x, Just y) <- xs ]
Loading…
Cancel
Save