{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
module Follow.Digesters.Pocket.Auth
( requestTokenStep
, accessTokenStep
, jsonPostResponseBody
, jsonHeaders
, consumerKey
) where
import Control.Monad.Catch (Exception, MonadThrow, throwM)
import Data.Aeson (ToJSON, Value (..), object, (.=))
import qualified Data.HashMap.Strict as HS
import Data.Text (Text)
import qualified Data.Text as T (concat)
import GHC.Generics (Generic)
import HTTP.Follow
import Network.HTTP.Req (MonadHttp, Option, POST (..),
ReqBodyJson (..), Url, header, https,
jsonResponse, req, responseBody, (/:))
data PocketError
= PocketTokenNotFound
| PocketTokenDecodingError
deriving (Eq, Show, Exception)
consumerKey :: Text
consumerKey = "80296-6e350545b4382d839b3aa5df"
requestTokenStep :: (MonadThrow m, MonadHttp m) => m (Text, Text)
requestTokenStep = do
token <- getRequestToken
processTokenStep token $ \token ->
( token
, T.concat
[ "https://getpocket.com/auth/authorize?request_token="
, token
, "&redirect_uri="
, "https://getpocket.com"
])
accessTokenStep :: (MonadHttp m, MonadThrow m) => Text -> m Text
accessTokenStep rToken = do
token <- getAccessToken rToken
processTokenStep token id
processTokenStep ::
(MonadHttp m, MonadThrow m) => Maybe Value -> (Text -> a) -> m a
processTokenStep token f =
case token of
Nothing -> throwM PocketTokenNotFound
Just (String token) -> return $ f token
Just _ -> throwM PocketTokenDecodingError
jsonPostResponseBody ::
(ToJSON b, MonadHttp m, MonadThrow m)
=> Url scheme
-> b
-> Option scheme
-> m (HS.HashMap Text Value)
jsonPostResponseBody url body options =
responseBody <$> req POST url (ReqBodyJson body) jsonResponse options
jsonHeaders =
header "Content-Type" "application/json; charset=UTF-8" <>
header "X-Accept" "application/json"
getRequestToken :: (MonadHttp m, MonadThrow m) => m (Maybe Value)
getRequestToken =
parseValue "code" <$> jsonPostResponseBody url body jsonHeaders
where
url = https "getpocket.com" /: "v3" /: "oauth" /: "request"
body =
object
[ "consumer_key" .= String consumerKey
, "redirect_uri" .= String "https://getpocket.com"
]
getAccessToken :: (MonadHttp m, MonadThrow m) => Text -> m (Maybe Value)
getAccessToken rToken =
parseValue "access_token" <$> jsonPostResponseBody url body jsonHeaders
where
url = https "getpocket.com" /: "v3" /: "oauth" /: "authorize"
body = object ["consumer_key" .= String consumerKey, "code" .= rToken]
parseValue :: Text -> HS.HashMap Text Value -> Maybe Value
parseValue = HS.lookup