reddit 0.2.3.0 → 0.3.0.0

raw patch · 12 files changed

+241/−105 lines, 12 filesdep +directorydep ~aesondep ~api-builderdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: directory

Dependency ranges changed: aeson, api-builder, base, bytestring, data-default-class, free, http-client, http-client-tls, http-types, network, text, time, transformers, unordered-containers, vector

API changes (from Hackage documentation)

Files

• README.md +13/−6
• reddit.cabal +84/−58
• src/Reddit.hs +13/−6
• src/Reddit/Actions/User.hs +1/−1
• src/Reddit/Login.hs +3/−2
• src/Reddit/Types/Empty.hs +2/−2
• src/Reddit/Types/Error.hs +1/−0
• src/Reddit/Types/Listing.hs +6/−3
• src/Reddit/Types/Reddit.hs +18/−2
• test-anon/Reddit/Actions/CommentSpec.hs +2/−2
• test-io/ConfigLoad.hs +96/−21
• test-io/Reddit/Actions/CommentSpec.hs +2/−2

@@ -1,9 +1,10 @@-reddit for haskell [![Build Status](https://travis-ci.org/intolerable/reddit.svg?branch=master)](https://travis-ci.org/intolerable/reddit)+reddit for haskell [![CircleCI](https://circleci.com/gh/intolerable/reddit.svg?style=svg)](https://circleci.com/gh/intolerable/reddit) ---  A Haskell library for interacting with the [Reddit API](http://reddit.com/api). -### A couple of examples+A couple of examples+---  Let's get all the posts from the frontpage of Reddit and write a summary of each of them to the console: @@ -67,8 +68,14 @@  `cabal test test-io` -The `test` test suite will run the tests that don't rely on doing any IO, but the `test-io` should be used too to ensure that IO functions do what they're supposed to do. If you want to run the IO suite, add a file `test.cfg` to the `reddit/` directory, containing (one field per line):+The `test` test suite will run the tests that don't rely on doing any IO, but the `test-io` should be used too to ensure that IO functions do what they're supposed to do. If you want to run the IO suite, add a file `test_config.yaml` to the `reddit/` directory, like this: -- a reddit username-- a reddit password-- a subreddit name (the user should be a moderator for the subredit)+```+username: my_reddit_username+password: my_reddit_password+subreddit: test_subreddit # A subreddit that the user has moderator access to+client_id: MY_CLIENT_ID # Your reddit app client ID+client_secret: MY_CLIENT_SECRET # Your reddit app client secret+```++Your app client and secret can be found in [your reddit preferences](https://reddit.com/prefs/apps/)

@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.20.0.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: 6d0965ca6f31dbbd95562eb8028178c6142b8dc8d08ddaf93ef114725e63d3fd  name:           reddit-version:        0.2.3.0+version:        0.3.0.0 synopsis:       Library for interfacing with Reddit's API description:    A library for interfacing with Reddit''s API in Haskell. Handles logins, rate-limiting and converting to and from JSON responses. Supports most user-facing Reddit API functions, as well as some moderator endpoints. Check out the readme at <https://github.com/intolerable/reddit>.                 Contributions are welcome.@@ -18,39 +18,17 @@ license:        BSD2 license-file:   LICENSE build-type:     Simple-cabal-version:  >= 1.10- extra-source-files:     README.md     test/data/aboutMe_example.json-    test/data/getUserComments_example.json     test/data/getUserInfo_example.json+    test/data/getUserComments_example.json  source-repository head   type: git   location: https://github.com/intolerable/reddit  library-  hs-source-dirs:-      src-  default-extensions: FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase OverloadedStrings-  ghc-options: -Wall -fno-warn-dodgy-imports-  build-depends:-      aeson >=0.9 && <1.3-    , api-builder >=0.10 && <0.16-    , base >=4.6 && <4.12-    , bytestring ==0.10.*-    , data-default-class >=0.0.1 && <0.2-    , free >=4 && <6-    , http-client >=0.4.30 && <0.6-    , http-client-tls >=0.2 && <0.4-    , http-types >=0.8 && <0.13-    , network ==2.6.*-    , text ==1.*-    , time >=1.5 && <1.9-    , transformers >=0.4 && <0.6-    , unordered-containers >=0.2.5 && <0.3-    , vector >=0.10 && <0.13   exposed-modules:       Reddit       Reddit.Actions@@ -102,15 +80,55 @@       Reddit.Types.Empty       Reddit.Utilities       Paths_reddit+  hs-source-dirs:+      src+  default-extensions:+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      OverloadedStrings+      OverloadedStrings+  ghc-options: -Wall -Wcompat -fno-warn-dodgy-imports+  build-depends:+      aeson >=2+    , api-builder >=0.10+    , base >=4.6+    , bytestring >=0.10.8+    , data-default-class >=0.0.1+    , free >=4+    , http-client >=0.4.30+    , http-client-tls >=0.2+    , http-types >=0.8+    , network >=2.6+    , text >=1.2+    , time >=1.5+    , transformers >=0.4+    , unordered-containers >=0.2.5+    , vector >=0.10   default-language: Haskell2010  test-suite test   type: exitcode-stdio-1.0   main-is: Spec.hs+  other-modules:+      Reddit.Types.CommentSpec+      Reddit.Types.ListingSpec+      Reddit.Types.PostSpec+      Reddit.Types.SubredditSpec+      Reddit.Types.UserSpec+      Reddit.Types.WikiSpec+      Paths_reddit   hs-source-dirs:       test-  default-extensions: FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase OverloadedStrings-  ghc-options: -Wall+  default-extensions:+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      OverloadedStrings+      OverloadedStrings+  ghc-options: -Wall -Wcompat   build-depends:       Cabal >=1.16.0     , aeson@@ -122,24 +140,34 @@     , text     , time     , transformers-  other-modules:-      Reddit.Types.CommentSpec-      Reddit.Types.ListingSpec-      Reddit.Types.PostSpec-      Reddit.Types.SubredditSpec-      Reddit.Types.UserSpec-      Reddit.Types.WikiSpec-      Paths_reddit   default-language: Haskell2010  test-suite test-anon   type: exitcode-stdio-1.0   main-is: Spec.hs+  other-modules:+      Reddit.Actions.CaptchaSpec+      Reddit.Actions.CommentSpec+      Reddit.Actions.FlairSpec+      Reddit.Actions.MessageSpec+      Reddit.Actions.PostSpec+      Reddit.Actions.SearchSpec+      Reddit.Actions.SubredditSpec+      Reddit.Actions.UserSpec+      Utils+      Paths_reddit   hs-source-dirs:       test-anon       test-utils-  default-extensions: FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase OverloadedStrings Rank2Types-  ghc-options: -Wall+  default-extensions:+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      OverloadedStrings+      OverloadedStrings+      Rank2Types+  ghc-options: -Wall -Wcompat   build-depends:       Cabal >=1.16.0     , api-builder@@ -150,33 +178,42 @@     , text     , time     , transformers+  default-language: Haskell2010++test-suite test-io+  type: exitcode-stdio-1.0+  main-is: Spec.hs   other-modules:+      ConfigLoad       Reddit.Actions.CaptchaSpec       Reddit.Actions.CommentSpec       Reddit.Actions.FlairSpec       Reddit.Actions.MessageSpec       Reddit.Actions.PostSpec-      Reddit.Actions.SearchSpec       Reddit.Actions.SubredditSpec       Reddit.Actions.UserSpec       Utils       Paths_reddit-  default-language: Haskell2010--test-suite test-io-  type: exitcode-stdio-1.0-  main-is: Spec.hs   hs-source-dirs:       test-io       test-utils-  default-extensions: FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase OverloadedStrings Rank2Types-  ghc-options: -Wall+  default-extensions:+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      OverloadedStrings+      OverloadedStrings+      Rank2Types+      RecordWildCards+  ghc-options: -Wall -Wcompat   build-depends:       Cabal >=1.16.0     , api-builder     , base ==4.*     , bytestring     , data-default-class+    , directory     , hspec     , http-client     , http-client-tls@@ -185,15 +222,4 @@     , time     , transformers     , yaml-  other-modules:-      ConfigLoad-      Reddit.Actions.CaptchaSpec-      Reddit.Actions.CommentSpec-      Reddit.Actions.FlairSpec-      Reddit.Actions.MessageSpec-      Reddit.Actions.PostSpec-      Reddit.Actions.SubredditSpec-      Reddit.Actions.UserSpec-      Utils-      Paths_reddit   default-language: Haskell2010

@@ -33,7 +33,7 @@ import Data.ByteString.Char8 (ByteString) import Data.Default.Class import Data.Maybe (fromMaybe, isNothing)-import Data.Monoid+import Data.Semigroup ((<>)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Data.Version@@ -41,6 +41,7 @@ import Network.HTTP.Client import Network.HTTP.Client.TLS import Network.HTTP.Types+import Prelude hiding ((<>)) import qualified Data.ByteString.Char8 as BS  import qualified Paths_reddit@@ -79,7 +80,7 @@ -- | Should we log in to Reddit? If so, should we use a stored set of credentials --   or get a new fresh set? data LoginMethod = Anonymous -- ^ Don't login, instead use an anonymous account-                 | Credentials Text Text -- ^ Login using the specified username and password+                 | Credentials Text Text ClientParams-- ^ Login using the specified username and password                  | StoredDetails LoginDetails -- ^                  --   Login using a stored set of credentials. Usually the best way to get                  --   these is to do @'runRedditAnon' $ 'login' user pass@.@@ -91,8 +92,8 @@ --   for 'RedditOptions': rate limiting enabled, default manager, login via username and password, and --   the default user-agent. You should change the user agent if you're making anything more complex than --   a basic script, since Reddit's API policy says that you should have a uniquely identifiable user agent.-runReddit :: MonadIO m => Text -> Text -> RedditT m a -> m (Either (APIError RedditError) a)-runReddit user pass = runRedditWith def { loginMethod = Credentials user pass }+runReddit :: MonadIO m => Text -> Text -> ClientParams -> RedditT m a -> m (Either (APIError RedditError) a)+runReddit user pass cp = runRedditWith def { loginMethod = Credentials user pass cp }  -- | Run a 'Reddit' action (or a 'RedditT' transformer action). This uses the default logged-out settings, so --   you won't be able to do anything that requires authentication (like checking messages or making a post).@@ -119,7 +120,7 @@   loginCreds <- case lm of     Anonymous -> return $ Right Nothing     StoredDetails ld -> return $ Right $ Just ld-    Credentials user pass -> liftM (fmap Just) $ interpretIO (RedditState loginBaseURL rl manager [] Nothing) $ login user pass+    Credentials user pass cp -> liftM (fmap Just) $ interpretIO (RedditState loginBaseURL rl manager [] Nothing) $ login user pass cp   case loginCreds of     Left (err, _) -> return $ Left (err, Just reddit)     Right lds ->@@ -136,6 +137,12 @@           return $ Left (err, Just $ resume >>= RedditT . n)         Left (err, Nothing) -> return $ Left (err, Nothing)         Right res -> interpretIO rstate $ RedditT $ n res+    Free (WithHeaders hf x n) -> do+      interpretIO (rstate { extraHeaders = hf (extraHeaders rstate)}) x >>= \case+        Left (err, Just resume) ->+          return $ Left (err, Just $ resume >>= RedditT . n)+        Left (err, Nothing) -> return $ Left (err, Nothing)+        Right res -> interpretIO rstate $ RedditT $ n res     Free (FailWith x) -> return $ Left (x, Nothing)     Free (Nest x n) ->       interpretIO rstate $ RedditT $ wrap $ NestResuming x (n . dropResume)@@ -179,7 +186,7 @@   RedditState { currentBaseURL :: Text               , rateLimit :: Bool               , connMgr :: Manager-              , _extraHeaders :: [Header]+              , extraHeaders :: [Header]               , _creds :: Maybe LoginDetails }  customUAWarning :: MonadIO m => m ()

@@ -85,5 +85,5 @@ setUserFlair :: Monad m => SubredditName -> Username -> Text -> Text -> RedditT m () setUserFlair r u txt cls =   if Text.length txt > 64-    then fail "Flair text too long!"+    then failWith $ APIError FlairTooLong     else nothing $ runRoute $ Route.setUserFlair r u txt cls

@@ -13,12 +13,13 @@                              , "passwd" =. pass ]                              "POST" -getLoginDetails :: Monad m => Text -> Text -> RedditT m LoginDetails-getLoginDetails user pass = receiveRoute $ loginRoute user pass+getLoginDetails :: Monad m => Text -> Text -> ClientParams -> RedditT m LoginDetails+getLoginDetails user pass cp = withHeaders (mkClientParamsHeader cp :) $ receiveRoute $ loginRoute user pass  -- | Make a login request with the given username and password. login :: Monad m       => Text -- ^ Username to login with       -> Text -- ^ Password to login with+      -> ClientParams       -> RedditT m LoginDetails login = getLoginDetails

@@ -5,7 +5,7 @@ import Data.Aeson.Types import Data.Monoid import Prelude-import qualified Data.HashMap.Strict as Hash+import qualified Data.Aeson.KeyMap as KeyMap  -- | More specific @void@ for forcing a @Empty@ @FromJSON@ instance nothing :: Monad m => m Empty -> m ()@@ -16,7 +16,7 @@  instance FromJSON Empty where   parseJSON (Object o) =-    if Hash.null o+    if KeyMap.null o       then return Empty       else do         errs <- (o .: "json") >>= (.: "errors") :: Parser [Value]

@@ -25,6 +25,7 @@                  | LinkDeleted                  | BadSubredditName                  | TooManyRequests+                 | FlairTooLong                  deriving (Show, Eq)  instance FromJSON RedditError where

@@ -5,7 +5,7 @@ import Control.Applicative import Data.Aeson import Data.Traversable-import Data.Monoid+import Data.Semigroup import Network.API.Builder.Query import Prelude @@ -32,9 +32,12 @@ instance Functor (Listing t) where   fmap f (Listing b a x) = Listing b a (fmap f x) -instance Ord t => Monoid (Listing t a) where-  mappend (Listing a b cs) (Listing d e fs) =+instance Ord t => Semigroup (Listing t a) where+  Listing a b cs <> Listing d e fs =     Listing (max a d) (min b e) (cs <> fs)++instance Ord t => Monoid (Listing t a) where+  mappend = (<>)   mempty = Listing Nothing Nothing []  instance (FromJSON t, FromJSON a) => FromJSON (Listing t a) where

@@ -7,6 +7,7 @@   , nest   , failWith   , withBaseURL+  , withHeaders   , Modhash(..)   , LoginDetails(..)   , POSTWrapped(..)@@ -14,9 +15,12 @@   , RateLimits(RateLimits, should, info)   , RateLimitInfo(..)   , headersToRateLimitInfo+  , ClientParams(..)+  , mkClientParamsHeader   , mainBaseURL   , loginBaseURL-  , addAPIType ) where+  , addAPIType+  ) where  import Reddit.Types.Error @@ -35,6 +39,7 @@ import Prelude import Text.Read (readMaybe) import qualified Data.ByteString.Char8 as BS+import qualified Data.Text.Encoding as Text  type Reddit a = RedditT IO a @@ -45,6 +50,7 @@   ReceiveRoute :: Receivable b => Route -> (b -> a) -> RedditF m a   RunRoute :: FromJSON b => Route -> (b -> a) -> RedditF m a   WithBaseURL :: Text -> RedditT m b -> (b -> a) -> RedditF m a+  WithHeaders :: ([Header] -> [Header]) -> RedditT m b -> (b -> a) -> RedditF m a  instance Functor (RedditF m) where   fmap _ (FailWith x) = FailWith x@@ -53,6 +59,7 @@   fmap f (ReceiveRoute r x) = ReceiveRoute r (fmap f x)   fmap f (RunRoute r x) = RunRoute r (fmap f x)   fmap f (WithBaseURL u a x) = WithBaseURL u a (fmap f x)+  fmap f (WithHeaders hf a x) = WithHeaders hf a (fmap f x)  newtype RedditT m a = RedditT (FreeT (RedditF m) m a)   deriving (Functor, Applicative, Monad)@@ -75,6 +82,9 @@ withBaseURL :: Monad m => Text -> RedditT m a -> RedditT m a withBaseURL u f = RedditT $ liftF $ WithBaseURL u f id +withHeaders :: Monad m => ([Header] -> [Header]) -> RedditT m a -> RedditT m a+withHeaders u f = RedditT $ liftF $ WithHeaders u f id+ failWith :: Monad m => APIError RedditError -> RedditT m a failWith = RedditT . liftF . FailWith @@ -87,7 +97,7 @@   parseJSON _ = mempty  data LoginDetails = LoginDetails Modhash CookieJar-  deriving (Show, Eq)+  deriving (Show)  instance Receivable LoginDetails where   receive x = do@@ -120,6 +130,12 @@         rlResetTime' = fmap (\s -> addUTCTime (fromIntegral s) now) rlResetTime         extract s = lookup s hs >>= readMaybe . BS.unpack         trimap f (a, b, c) = (f a, f b, f c)++data ClientParams = ClientParams Text Text+  deriving (Show, Read, Eq, Ord)++mkClientParamsHeader :: ClientParams -> (HeaderName, BS.ByteString)+mkClientParamsHeader (ClientParams i s) = ("Authorization", Text.encodeUtf8 $ i <> ":" <> s)  addAPIType :: Route -> Route addAPIType (Route fs ps m) = Route fs ("api_type" =. ("json" :: Text) : ps) m

