module Web.Pocket
( AuthRequest (..)
, makeAuthRequest
, AuthorizeRequest (..)
, makeAuthorizeRequest
, authRequest
, authorize
, add
, AddRequest (..)
, makeAddRequest
, AddResponse (..)
, send
, Action (..)
, SendRequest (..)
, SendResponse (..)
, get
, GetRequest (..)
, makeGetRequest
, GetResponse (..)
, run
)
where
import Data.Aeson
import Data.Proxy (Proxy (..))
import Network.HTTP.Client (Manager)
import Servant.API
import Servant.Client hiding (Client)
import Data.Text (Text)
import Control.Monad.IO.Class
type Api =
"v3"
:>
( "oauth"
:>
( "request"
:> ReqBody '[JSON] AuthRequest
:> Post '[JSON] AuthResponse
:<|>
"authorize"
:> ReqBody '[JSON] AuthorizeRequest
:> Post '[JSON] AuthorizeResponse
)
:<|>
"add"
:> ReqBody '[JSON] AddRequest
:> Post '[JSON] AddResponse
:<|>
"send"
:> ReqBody '[JSON] SendRequest
:> Post '[JSON] SendResponse
:<|>
"get"
:> ReqBody '[JSON] GetRequest
:> Post '[JSON] GetResponse
)
data AuthRequest =
AuthRequest
{ arConsumerKey :: Text
, arRedirectUri :: Text
, arState :: Maybe Text
}
instance ToJSON AuthRequest where
toJSON AuthRequest {..} =
object
[ "consumer_key" .= arConsumerKey
, "redirect_uri" .= arRedirectUri
, "state" .= arState
]
makeAuthRequest
:: Text
-> Text
-> AuthRequest
makeAuthRequest arConsumerKey arRedirectUri =
AuthRequest { arState = Nothing, .. }
data AuthResponse =
AuthResponse
{ code :: Text
, state :: Maybe Text
}
deriving (Show)
instance FromJSON AuthResponse where
parseJSON =
withObject "" $ do
\o -> do
code <- o .: "code"
state <- o .: "state"
return AuthResponse {..}
data AuthorizeRequest =
AuthorizeRequest
{ arrConsumerKey :: Text
, arrCode :: Text
}
instance ToJSON AuthorizeRequest where
toJSON AuthorizeRequest {..} =
object
[ "consumer_key" .= arrConsumerKey
, "code" .= arrCode
]
makeAuthorizeRequest
:: Text
-> Text
-> AuthorizeRequest
makeAuthorizeRequest arrConsumerKey arrCode =
AuthorizeRequest {..}
data AuthorizeResponse =
AuthorizeResponse
{ arespAccessToken :: Text
, arespUsername :: Text
, arespState :: Maybe Text
}
instance FromJSON AuthorizeResponse where
parseJSON =
withObject "" $
\o -> do
arespAccessToken <- o .: "access_token"
arespUsername <- o .: "username"
arespState <- o .: "state"
return AuthorizeResponse {..}
data AddRequest =
AddRequest
{ adrConsumerKey :: Text
, adrAccessToken :: Text
, adrUrl :: Text
, adrTitle :: Maybe Text
, adrTags :: Maybe Text
, adrTweetId :: Maybe Text
}
makeAddRequest
:: Text
-> Text
-> Text
-> AddRequest
makeAddRequest adrConsumerKey adrAccessToken adrUrl =
AddRequest
{ adrTitle = Nothing
, adrTags = Nothing
, adrTweetId = Nothing
, ..
}
instance ToJSON AddRequest where
toJSON AddRequest {..} =
object
[ "url" .= adrUrl
, "consumer_key" .= adrConsumerKey
, "access_token" .= adrAccessToken
]
data AddResponse =
AddResponse
{ addResponseItem :: Object
, addResponseStatus :: Integer
}
instance FromJSON AddResponse where
parseJSON =
withObject "" $
\o -> do
addResponseItem <- o .: "item"
addResponseStatus <- o .: "status"
return AddResponse {..}
data SendRequest =
SendRequest
{ srConsumerKey :: Text
, srAccessToken :: Text
, srActions :: [Action]
}
instance ToJSON SendRequest where
toJSON SendRequest {..} =
object
[ "consumer_key" .= srConsumerKey
, "access_token" .= srAccessToken
, "actions" .= srActions
]
data Action
= Add
{ itemId :: Text
, refId :: Maybe Text
, tags :: Text
, time :: Maybe Text
, title :: Maybe Text
, url :: Maybe Text
}
| Archive
{ itemId :: Text
, time :: Maybe Text
}
| Delete
{ itemId :: Text
, time :: Maybe Text
}
| Favorite
{ itemId :: Text
, time :: Maybe Text
}
| Readd
{ itemId :: Text
, time :: Maybe Text
}
| TagRename
{ oldTag :: Text
, newTag :: Text
, time :: Maybe Text
}
| TagsAdd
{ itemId :: Text
, tags :: Text
, time :: Maybe Text
}
| TagsClear
{ itemId :: Text
, time :: Maybe Text
}
| TagsRemove
{ itemId :: Text
, tags :: Text
, time :: Maybe Text
}
| TagsReplace
{ itemId :: Text
, tags :: Text
, time :: Maybe Text
}
| Unfavorite
{ itemId :: Text
, time :: Maybe Text
}
instance ToJSON Action where
toJSON Add {..} =
object
[ "action" .= ("add" :: Text)
, "ref_id" .= refId
, "tags" .= tags
, "time" .= time
, "title" .= title
, "url" .= url
]
toJSON Archive {..} =
object
[ "action" .= ("archive" :: Text)
, "item_id" .= itemId
, "time" .= time
]
toJSON Delete {..} =
object
[ "action" .= ("delete" :: Text)
, "item_id" .= itemId
, "time" .= time
]
toJSON Favorite {..} =
object
[ "action" .= ("favorite" :: Text)
, "item_id" .= itemId
, "time" .= time
]
toJSON Readd {..} =
object
[ "action" .= ("readd" :: Text)
, "item_id" .= itemId
, "time" .= time
]
toJSON TagRename {..} =
object
[ "action" .= ("tag_rename" :: Text)
, "old_tag" .= oldTag
, "new_tag" .= newTag
, "time" .= time
]
toJSON TagsAdd {..} =
object
[ "action" .= ("tags_add" :: Text)
, "item_id" .= itemId
, "tags" .= tags
, "time" .= time
]
toJSON TagsClear {..} =
object
[ "action" .= ("tags_clear" :: Text)
, "item_id" .= itemId
, "time" .= time
]
toJSON TagsRemove {..} =
object
[ "action" .= ("tags_remove" :: Text)
, "item_id" .= itemId
, "tags" .= tags
, "time" .= time
]
toJSON TagsReplace {..} =
object
[ "action" .= ("tags_replace" :: Text)
, "item_id" .= itemId
, "tags" .= tags
, "time" .= time
]
toJSON Unfavorite {..} =
object
[ "action" .= ("unfavorite" :: Text)
, "item_id" .= itemId
, "time" .= time
]
data SendResponse =
SendResponse
{ actionResults :: [Bool]
, status :: Integer
}
deriving (Show)
instance FromJSON SendResponse where
parseJSON =
withObject "" $
\o -> do
actionResults <- o .: "action_results"
status <- o .: "status"
return SendResponse {..}
data GetRequest =
GetRequest
{ consumerKey :: Text
, accessToken :: Text
, grState :: Maybe Text
, grFavorite :: Maybe Integer
, grTag :: Maybe Text
, grContentType :: Maybe Text
, grSort :: Maybe Text
, grDetailType :: Maybe Text
, grSearch :: Maybe Text
, grDomain :: Maybe Text
, grSince :: Maybe Text
, grCount :: Maybe Integer
, grOffset :: Maybe Integer
}
instance ToJSON GetRequest where
toJSON GetRequest {..} =
object
[ "consumer_key" .= consumerKey
, "access_token" .= accessToken
, "state" .= grState
, "favorite" .= grFavorite
, "tag" .= grTag
, "contentType" .= grContentType
, "sort" .= grSort
, "detailType" .= grDetailType
, "search" .= grSearch
, "domain" .= grDomain
, "since" .= grSince
, "count" .= grCount
, "offset" .= grOffset
]
makeGetRequest
:: Text
-> Text
-> GetRequest
makeGetRequest consumerKey accessToken =
GetRequest
consumerKey
accessToken
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
Nothing
data GetResponse =
GetResponse
{ list :: Object
, getResponseStatus :: Integer
}
deriving (Show)
instance FromJSON GetResponse where
parseJSON =
withObject "" $
\o -> do
list <- o .: "list"
getResponseStatus <- o .: "status"
return GetResponse {..}
authRequest
:: AuthRequest
-> ClientM AuthResponse
authorize
:: AuthorizeRequest
-> ClientM AuthorizeResponse
add
:: AddRequest
-> ClientM AddResponse
send
:: SendRequest
-> ClientM SendResponse
get
:: GetRequest
-> ClientM GetResponse
(authRequest :<|> authorize) :<|> add :<|> send :<|> get =
client (Proxy :: Proxy Api)
run
:: MonadIO m
=> Manager
-> ClientM a
-> m (Either ServantError a)
run manager =
let
baseUrl =
BaseUrl
Https
"getpocket.com"
443
""
in
liftIO . flip runClientM (ClientEnv manager baseUrl)