diff --git a/ghcjs-example/Main.hs b/ghcjs-example/Main.hs new file mode 100644 index 0000000..beb203e --- /dev/null +++ b/ghcjs-example/Main.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | + +module Main where + +import Reddit +import Reddit.Types.Post +import Reddit.Types.User + +import Control.Monad +import Control.Monad.IO.Class +import Data.List +import Data.Monoid +import Data.Ord +import qualified Data.Text as Text +import qualified Data.Text.IO as Text + +main :: IO () +main = do + _ <- runRedditAnon $ do + Listing _ _ posts <- getPosts + forM_ posts $ \post -> do + liftIO $ putStrLn $ + "[" <> show (score post) <> "] " <> + (show $ title post) <> " (" <> show (subreddit post) <> ")" + + infos <- mapM (getUserInfo . Username) usersToCheck + liftIO $ print $ maximumBy (comparing linkKarma) infos + return () + + +usersToCheck :: [Text.Text] +usersToCheck = ["nikita-volkov", "simonmar", "bos", "roche"] + +tshow :: Show a => a -> Text.Text +tshow = Text.pack . show diff --git a/reddit.cabal b/reddit.cabal index 9b9d061..50d495a 100644 --- a/reddit.cabal +++ b/reddit.cabal @@ -87,6 +87,7 @@ library GeneralizedNewtypeDeriving LambdaCase OverloadedStrings + CPP default-language: Haskell2010 hs-source-dirs: src/ build-depends: @@ -96,8 +97,6 @@ library bytestring == 0.10.*, data-default-class == 0.0.1, free >= 4 && < 5, - http-client >= 0.4.11 && < 0.4.21, - http-client-tls >= 0.2 && < 0.2.3, http-types == 0.8.*, network == 2.6.*, text == 1.*, @@ -105,6 +104,14 @@ library transformers == 0.4.*, unordered-containers == 0.2.5.*, vector >= 0.10 && < 0.12 + if impl(ghcjs) + build-depends: + ghcjs-base + if !impl(ghcjs) + build-depends: + http-client >= 0.4.11 && < 0.4.21, + http-client-tls >= 0.2 && < 0.2.3 + ghc-options: -Wall test-suite test @@ -166,3 +173,20 @@ test-suite test-anon time, transformers ghc-options: -Wall + +executable ghcjs-example + if !impl(ghcjs) + Buildable: False + ghc-options: -Wall + cpp-options: -DGHCJS_BROWSER + + default-extensions: CPP + default-language: Haskell2010 + hs-source-dirs: ghcjs-example + main-is: Main.hs + build-depends: base + , text + , transformers + , reddit + if impl(ghcjs) + build-depends: ghcjs-base diff --git a/src/Reddit.hs b/src/Reddit.hs index c307573..d7bf915 100644 --- a/src/Reddit.hs +++ b/src/Reddit.hs @@ -35,8 +35,22 @@ import Data.Default.Class import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) import Network.API.Builder as API + +#ifdef __GHCJS__ + +import JavaScript.Web.XMLHttpRequest +import qualified Data.Text.Encoding as TE +import Data.JSString.Text +import qualified Data.JSString as JSS +import Control.Arrow ((***)) + +#else + import Network.HTTP.Client import Network.HTTP.Client.TLS + +#endif + import Network.HTTP.Types -- | Options for how we should run the 'Reddit' action. @@ -111,7 +125,7 @@ runResumeRedditWith (RedditOptions rl man lm _ua) reddit = do Left (err, _) -> return $ Left (err, Just reddit) Right lds -> interpretIO - (RedditState mainBaseURL rl manager [("User-Agent", "reddit-haskell dev version")] lds) reddit + (RedditState mainBaseURL rl manager defaultHeaders lds) reddit interpretIO :: MonadIO m => RedditState -> RedditT m a -> m (Either (APIError RedditError, Maybe (RedditT m a)) a) interpretIO rstate (RedditT r) = @@ -152,6 +166,26 @@ handleReceive r rstate = do API.runRoute r return res +#ifdef __GHCJS__ + +builderFromState :: RedditState -> Builder +builderFromState (RedditState burl _ _ hdrs (Just (LoginDetails (Modhash mh) _))) = + Builder "Reddit" burl addAPIType $ + \req -> addHeaders (("X-Modhash", encodeUtf8 mh):hdrs) req +builderFromState (RedditState burl _ _ hdrs Nothing) = + Builder "Reddit" burl addAPIType (addHeaders hdrs) + +addHeaders :: [Header] -> Request -> Request +addHeaders xs req = req { reqHeaders = reqHeaders req ++ (map (JSS.pack . show *** byteStringToJS) xs) } + +byteStringToJS :: ByteString -> JSS.JSString +byteStringToJS = textToJSString . TE.decodeUtf8 + +defaultHeaders :: [Header] +defaultHeaders = [] -- browser will not allow to set User-Agent + +#else + builderFromState :: RedditState -> Builder builderFromState (RedditState burl _ _ hdrs (Just (LoginDetails (Modhash mh) cj))) = Builder "Reddit" burl addAPIType $ @@ -162,9 +196,15 @@ builderFromState (RedditState burl _ _ hdrs Nothing) = addHeaders :: [Header] -> Request -> Request addHeaders xs req = req { requestHeaders = requestHeaders req ++ xs } +defaultHeaders :: [Header] +defaultHeaders = + [("User-Agent", "reddit-haskell dev version")] +#endif + data RedditState = RedditState { currentBaseURL :: Text , rateLimit :: Bool , connMgr :: Manager , _extraHeaders :: [Header] , _creds :: Maybe LoginDetails } + diff --git a/src/Reddit/Types/Reddit.hs b/src/Reddit/Types/Reddit.hs index 58391bf..1846e48 100644 --- a/src/Reddit/Types/Reddit.hs +++ b/src/Reddit/Types/Reddit.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Reddit.Types.Reddit ( Reddit , RedditT(..) @@ -27,12 +28,26 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Free import Control.Monad.Trans.Class import Data.Aeson -import Data.ByteString.Lazy (ByteString) import Data.Monoid import Data.Text (Text) import Data.Time.Clock import Network.API.Builder hiding (runRoute) + +#ifdef __GHCJS__ + +import JavaScript.Web.XMLHttpRequest +import Data.ByteString (ByteString) +import qualified Data.Text.Encoding as TE +import Data.JSString.Text +import qualified Data.JSString as JSS + +#else + import Network.HTTP.Client hiding (path) +import Data.ByteString.Lazy (ByteString) + +#endif + import Network.HTTP.Types import Prelude import Text.Read (readMaybe) @@ -40,6 +55,16 @@ import qualified Data.ByteString.Char8 as BS type Reddit a = RedditT IO a +#ifdef __GHCJS__ + +data CookieJar = CookieJar + deriving (Show, Eq) + +responseCookieJar :: Response a -> CookieJar +responseCookieJar _ = CookieJar + +#endif + data RedditF m a where FailWith :: APIError RedditError -> RedditF m a Nest :: RedditT m b -> (Either (APIError RedditError) b -> a) -> RedditF m a @@ -129,12 +154,25 @@ builder = Builder "Reddit" addAPIType (addHeader Nothing) +#ifdef __GHCJS__ + +addHeader :: Maybe BS.ByteString -> Request -> Request +addHeader Nothing req = req +addHeader (Just hdr) req = req + +byteStringToJS :: ByteString -> JSS.JSString +byteStringToJS = textToJSString . TE.decodeUtf8 + +#else + addHeader :: Maybe BS.ByteString -> Request -> Request addHeader Nothing req = req { requestHeaders = ("User-Agent", "reddit-haskell 0.1.0.0 / intolerable") : requestHeaders req } addHeader (Just hdr) req = req { requestHeaders = ("User-Agent", hdr) : requestHeaders req } +#endif + addAPIType :: Route -> Route addAPIType (Route fs ps m) = Route fs ("api_type" =. ("json" :: Text) : ps) m