packages feed

pinboard (empty) → 0.1

raw patch · 11 files changed

+1016/−0 lines, 11 filesdep +HsOpenSSLdep +aesondep +basesetup-changed

Dependencies added: HsOpenSSL, aeson, base, bytestring, containers, either, http-streams, http-types, io-streams, mtl, old-locale, random, text, time, transformers, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ pinboard.cabal view
@@ -0,0 +1,67 @@+name:                pinboard+version:             0.1+synopsis:            Access to the Pinboard API+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:            Network APIs+build-type:          Simple+cabal-version:       >=1.10+Description:         +    .+    The Pinboard API is a way to interact programatically with+    your bookmarks, notes and other Pinboard data. This+    library wraps the API exposing functions and data+    structures suitable for usage in Haskell programs.+    .+    Example:+    .+    > 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+    .+library +  hs-source-dirs:      src+  build-depends:       base >=4.6 && < 5.0+                     , aeson+                     , bytestring+                     , containers+                     , either+                     , HsOpenSSL+                     , http-streams+                     , http-types+                     , io-streams+                     , mtl >= 2.1.3.1+                     , old-locale+                     , random >= 1.1+                     , text+                     , time+                     , transformers+                     , unordered-containers+              +  default-language:    Haskell2010+  other-modules:       +  exposed-modules:     +                       Pinboard+                       Pinboard.Api+                       Pinboard.ApiTypes +                       Pinboard.Client+                       Pinboard.Client.Internal+                       Pinboard.Client.Error+                       Pinboard.Client.Types+                       Pinboard.Client.Util+  ghc-options:         -Wall -rtsopts++source-repository head+  type:     git+  location: git://github.com/jonschoning/pinboard.git
+ src/Pinboard.hs view
@@ -0,0 +1,35 @@+-------------------------------------------+-- |+-- Module      : Pinboard+-- 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 (+      -- * Pinboard.Client+      -- | Executes the methods defined in Pinboard.Api+      module Pinboard.Client +      -- * Pinboard.Api+      -- | Provides Pinboard Api Methods+    , module Pinboard.Api+      -- * Pinboard.ApiTypes+      -- | Pinboard Data Structures returned by the Api+    , module Pinboard.ApiTypes+  ) where++import Pinboard.Client+import Pinboard.Api+import Pinboard.ApiTypes
+ src/Pinboard/Api.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedStrings #-}++-------------------------------------------+-- |+-- Module      : Pinboard.Api+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+--+-- < https://pinboard.in/api/ >++module Pinboard.Api+    ( +      -- ** Posts+      getPostsRecent,+      getPostsForDate,+      getPostsAll,+      getPostsDates,+      getPostsMRUTime,+      getSuggestedTags,+      addPost,+      deletePost,+      -- ** Tags+      getTags,+      renameTag,+      deleteTag,+      -- ** User+      getUserSecretRssKey,+      getUserApiToken,+      -- ** Notes+      getNoteList,+      getNote,+    ) where++import Prelude hiding (unwords)+import Pinboard.Client.Internal (pinboardJson)+import Pinboard.Client.Types    (Pinboard, PinboardRequest (..), Param (..))+import Pinboard.Client.Util     ((</>))+import Control.Applicative      ((<$>))+import Data.Text                (Text, unwords)+import Data.Time                (UTCTime)+import Data.Maybe               (catMaybes)+import Pinboard.ApiTypes        +                                            +-- POSTS ---------------------------------------------------------------------++-- | posts/recent : 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 path params)+  where +    path = "posts/recent" +    params = catMaybes [ Tag . unwords <$> tags+                       , Count <$> count ]++-- | posts/all : Returns all bookmarks in the user's account.+getPostsAll+  :: 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+  -> Pinboard Posts+getPostsAll tags start results fromdt todt meta = +  pinboardJson (PinboardRequest path params)+  where +    path = "posts/all" +    params = catMaybes [ Tag . unwords <$> tags+                       , Start <$> start+                       , Results <$> results+                       , FromDateTime <$> fromdt+                       , ToDateTime <$> todt+                       , Meta <$> 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.+getPostsForDate+  :: Maybe [Tag] -- ^ filter by up to three tags+  -> Maybe Date -- ^ return results bookmarked on this day+  -> Maybe Url -- ^ return bookmark for this URL+  -> Pinboard Posts+getPostsForDate tags date url = pinboardJson (PinboardRequest path params)+  where +    path = "posts/get" +    params = catMaybes [ Tag . unwords <$> tags+                       , Date <$> date+                       , Url <$> 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 (PinboardRequest path params)+  where +    path = "posts/dates" +    params = catMaybes [ Tag . unwords <$> tags ]+++-- | posts/update : Returns the most recent time a bookmark was added, updated or deleted.+getPostsMRUTime :: Pinboard UTCTime+getPostsMRUTime = fromUpdateTime <$> pinboardJson (PinboardRequest path params)+  where +    path = "posts/update" +    params = []++-- | 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.+getSuggestedTags+  :: Url+  -> Pinboard [Suggested]+getSuggestedTags url = pinboardJson (PinboardRequest path params)+  where +    path = "posts/suggest" +    params = [ Url url ]++-- | posts/delete : Delete an existing bookmark.+deletePost +  :: Url+  -> Pinboard ()+deletePost url = fromDoneResult <$> pinboardJson (PinboardRequest path params)+  where +    path = "posts/delete" +    params = [Url url]+++-- | posts/add : Add a bookmark+addPost+  :: 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+  -> Maybe DateTime -- ^ creation time for this bookmark. Defaults to current time. Datestamps more than 10 minutes ahead of server time will be reset to current server time+  -> Maybe Replace  -- ^ Replace any existing bookmark with this URL. Default is yes. If set to no, will throw an error if bookmark exists+  -> 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 (PinboardRequest path params)+  where +    path = "posts/add" +    params = catMaybes [ Just $ Url url+                       , Just $ Description descr+                       , Extended <$> ext+                       , Tags . unwords <$> tags+                       , DateTime <$> ctime+                       , Replace <$> repl+                       , Shared <$> shared+                       , ToRead <$> toread ]++-- TAGS ----------------------------------------------------------------------+++-- | tags/get : Returns a full list of the user's tags along with the number of +-- times they were used.+getTags :: Pinboard TagMap+getTags = fromJsonTagMap <$> pinboardJson (PinboardRequest path params)+  where +    path = "tags/get" +    params = []+++-- | tags/delete : Delete an existing tag.+deleteTag +  :: Tag +  -> Pinboard ()+deleteTag tag = fromDoneResult <$> pinboardJson (PinboardRequest path params)+  where +    path = "tags/delete" +    params = [Tag tag]+++-- | tags/rename : Rename an tag, or fold it in to an existing tag+renameTag +  :: Old -- ^ note: match is not case sensitive+  -> New -- ^ if empty, nothing will happen+  -> Pinboard ()+renameTag old new = fromDoneResult <$> pinboardJson (PinboardRequest path params)+  where +    path = "tags/rename" +    params = [Old old, New new]+++-- USER ----------------------------------------------------------------------++-- | user/secret : Returns the user's secret RSS key (for viewing private feeds)+getUserSecretRssKey :: Pinboard Text+getUserSecretRssKey = fromTextResult <$> pinboardJson (PinboardRequest path params)+  where +    path = "user/secret" +    params = []++-- | user/api_token : Returns the user's API token (for making API calls without a password)+getUserApiToken :: Pinboard Text+getUserApiToken = fromTextResult <$> pinboardJson (PinboardRequest path params)+  where +    path = "user/api_token" +    params = []+++-- NOTES ---------------------------------------------------------------------++-- | notes/list : Returns a list of the user's notes (note text detail is not included)+getNoteList :: Pinboard NoteList+getNoteList = pinboardJson (PinboardRequest path params)+  where +    path = "notes/list" +    params = []++-- | 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 (PinboardRequest path params)+  where +    path = "notes" </> noteid+    params = []+
+ src/Pinboard/ApiTypes.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Pinboard.Types+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+module Pinboard.ApiTypes where++import Prelude hiding      (words)+import Control.Applicative ((<$>), (<*>), (<|>))+import Data.Aeson          (FromJSON (parseJSON), Value (String, Object), ( .:))+import Data.Aeson.Types    (Parser)+import Data.HashMap.Strict (HashMap, member, toList)+import Data.Text           (Text, words, unpack)+import Data.Time           (UTCTime)+import Data.Time.Calendar  (Day)+import Data.Time.Format    (readTime)+import System.Locale       (defaultTimeLocale)+import qualified Data.HashMap.Strict as HM+++-- * Posts++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++data PostDates = PostDates {+      postDatesUser     :: Text+    , postDatesTag      :: Text+    , postDatesCount    :: [DateCount]+    } deriving (Show, Eq)++instance FromJSON PostDates where+   parseJSON (Object o) =+     PostDates <$> o .: "user"+               <*> o .: "tag"+               <*> (parseDates <$> o .: "dates")+     where+       parseDates :: Value -> [DateCount]+       parseDates (Object o')= do+          (dateStr, String countStr) <- toList o'+          return (read (unpack dateStr), read (unpack countStr))+       parseDates _ = []+   parseJSON _ = error "bad parse"++type DateCount = (Day, Int)+++-- * Notes++data NoteList = NoteList {+      noteListCount     :: Int+    , noteListItems     :: [NoteListItem]+    } deriving (Show, Eq)++instance FromJSON NoteList where+   parseJSON (Object o) =+       NoteList <$> o .: "count"+                <*> o .: "notes"+   parseJSON _ = error "bad parse"++data NoteListItem = NoteListItem {+      noteListItemId     :: Text+    , noteListItemHash   :: Text+    , noteListItemTitle  :: Text+    , noteListItemLength :: Int+    , noteListItemCreatedAt :: UTCTime+    , noteListItemUpdatedAt :: UTCTime+    } deriving (Show, Eq)++instance FromJSON NoteListItem where+   parseJSON (Object o) =+       NoteListItem <$> o .: "id"+                    <*> o .: "hash"+                    <*> o .: "title"+                    <*> (read <$> (o .: "length"))+                    <*> (readNoteTime <$> o .: "created_at")+                    <*> (readNoteTime <$> o .: "updated_at")+   parseJSON _ = error "bad parse"++++data Note = Note {+      noteId     :: Text+    , noteHash   :: Text+    , noteTitle  :: Text+    , noteText   :: Text+    , noteLength :: Int+    , noteCreatedAt :: UTCTime+    , noteUpdatedAt :: UTCTime+    } deriving (Show, Eq)++instance FromJSON Note where+   parseJSON (Object o) =+       Note <$> o .: "id"+            <*> o .: "hash"+            <*> o .: "title"+            <*> o .: "text"+            <*> o .: "length"+            <*> (readNoteTime <$> o .: "created_at")+            <*> (readNoteTime <$> o .: "updated_at")+   parseJSON _ = error "bad parse"++readNoteTime :: String -> UTCTime+readNoteTime = readTime defaultTimeLocale "%F %T"+++-- * Tags++type TagMap = HashMap Text Int++newtype JsonTagMap = ToJsonTagMap {fromJsonTagMap :: TagMap}+    deriving (Show, Eq)++instance FromJSON JsonTagMap where+  parseJSON = return . toTags+    where toTags (Object o) = ToJsonTagMap $ HM.map (\(String s)-> read (unpack s)) o+          toTags _ = error "bad parse"+++data Suggested = Popular [Text]+               | Recommended [Text]+    deriving (Show, Eq)++instance FromJSON Suggested where+   parseJSON (Object o)+     | member "popular" o = Popular <$> (o .: "popular")+     | member "recommended" o = Recommended  <$> (o .: "recommended")+     | otherwise = error "bad parse"  +   parseJSON _ = error "bad parse"+++-- * Scalars++newtype DoneResult = ToDoneResult {fromDoneResult :: ()}+    deriving (Show, Eq)++instance FromJSON DoneResult where+  parseJSON (Object o) = parseDone =<< (o .: "result" <|> o .: "result_code")+    where+      parseDone :: Text -> Parser DoneResult+      parseDone "done" = return $ ToDoneResult ()+      parseDone msg = ( fail . unpack ) msg+  parseJSON _ = error "bad parse"++newtype TextResult = ToTextResult {fromTextResult :: Text}+    deriving (Show, Eq)++instance FromJSON TextResult where+  parseJSON (Object o) = ToTextResult <$> (o .: "result")+  parseJSON _ = error "bad parse"++newtype UpdateTime = ToUpdateTime {fromUpdateTime :: UTCTime}+    deriving (Show, Eq)++instance FromJSON UpdateTime where+  parseJSON (Object o) = ToUpdateTime <$> (o .: "update_time")+  parseJSON _ = error "bad parse"++-- * Aliases++-- | as defined by RFC 3986. Allowed schemes are http, https, javascript, mailto, ftp and file. The Safari-specific feed scheme is allowed but will be treated as a synonym for http.+type Url = Text++-- | up to 255 characters long+type Description = Text ++-- | up to 65536 characters long. Any URLs will be auto-linkified when displayed.+type Extended = Text++-- | up to 255 characters. May not contain commas or whitespace.+type Tag = Text +type Old = Tag+type New = Tag++type Count = Int+type NumResults = Int+type StartOffset = Int++type Shared = Bool+type Replace = Bool+type ToRead = Bool++-- | UTC date in this format: 2010-12-11. Same range as datetime above+type Date = Day++-- | UTC timestamp in this format: 2010-12-11T19:48:02Z. Valid date range is Jan 1, 1 AD to January 1, 2100 (but see note below about future timestamps).+type DateTime = UTCTime+type FromDateTime = DateTime+type ToDateTime = DateTime++type Meta = Int++type NoteId = Text+
+ src/Pinboard/Client.hs view
@@ -0,0 +1,41 @@+-- |+-- Module      : Pinboard.Client+-- Copyright   : (c) Jon Schoning+-- 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+      -- | The PinboardConfig provides authentication via apiToken+    , PinboardConfig       (..)+      -- * Client Dependencies+    , module Pinboard.Client.Error+    , module Pinboard.Client.Types+    , module Pinboard.Client.Util+    ) where++import Pinboard.Client.Internal+import Pinboard.Client.Types+import Pinboard.Client.Error+import Pinboard.Client.Util+import Data.ByteString (ByteString)++fromApiToken :: ByteString -> PinboardConfig+fromApiToken token = PinboardConfig { debug = False, apiToken = token }
+ src/Pinboard/Client/Error.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Pinboard.Client.Error+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+module 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+        | TooManyRequests   -- ^ 429+        | 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
+ src/Pinboard/Client/Internal.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+------------------------------------------------------------------------------+-- | +-- Module      : Pinboard.Client.Internal+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+------------------------------------------------------------------------------++module 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 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)++--------------------------------------------------------------------------------++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 { 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 +      -> 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+  where+    buildReq url = buildRequest $ do+      http GET ("/v1/" <> url)+      setHeader "Connection" "Keep-Alive"  +      setHeader "User-Agent" "pinboard.hs/0.1"  ++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)+
+ src/Pinboard/Client/Types.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : Pinboard.Client.Types+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+module Pinboard.Client.Types+  ( Pinboard+  , PinboardRequest (..)+  , PinboardConfig  (..)+  , Param (..)+  , ParamsBS+  ) 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 Pinboard.Client.Error  (PinboardError (..))+import Data.Time.Calendar(Day)+import Data.Time.Clock(UTCTime)++------------------------------------------------------------------------------++type Pinboard = EitherT PinboardError (ReaderT (PinboardConfig, Connection) IO)++------------------------------------------------------------------------------++data PinboardRequest = PinboardRequest+    { requestPath    :: Text   -- ^ url path of PinboardRequest+    , requestParams :: [Param] -- ^ Query Parameters of PinboardRequest+    } deriving Show++------------------------------------------------------------------------------+data PinboardConfig = PinboardConfig+    { apiToken :: ByteString+    , debug :: Bool+    } deriving Show++------------------------------------------------------------------------------++type ParamsBS = [(ByteString, ByteString)]++------------------------------------------------------------------------------++data Param = Format Text+           | Tag Text+           | Tags Text+           | Old Text+           | New Text+           | Count Int+           | Start Int+           | Results Int+           | Url Text+           | Date Day+           | DateTime UTCTime+           | FromDateTime UTCTime+           | ToDateTime UTCTime+           | Replace Bool+           | Shared Bool+           | ToRead Bool+           | Description Text+           | Extended Text+           | Meta Int+      deriving (Show, Eq)+
+ src/Pinboard/Client/Util.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Pinboard.Client.Util+-- Copyright   : (c) Jon Schoning, 2015+-- Maintainer  : jonschoning@gmail.com+-- Stability   : experimental+-- Portability : POSIX+module Pinboard.Client.Util+    ( +      mkConfig+    , paramsToByteString+    , toText+    , toTextLower+    , (</>)+    , paramToName+    , paramToText+    , encodeParams+    ) where++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           Pinboard.Client.Types (PinboardConfig (..), Param (..), ParamsBS)+import Network.HTTP.Types(urlEncode)++------------------------------------------------------------------------------++mkConfig :: PinboardConfig+mkConfig = PinboardConfig { debug = False, apiToken = mempty }++------------------------------------------------------------------------------+-- | 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++-- | Retrieve and encode the optional parameters+encodeParams :: [Param] -> ParamsBS+encodeParams xs = do +  x <- xs +  let (k, v) = paramToText x+  return ( T.encodeUtf8 k+         , (urlEncode True . T.encodeUtf8 ) v+         )++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 (Count a)    = ("count", toText a)+paramToText (Start a)    = ("start", toText a)+paramToText (Results a)  = ("results", toText a)+paramToText (Url a)      = ("url", a)+paramToText (Date a)     = ("dt", toText a)+paramToText (DateTime a) = ("dt", toText a)+paramToText (FromDateTime a) = ("fromdt", toText a)+paramToText (ToDateTime a)   = ("todt", toText a)+paramToText (Replace a)  = ("replace", if a then "yes" else "no")+paramToText (Shared a)   = ("shared", if a then "yes" else "no")+paramToText (ToRead a)   = ("toread", if a then "yes" else "no")+paramToText (Description a) = ("description", a)+paramToText (Extended a) = ("extended", a)+paramToText (Meta a) = ("meta", toText a)++paramToName :: Param -> Text+paramToName = fst . paramToText+------------------------------------------------------------------------------+-- | Forward slash interspersion on `Monoid` and `IsString`+-- constrained types+(</>)+    :: (Monoid m, IsString m)+    => m+    -> m+    -> m+m1 </> m2 = m1 <> "/" <> m2