Add support for OAuth

package.yaml

@@ -46,6 +46,7 @@ library:
     - Reddit.Actions.Flair
     - Reddit.Actions.Message
     - Reddit.Actions.Moderation
+    - Reddit.Actions.OAuth
     - Reddit.Actions.Post
     - Reddit.Actions.Search
     - Reddit.Actions.Subreddit
@@ -63,6 +64,7 @@ library:
     - Reddit.Types.Message
     - Reddit.Types.Moderation
     - Reddit.Types.Options
+    - Reddit.Types.OAuth
     - Reddit.Types.Post
     - Reddit.Types.Reddit
     - Reddit.Types.SearchOptions
@@ -87,6 +89,7 @@ library:
     - transformers >=0.4
     - unordered-containers >=0.2.5
     - vector >=0.10
+    - base64-bytestring
 
 tests:
 

src/Reddit.hs

@@ -83,6 +83,13 @@ data LoginMethod = Anonymous -- ^ Don't login, instead use an anonymous account
                  | StoredDetails LoginDetails -- ^
                  --   Login using a stored set of credentials. Usually the best way to get
                  --   these is to do @'runRedditAnon' $ 'login' user pass@.
+                 | OAuth Client RefreshToken -- ^
+                 -- Use OAuth for authorization. The Authorization field should have a clientId and secret,
+                 -- which you get get from creating a new application in Reddit. Using this authorization,
+                 -- you have to acquire the necessary access tokens. Make sure to use permanent tokens, so
+                 -- that you don't have to frequently refresh them. Perhaps in the future, this library might
+                 -- offer a way to perform the steps to actually get the one-time code and use it to get the
+                 -- access token, but in the interest of time, this is not done here.
   deriving (Show)
 
 instance Default LoginMethod where def = Anonymous
@@ -110,21 +117,46 @@ runRedditWith opts reddit = liftM dropResume $ runResumeRedditWith opts reddit
 -- | Run a 'Reddit' or 'RedditT' action with custom settings. You probably won't need this function for
 --   most things, but it's handy if you want to persist a connection over multiple 'Reddit' sessions or
 --   use a custom user agent string.
-runResumeRedditWith :: MonadIO m => RedditOptions -> RedditT m a -> m (Either (APIError RedditError, Maybe (RedditT m a)) a)
+runResumeRedditWith ::
+     MonadIO m
+  => RedditOptions
+  -> RedditT m a
+  -> m (Either (APIError RedditError, Maybe (RedditT m a)) a)
 runResumeRedditWith (RedditOptions rl man lm ua) reddit = do
   when (isNothing ua) customUAWarning
-  manager <- case man of
-    Just m -> return m
-    Nothing -> liftIO $ newManager tlsManagerSettings
-  loginCreds <- case lm of
-    Anonymous -> return $ Right Nothing
-    StoredDetails ld -> return $ Right $ Just ld
-    Credentials user pass cp -> liftM (fmap Just) $ interpretIO (RedditState loginBaseURL rl manager [] Nothing) $ login user pass cp
+  manager <-
+    case man of
+      Just m -> return m
+      Nothing -> liftIO $ newManager tlsManagerSettings
+  let uaHeader =
+        ("User-Agent", fromMaybe ("reddit-haskell " <> versionString) ua)
+  (loginCreds, baseURL, extraHeaders) <-
+    case lm of
+      Anonymous -> return (Right Nothing, mainBaseURL, [])
+      StoredDetails ld -> return (Right $ Just ld, mainBaseURL, [])
+      Credentials user pass cp -> do
+        loginCreds <-
+          liftM (fmap Just) $
+          interpretIO (RedditState loginBaseURL rl manager [] Nothing) $
+          login user pass cp
+        return (loginCreds, mainBaseURL, [])
+      OAuth client refreshToken ->
+        -- TODO: refresh the token
+        interpretIO
+          (RedditState "https://www.reddit.com" rl manager [uaHeader] Nothing)
+          (accessTokenWithRefreshToken refreshToken client) >>= \case
+          Right AccessToken {accessToken = accessToken} ->
+            return
+              ( Right Nothing
+              , oauthBaseURL
+              , [("Authorization", "bearer " <> encodeUtf8 accessToken)])
+          Left (err, _) -> return (Left (err, Nothing), mainBaseURL, [])
   case loginCreds of
     Left (err, _) -> return $ Left (err, Just reddit)
     Right lds ->
       interpretIO
