add GHCJS support

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

reddit.cabal

@@ -87,6 +87,7 @@ library
     GeneralizedNewtypeDeriving
     LambdaCase
     OverloadedStrings
+    CPP
   default-language: Haskell2010
   hs-source-dirs: src/
   build-depends:
@@ -96,15 +97,21 @@ 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.*,
     time == 1.5.*,
     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

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 }
+

src/Reddit/Types/Reddit.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module Reddit.Types.Reddit
   ( Reddit
   , RedditT(..)
@@ -27,19 +28,43 @@ 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)
 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