Response parsing

exec/API.hs

@@ -6,4 +6,4 @@ module API where
 import Servant.API
 
 --type API = Get '[JSON] () :<|> Get '[JSON] Int
-type API = Get '[JSON] ()
+type API = Get '[JSON] Int

exec/Example.hs

@@ -12,16 +12,16 @@ api :: Proxy API
 api = Proxy
 
 url :: BaseUrl
-url = BaseUrl Http "localhost" 8000 ""
+url = BaseUrl Http "localhost" 8000 "api"
 
 main :: IO ()
 main = mainWidget run
 
 run :: forall t m. MonadWidget t m => m ()
 run = do
-  let getUnit = clientWithRoute api defReq url
-  b :: Event t () <- button "Get unit"
-  res :: Event t ((),()) <- getUnit b
-  c <- foldDyn (\_ (n :: Int) -> succ n) 0 res
+  let getInt = clientWithRoute api defReq url
+  b :: Event t () <- button "Get int"
+  res :: Event t ((),Int) <- getInt b
+  c <- foldDyn (\n accum -> accum + snd n) 0 $ traceEvent "res" res
   display c
 

servant-reflex.cabal

@@ -33,6 +33,7 @@ library
     http-types          >= 0.8  && < 0.10,
     mtl,
     network-uri         >= 2.6  && < 2.7,
+    readable,
     reflex,
     reflex-dom,
     safe,

src/Servant/Reflex.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE InstanceSigs         #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TupleSections        #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -28,6 +29,7 @@ import           Control.Applicative        ((<$>))
 import           Control.Monad.Trans (liftIO)
 import           Data.Default
 import           Data.Proxy
+import           Data.String.Conversions
 import           GHC.TypeLits
 import           Servant.API
 import           Servant.Common.BaseUrl
@@ -102,21 +104,27 @@ instance
       performAJAX requestBuilder responseParser trigEvents
     where
       requestBuilder _ = XhrRequest "GET" (showBaseUrl baseurl) def
-      responseParser xhrResp = undefined
+      responseParser xhrResp =
+        hush . mimeUnrender (Proxy :: Proxy ct) =<<
+        (cs <$> _xhrResponse_responseText xhrResp)
+
+hush (Left _) = Nothing
+hush (Right a) = Just a
 
 performAJAX
     :: (MonadWidget t m)
     => (a -> XhrRequest)
     -- ^ Function to build the request
-    -> (XhrResponse -> b)
+    -> (XhrResponse -> Maybe b)
     -- ^ Function to parse the response
     -> Event t a
     -> m (Event t (a, b))
-performAJAX mkRequest parseResponse req =
-    performEventAsync $ ffor req $ \a cb -> do
+performAJAX mkRequest parseResponse req = do
+    e <- performEventAsync $ ffor req $ \a cb -> do
       _ <- newXMLHttpRequest (mkRequest a) $ \response ->
-             liftIO $ cb (a, parseResponse response)
+             liftIO $ cb $ (a,) <$> parseResponse response
       return ()
+    return $ fmapMaybe id e
 
 
 instance
@@ -131,7 +139,7 @@ instance
     performAJAX requestBuilder responseParser trigEvents
     where
       requestBuilder _ = XhrRequest "GET" (showBaseUrl baseurl) def
-      responseParser _ = ()
+      responseParser _ = Just ()
 
 -- -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- -- back the full `Response`.

testserver/Main.hs

@@ -14,8 +14,8 @@ import           Snap.Http.Server
 import           Snap.Core
 import           Servant.Server.Internal.SnapShims
 
-import           Servant
-import           Servant.Server
+import           Servant        hiding (route)
+import           Servant.Server hiding (route)
 import           API
 
 -- * Example
@@ -37,7 +37,7 @@ testApi = Proxy
 --
 -- Each handler runs in the 'ExceptT ServantErr IO' monad.
 server :: Server API Snap
-server = return () :<|> return 100
+server = return 100
 
   where helloH name Nothing = helloH name (Just False)
         helloH name (Just False) = return . Greet $ "Hello, " <> name
@@ -54,4 +54,7 @@ test = serve testApi server
 
 -- Put this all to work!
 main :: IO ()
-main = quickHttpServe $ applicationToSnap (serve testApi server)
+main = quickHttpServe $ route
+    [ ("api", applicationToSnap (serve testApi server))
+    , ("", serveDirectory "example.jsexe")
+    ]