diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/pinboard.cabal b/pinboard.cabal new file mode 100644 --- /dev/null +++ b/pinboard.cabal @@ -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 diff --git a/src/Pinboard.hs b/src/Pinboard.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard.hs @@ -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 diff --git a/src/Pinboard/Api.hs b/src/Pinboard/Api.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Api.hs @@ -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 = [] + diff --git a/src/Pinboard/ApiTypes.hs b/src/Pinboard/ApiTypes.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/ApiTypes.hs @@ -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 + diff --git a/src/Pinboard/Client.hs b/src/Pinboard/Client.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Client.hs @@ -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 } diff --git a/src/Pinboard/Client/Error.hs b/src/Pinboard/Client/Error.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Client/Error.hs @@ -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 diff --git a/src/Pinboard/Client/Internal.hs b/src/Pinboard/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Client/Internal.hs @@ -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) + diff --git a/src/Pinboard/Client/Types.hs b/src/Pinboard/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Client/Types.hs @@ -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) + diff --git a/src/Pinboard/Client/Util.hs b/src/Pinboard/Client/Util.hs new file mode 100644 --- /dev/null +++ b/src/Pinboard/Client/Util.hs @@ -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