-        (RedditState mainBaseURL rl manager [("User-Agent", fromMaybe ("reddit-haskell " <> versionString) ua)] lds) reddit
+        (RedditState baseURL rl manager (uaHeader : extraHeaders) lds)
+        reddit
 
 interpretIO :: MonadIO m => RedditState -> RedditT m a -> m (Either (APIError RedditError, Maybe (RedditT m a)) a)
 interpretIO rstate (RedditT r) =

src/Reddit/Actions.hs

@@ -5,6 +5,7 @@ module Reddit.Actions
   , module Reddit.Actions.Flair
   , module Reddit.Actions.Message
   , module Reddit.Actions.Moderation
+  , module Reddit.Actions.OAuth
   , module Reddit.Actions.Post
   , module Reddit.Actions.Search
   , module Reddit.Actions.Subreddit
@@ -18,6 +19,7 @@ import Reddit.Actions.Comment
 import Reddit.Actions.Flair
 import Reddit.Actions.Message
 import Reddit.Actions.Moderation
+import Reddit.Actions.OAuth
 import Reddit.Actions.Post
 import Reddit.Actions.Search
 import Reddit.Actions.Subreddit

src/Reddit/Actions/OAuth.hs

@@ -0,0 +1,51 @@
+module Reddit.Actions.OAuth
+  ( accessTokenWithCode
+  , accessTokenWithRefreshToken
+  ) where
+
+import Data.ByteString.Base64 (encode)
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+import Network.API.Builder hiding (runRoute)
+import Network.HTTP.Types (Header)
+import Reddit.Types.OAuth
+import Reddit.Types.Reddit
+
+accessTokenWithCodeRoute :: AuthorizationCode -> Client -> Route
+accessTokenWithCodeRoute AuthorizationCode {authorizationCode = code} client =
+  Route
+    ["api", "v1", "access_token"]
+    [ ("grant_type" :: Text) =. ("authorization_code" :: Text)
+    , "code" =. code
+    , "redirect_uri" =. redirectUrl client
+    ]
+    "POST"
+
+accessTokenWithCode ::
+     Monad m
+  => AuthorizationCode
+  -> Client
+  -> RedditT m (AccessToken, RefreshToken)
+accessTokenWithCode code client =
+  withHeaders (authorizationHeader client :) $
+  receiveRoute $ accessTokenWithCodeRoute code client
+
+accessTokenWithRefreshTokenRoute :: RefreshToken -> Route
+accessTokenWithRefreshTokenRoute RefreshToken {refreshToken = token} =
+  Route
+    ["api", "v1", "access_token"]
+    [ ("grant_type" :: Text) =. ("refresh_token" :: Text)
+    , "refresh_token" =. token
+    ]
+    "POST"
+
+accessTokenWithRefreshToken ::
+     Monad m => RefreshToken -> Client -> RedditT m AccessToken
+accessTokenWithRefreshToken refreshToken client =
+  withHeaders (authorizationHeader client :) $
+  receiveRoute $ accessTokenWithRefreshTokenRoute refreshToken
+
+authorizationHeader :: Client -> Header
+authorizationHeader Script {clientId = clientId, secret = secret} =
+  ( "Authorization"
+  , "Basic " <> encode (Text.encodeUtf8 (clientId <> ":" <> secret)))

src/Reddit/Types.hs

@@ -22,7 +22,8 @@ module Reddit.Types
   , SubredditName(..)
   , Thing
   , User
