module Reddit
( runReddit
, runRedditAnon
, runRedditWith
, runResumeRedditWith
, interpretIO
, RedditOptions(..)
, defaultRedditOptions
, LoginMethod(..)
, APIError(..)
, module Reddit.Actions
, module Reddit.Types
, module Reddit.Types.Error
, module Reddit.Types.Reddit ) where
import Reddit.Actions
import Reddit.Login
import Reddit.Types.Error
import Reddit.Types
import Reddit.Types.Reddit hiding (info, should)
import Control.Concurrent
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Free
import Data.ByteString.Char8 (ByteString)
import Data.Default.Class
import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Version
import Network.API.Builder as API
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import qualified Data.ByteString.Char8 as BS
import qualified Paths_reddit
versionString :: ByteString
versionString =
case Paths_reddit.version of
Version xs _ -> BS.intercalate "." $ map (BS.pack . show) xs
data RedditOptions =
RedditOptions { rateLimitingEnabled :: Bool
, connectionManager :: Maybe Manager
, loginMethod :: LoginMethod
, customUserAgent :: Maybe ByteString }
instance Default RedditOptions where
def = RedditOptions True Nothing Anonymous Nothing
defaultRedditOptions :: RedditOptions
defaultRedditOptions = def
data LoginMethod = Anonymous
| Credentials Text Text
| StoredDetails LoginDetails
deriving (Show)
instance Default LoginMethod where def = Anonymous
runReddit :: MonadIO m => Text -> Text -> RedditT m a -> m (Either (APIError RedditError) a)
runReddit user pass = runRedditWith def { loginMethod = Credentials user pass }
runRedditAnon :: MonadIO m => RedditT m a -> m (Either (APIError RedditError) a)
runRedditAnon = runRedditWith def
runRedditWith :: MonadIO m => RedditOptions -> RedditT m a -> m (Either (APIError RedditError) a)
runRedditWith opts reddit = liftM dropResume $ runResumeRedditWith opts reddit
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 -> liftM (fmap Just) $ interpretIO (RedditState loginBaseURL rl manager [] Nothing) $ login user pass
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
interpretIO :: MonadIO m => RedditState -> RedditT m a -> m (Either (APIError RedditError, Maybe (RedditT m a)) a)
interpretIO rstate (RedditT r) =
runFreeT r >>= \case
Pure x -> return $ Right x
Free (WithBaseURL u x n) ->
interpretIO (rstate { currentBaseURL = u }) 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)
Free (NestResuming x n) -> do
res <- interpretIO rstate x
interpretIO rstate $ RedditT $ n res
Free (RunRoute route n) ->
interpretIO rstate $ RedditT $ wrap $ ReceiveRoute route (n . unwrapJSON)
Free (ReceiveRoute route n) ->
handleReceive route rstate >>= \case
Left err@(APIError (RateLimitError secs _)) ->
if rateLimit rstate
then do
liftIO $ threadDelay $ fromInteger secs * 1000 * 1000
interpretIO rstate $ RedditT $ wrap $ ReceiveRoute route n
else return $ Left (err, Just $ RedditT $ wrap $ ReceiveRoute route n)
Left err -> return $ Left (err, Just $ RedditT $ wrap $ ReceiveRoute route n)
Right x -> interpretIO rstate $ RedditT $ n x
dropResume :: Either (APIError RedditError, Maybe (RedditT m a)) a -> Either (APIError RedditError) a
dropResume (Left (x, _)) = Left x
dropResume (Right x) = Right x
handleReceive :: (MonadIO m, Receivable a) => Route -> RedditState -> m (Either (APIError RedditError) a)
handleReceive r rstate = do
(res, _, _) <- runAPI (builderFromState rstate) (connMgr rstate) () $
API.runRoute r
return res
builderFromState :: RedditState -> Builder
builderFromState (RedditState burl _ _ hdrs (Just (LoginDetails (Modhash mh) cj))) =
Builder "Reddit" burl addAPIType $
\req -> addHeaders (("X-Modhash", encodeUtf8 mh):hdrs) req { cookieJar = Just cj }
builderFromState (RedditState burl _ _ hdrs Nothing) =
Builder "Reddit" burl addAPIType (addHeaders hdrs)
addHeaders :: [Header] -> Request -> Request
addHeaders xs req = req { requestHeaders = requestHeaders req ++ xs }
data RedditState =
RedditState { currentBaseURL :: Text
, rateLimit :: Bool
, connMgr :: Manager
, _extraHeaders :: [Header]
, _creds :: Maybe LoginDetails }
customUAWarning :: MonadIO m => m ()
customUAWarning = liftIO $ do
putStrLn "WARNING: You haven't specified a custom Reddit user agent!"
putStrLn " This is against Reddit's terms of service, and you should probably fix it."