@@ -29,11 +29,11 @@       Left _ -> expectationFailure "something failed"    it "should fail if we try to get an invalid comment" $ do-    res <- runAnon $ getCommentInfo (CommentID "garbage")+    res <- runAnon $ getCommentInfo (CommentID "!!!!!!!")     res `shouldSatisfy` isLeft    it "shouldn't be able to get a list of comment IDs where some are invalid" $ do-    res <- runAnon $ getCommentsInfo [CommentID "c60o0iw", CommentID "garbage"]+    res <- runAnon $ getCommentsInfo [CommentID "c60o0iw", CommentID "!!!!!!!"]     res `shouldSatisfy` isLeft    it "should be able to get mass comment IDs" $ do

@@ -1,49 +1,124 @@ module ConfigLoad where +import Control.Applicative+import Data.List+import Data.Semigroup (Semigroup(..)) import Data.Text (Text) import Data.Yaml import Network.HTTP.Client import Network.HTTP.Client.TLS import Reddit import Reddit.Login+import System.Directory+import System.Environment import System.Exit import Utils+import qualified Data.Text as Text  newtype RunReddit = RunReddit   { run :: forall a. Reddit a -> IO (Either (APIError RedditError) a) } -newtype TestConfig = TestConfig (Maybe Config)+data Opts =+  Opts { optsUsername :: Maybe Text+       , optsPassword :: Maybe Text+       , optsSubreddit :: Maybe Text+       , optsClientId :: Maybe Text+       , optsClientSecret :: Maybe Text+       }   deriving (Show, Eq, Ord) -instance FromJSON TestConfig where-  parseJSON = withObject "TestConfig" $ \ o ->-    TestConfig <$> o .:? "config"+instance Semigroup Opts where+  Opts u1 p1 s1 ci1 cs1 <> Opts u2 p2 s2 ci2 cs2 =+    Opts (u2 <|> u1)+         (p2 <|> p1)+         (s2 <|> s1)+         (ci2 <|> ci1)+         (cs2 <|> cs1) +instance Monoid Opts where+  mappend = (<>)+  mempty = Opts mempty mempty mempty mempty mempty++instance FromJSON Opts where+  parseJSON = withObject "Opts" $ \ o ->+    Opts <$> o .:? "username"+         <*> o .:? "password"+         <*> o .:? "subreddit"+         <*> o .:? "client_id"+         <*> o .:? "client_secret"++getEnvOpts :: IO Opts+getEnvOpts =+  Opts <$> lookupEnv' "REDDIT_USERNAME"+       <*> lookupEnv' "REDDIT_PASSWORD"+       <*> lookupEnv' "REDDIT_SUBREDDIT"+       <*> lookupEnv' "REDDIT_CLIENT_ID"+       <*> lookupEnv' "REDDIT_CLIENT_SECRET"+    where+      lookupEnv' x = fmap (fmap Text.pack) (lookupEnv x)+ data Config =-  Config { tcUsername :: Text-         , tcPassword :: Text-         , tcSubreddit :: Text+  Config { cfgUsername :: Text+         , cfgPassword :: Text+         , cfgSubreddit :: Text+         , cfgClientId :: Text+         , cfgClientSecret :: Text          }   deriving (Show, Eq, Ord) -instance FromJSON Config where-  parseJSON = withObject "Config" $ \ o ->-    Config <$> o .: "username"-           <*> o .: "password"-           <*> o .: "subreddit"+newtype Validation e a = Validation (Either e a)+  deriving (Show, Read, Eq, Ord, Functor) +instance Semigroup e => Applicative (Validation e) where+  pure = Validation . Right++  Validation a <*> Validation b =+    Validation $ case (a, b) of+      (Left ea, Left eb) -> Left (ea <> eb)+      (Left ea, Right _) -> Left ea+      (Right _, Left eb) -> Left eb+      (Right f, Right x) -> Right (f x)++optionsToConfig :: Opts -> Validation [String] Config+optionsToConfig Opts{..} =+  Config <$> get "optsUsername was missing" optsUsername+         <*> get "optsPassword was missing" optsPassword+         <*> get "optsSubreddit was missing" optsSubreddit+         <*> get "optsClientId was missing" optsClientId+         <*> get "optsClientSecret was missing" optsClientSecret+    where+      get :: String -> Maybe a -> Validation [String] a+      get _ (Just x) = pure x+      get msg Nothing = Validation (Left [msg])+ loadConfig :: IO (RunReddit, Username, SubredditName) loadConfig = do-  decodeFileEither "test_config.yaml" >>= \case-    Left err -> do-      print err-      exitFailure-    Right (TestConfig Nothing) ->-      putStrLn "Warning: missing config section, skipping authorized tests"-      exitSuccess-    Right (TestConfig (Just (Config user pass sub))) -> do+  jsonOpts <- do+    let configFilePath = "test_config.yaml"+    doesFileExist configFilePath >>= \case+      False -> do+        putStrLn "Warning: missing config, skipping authorized tests"+        pure mempty+      True ->+        decodeFileEither "test_config.yaml" >>= \case+          Left err -> do+            print err+            exitFailure+          Right opts -> pure opts+  envOpts <- getEnvOpts++  case optionsToConfig (jsonOpts <> envOpts) of+    Validation (Left errs) ->+      error $+        intercalate "\n" $+          [ "Options were missing, got:"+          , "  " <> show (jsonOpts <> envOpts)+          , "Errors:"+          , intercalate "\n" $ map ("  " <>) errs+          ]+    Validation (Right (Config user pass sub ci cs)) -> do       manager <- newManager tlsManagerSettings-      res <- runAnon $ login user pass+      res <- runAnon $ login user pass (ClientParams ci cs)       case res of         Left err -> do           print err

@@ -32,11 +32,11 @@       Left _ -> expectationFailure "something failed"    it "should fail if we try to get an invalid comment" $ do-    res <- run reddit $ getCommentInfo (CommentID "garbage")+    res <- run reddit $ getCommentInfo (CommentID "!!!!!!!")     res `shouldSatisfy` isLeft    it "shouldn't be able to get a list of comment IDs where some are invalid" $ do-    res <- run reddit $ getCommentsInfo [CommentID "c60o0iw", CommentID "garbage"]+    res <- run reddit $ getCommentsInfo [CommentID "c60o0iw", CommentID "!!!!!!!"]     res `shouldSatisfy` isLeft    it "should be able to get mass comment IDs" $ do