-  , Username(..) ) where
+  , Username(..)
+  , module Reddit.Types.OAuth) where
 
 import Reddit.Types.Captcha (CaptchaID(..))
 import Reddit.Types.Comment (CommentID(..), Comment, CommentListing)
@@ -35,3 +36,4 @@ import Reddit.Types.Reddit (Reddit, RedditT, Modhash, LoginDetails)
 import Reddit.Types.Subreddit (SubredditName(..), Subreddit)
 import Reddit.Types.Thing (Thing)
 import Reddit.Types.User (Username(..), User)
+import Reddit.Types.OAuth

src/Reddit/Types/OAuth.hs

@@ -0,0 +1,104 @@
+module Reddit.Types.OAuth where
+
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import Data.Text as Text
+import Network.API.Builder
+
+data Client =
+  Script
+    { clientId :: Text
+    , secret :: Text
+    , redirectUrl :: Text
+    }
+  deriving (Show)
+
+newtype RefreshToken =
+  RefreshToken
+    { refreshToken :: Text
+    }
+  deriving (Show)
+
+instance Receivable RefreshToken where
+  receive = useFromJSON
+
+instance FromJSON RefreshToken where
+  parseJSON (Object o) = RefreshToken <$> (o .: "refresh_token")
+
+newtype AuthorizationCode =
+  AuthorizationCode
+    { authorizationCode :: Text
+    }
+  deriving (Show)
+
+data TokenType =
+  Bearer
+  deriving (Show, Enum)
+
+instance FromJSON TokenType where
+  parseJSON (String raw) =
+    case lookup raw $
+         Prelude.map (\elem -> (toLower $ pack $ show elem, elem)) [Bearer ..] of
+      Just result -> return result
+      Nothing -> fail $ "Unsupported token type in response: " ++ unpack raw
+
+data AccessToken =
+  AccessToken
+    { accessToken :: Text
+    , tokenType :: TokenType
+    , expiresIn :: Word
+    , scope :: [Scope]
+    }
+  deriving (Show)
+
+instance FromJSON AccessToken where
+  parseJSON (Object o) =
+    AccessToken <$> (o .: "access_token") <*> (o .: "token_type") <*>
+    (o .: "expires_in") <*>
+    (o .: "scope" >>= parseJSONScopeString)
+
+instance Receivable AccessToken where
+  receive = useFromJSON
+
+data Scope
+  = Identity
+  | Edit
+  | Flair
+  | History
+  | ModConfig
+  | ModFlair
+  | ModLog
+  | ModPosts
+  | ModWiki
+  | MySubreddits
+  | PrivateMessages
+  | Read
+  | Report
+  | Save
+  | Submit
+  | Subscribe
+  | Vote
+  | WikiEdit
+  | WikiRead
+  | All
+  deriving (Show, Enum)
+
+parseJSONScopeString :: Value -> Parser [Scope]
+parseJSONScopeString (String text) =
+  Prelude.mapM textToScope $
+  split
+    (\c ->
+       case c of
+         ' ' -> True
+         ',' -> True
+         _ -> False)
+    text
+  where
+    textToScope "*" = return All
+    textToScope raw =
+      case lookup raw $
+           Prelude.map
+             (\elem -> (toLower $ pack $ show elem, elem))
+             [Identity ..] of
+        Just result -> return result
+        Nothing -> fail $ "Unsupported token type in response: " ++ unpack raw

src/Reddit/Types/Reddit.hs

@@ -19,6 +19,7 @@ module Reddit.Types.Reddit
   , mkClientParamsHeader
   , mainBaseURL
   , loginBaseURL
+  , oauthBaseURL
   , addAPIType
   ) where
 
@@ -145,3 +146,6 @@ mainBaseURL = "https://api.reddit.com"
 
 loginBaseURL :: Text
 loginBaseURL = "https://ssl.reddit.com"
+
+oauthBaseURL :: Text
+oauthBaseURL = "https://oauth.reddit.com"