Fix type errors and example client and server

.gitignore

@@ -1,3 +1,7 @@
 .cabal-sandbox
 cabal.sandbox.config
 dist
+*.js
+log
+*.webapp
+*.stats

exec/API.hs

@@ -7,3 +7,4 @@ import Servant.API
 
 type API = "getunit" :> Get '[JSON] () 
       :<|> "getint"  :> Get '[JSON] Int
+      :<|> Raw

exec/Example.hs

@@ -3,6 +3,8 @@
 
 module Main where
 
+import Data.Maybe
+import Servant.API
 import Servant.Reflex
 import API
 import Data.Proxy
@@ -19,9 +21,25 @@ main = mainWidget run
 
 run :: forall t m. MonadWidget t m => m ()
 run = do
-  let (getUnit :: Event t () -> m (Event t ((),()))) = client api url
-  b :: Event t () <- button "Get unit"
-  res :: Event t ((),()) <- getUnit b
-  c <- foldDyn (\_ (n :: Int) -> succ n) 0 res
-  display c
+  let (getUnit :<|> getInt :<|> doRaw) = client api (Proxy :: Proxy m) (constDyn url)
+  b  :: Event t () <- button "Get unit"
+  b' :: Event t () <- button "Get int"
+  res :: Event t (Maybe (), XhrResponse) <- getUnit b
+  res' :: Event t (Maybe Int, XhrResponse) <- getInt b'
+  r <- holdDyn "Waiting" $ leftmost [fmap (showXhrResponse . snd) res
+                                    ,fmap (showXhrResponse . snd) res'
+                                    ]
+  dynText r
 
+showXhrResponse :: XhrResponse -> String
+showXhrResponse (XhrResponse stat stattxt rbmay rtmay) =
+  unlines ["stat: " ++ show stat
+          ,"stattxt: " ++ show stattxt
+          ,"resp: " ++ maybe "" showRB rbmay
+          ,"rtext: " ++ show rtmay]
+
+showRB :: XhrResponseBody -> String
+showRB (XhrResponseBody_Default t) = show t
+showRB (XhrResponseBody_Text t) = show t
+showRB (XhrResponseBody_Blob t) = "<Blob>"
+showRB (XhrResponseBody_ArrayBuffer t) = show t

src/Servant/Common/Req.hs

@@ -10,8 +10,11 @@ module Servant.Common.Req where
 -- import Control.Monad.IO.Class
 -- import Control.Monad.Trans.Except
 import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
+import qualified Data.ByteString.Lazy.Char8 as BL
+import qualified Data.Text.Encoding as TE
 -- import qualified Data.Foldable as F
 import qualified Data.List as L
+import Data.Proxy
 -- import Data.Monoid
 -- import Data.String
 -- import Data.String.Conversions
@@ -26,6 +29,7 @@ import qualified Data.List as L
 -- import Network.URI hiding (path)
 -- import Servant.API.ContentTypes
 import Servant.Common.BaseUrl
+import Servant.API.ContentTypes
 import Reflex
 import Reflex.Dom
 
@@ -133,19 +137,24 @@ performRequest reqMethod req _ trigger = do
 
 -- TODO implement
 -- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
+  -- TODO Proxy probably not needed
 performRequestNoBody ::
-  forall t m .MonadWidget t m => String -> Req t -> Dynamic t BaseUrl
+  forall t m .MonadWidget t m => Proxy m -> String -> Req t -> Dynamic t BaseUrl
                               -> Event t () -> m (Event t XhrResponse)
-performRequestNoBody reqMethod req reqHost trigger = do
+performRequestNoBody _ reqMethod req reqHost trigger = do
   performRequest reqMethod req reqHost trigger
   -- return hdrs
 
-performRequestCT :: (MonadWidget t m, FromHttpApiData a)
-                 => String -> Req t -> Dynamic t BaseUrl
+performRequestCT :: (MonadWidget t m, FromHttpApiData a, MimeUnrender ct a)
+                 => Proxy ct -> String -> Req t -> Dynamic t BaseUrl
                  -> Event t () -> m (Event t (Maybe a, XhrResponse))
-performRequestCT reqMethod req reqHost trigger = do
+performRequestCT ct reqMethod req reqHost trigger = do
   resp <- performRequest reqMethod req reqHost trigger
-  return $ ffor resp $ \xhr -> undefined
+  return $ ffor resp $ \xhr -> (hushed (mimeUnrender ct . BL.fromStrict . TE.encodeUtf8) =<< _xhrResponse_responseText xhr, xhr)
+  where hushed :: (x -> Either e y) -> (x -> Maybe y)
+        hushed f ea = case f ea of
+          Left e  -> Nothing
+          Right a -> Just a
 
 
   -- partialRequest <- liftIO $ reqToRequest req reqHost

src/Servant/Reflex.hs

@@ -18,7 +18,6 @@
 module Servant.Reflex
   ( client
   , HasClient(..)
-  , ServantError(..)
   , module Servant.Common.BaseUrl
   ) where
 
@@ -29,6 +28,7 @@ import           Data.List
 import           Data.Proxy
 import           Data.String.Conversions
 import           Data.Text                  (unpack)
+import qualified Data.ByteString.Char8 as BS
 import           GHC.TypeLits
 -- import           Network.HTTP.Media
 -- import qualified Network.HTTP.Types         as H
@@ -36,6 +36,7 @@ import           GHC.TypeLits
 import           Servant.API
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
+import           Servant.API.ContentTypes
 import           Reflex
 import           Reflex.Dom
 import           Reflex.Dom.Xhr
@@ -55,22 +56,23 @@ import           Reflex.Dom.Xhr
 --               -> m (Event t (Either XhrError (Book,Book)))
 -- > (getAllBooks :<|> postNewBook) = client myApi host
 -- >   where host = constDyn $ BaseUrl Http "localhost" 8080
-client :: (HasClient t m layout, MonadWidget t m) => Proxy layout -> Dynamic t BaseUrl -> Client t m layout
-client p baseurl = clientWithRoute p defReq baseurl
+client :: (HasClient t m layout, MonadWidget t m)
+       => Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
+client p q baseurl = clientWithRoute p q defReq baseurl
 
 -- | This class lets us define how each API combinator
 -- influences the creation of an HTTP request. It's mostly
 -- an internal class, you can just use 'client'.
 class HasClient t m layout where
   type Client t m layout :: *
-  clientWithRoute :: Proxy layout -> Req t -> BaseUrl -> Client t m layout
+  clientWithRoute :: Proxy layout -> Proxy m -> Req t -> Dynamic t BaseUrl -> Client t m layout
 
 
 instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
   type Client t m (a :<|> b) = Client t m a :<|> Client t m b
-  clientWithRoute Proxy req baseurl =
-    clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
-    clientWithRoute (Proxy :: Proxy b) req baseurl
+  clientWithRoute Proxy q req baseurl =
+    clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>
+    clientWithRoute (Proxy :: Proxy b) q req baseurl
 
 -- Capture. Example:
 -- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
@@ -89,25 +91,26 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s
   type Client t m (Capture capture a :> sublayout) =
     Behavior t (Maybe a) -> Client t m sublayout
 
-  clientWithRoute Proxy req baseurl val =
+  clientWithRoute Proxy q req baseurl val =
     clientWithRoute (Proxy :: Proxy sublayout)
+                    q
                     (prependToPathParts p req)
                     baseurl
 
-    where p = fmap (unpack . toUrlPiece) val
+    where p = (fmap . fmap) (unpack . toUrlPiece) val
 
 -- VERB (Returning content) --
 instance {-# OVERLAPPABLE #-}
   -- Note [Non-Empty Content Types]
-  (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
+  (MimeUnrender ct a, FromHttpApiData a, ReflectMethod method, cts' ~ (ct ': cts), MonadWidget t m
   ) => HasClient t m (Verb method status cts' a) where
   type Client t m (Verb method status cts' a) =
     Event t () -> m (Event t (Maybe a, XhrResponse))
     -- TODO how to access input types here?
     -- ExceptT ServantError IO a
-  clientWithRoute Proxy req baseurl =
+  clientWithRoute Proxy q req baseurl =
     performRequestCT (Proxy :: Proxy ct) method req baseurl
-      where method = reflectMethod (Proxy :: Proxy method)
+      where method = BS.unpack $ reflectMethod (Proxy :: Proxy method)
 
 -- TODO Overlapping error??
 -- -- VERB (No content) --
@@ -180,12 +183,14 @@ instance (KnownSymbol sym, ToHttpApiData a,
   type Client t m (Header sym a :> sublayout) =
     Behavior t (Maybe a) -> Client t m sublayout
 
-  clientWithRoute Proxy req baseurl mval =
+  clientWithRoute Proxy q req baseurl mval =
     clientWithRoute (Proxy :: Proxy sublayout)
-                    (maybe req
-                           (\value -> Servant.Common.Req.addHeader hname value req)
-                           mval
-                    )
+                    q
+                    req
+                    -- (maybe req -- TODO Need to pass the header in
+                    --        (\value -> Servant.Common.Req.addHeader hname value req)
+                    --        mval
+                    -- )
                     baseurl
 
     where hname = symbolVal (Proxy :: Proxy sym)
@@ -198,8 +203,8 @@ instance HasClient t m sublayout
   type Client t m (HttpVersion :> sublayout) =
     Client t m sublayout
 
-  clientWithRoute Proxy =
-    clientWithRoute (Proxy :: Proxy sublayout)
+  clientWithRoute Proxy q =
+    clientWithRoute (Proxy :: Proxy sublayout) q
 
 -- | If you use a 'QueryParam' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
@@ -235,14 +240,16 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
     Behavior t (Maybe a) -> Client t m sublayout
 
   -- if mparam = Nothing, we don't add it to the query string
-  clientWithRoute Proxy req baseurl mparam =
+  clientWithRoute Proxy q req baseurl mparam =
     clientWithRoute (Proxy :: Proxy sublayout)
-                    (req {qParams = (pname', map show mparam) : qParams req})
+                    q
+                    req -- TODO Must pass in the query param
+                    -- (req {qParams = (pname', map show mparam) : qParams req})
                     baseurl
 
-    where pname  = cs pname'
-          pname' = symbolVal (Proxy :: Proxy sym)
-          mparamText = fmap toQueryParam mparam
+    -- where pname  = cs pname'
+    --       pname' = symbolVal (Proxy :: Proxy sym)
+    --       mparamText = fmap toQueryParam mparam
 
 -- | If you use a 'QueryParams' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
@@ -278,7 +285,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
   type Client t m (QueryParams sym a :> sublayout) =
     [a] -> Client t m sublayout
 
-  clientWithRoute Proxy req baseurl paramlist = undefined
+  clientWithRoute Proxy _ req baseurl paramlist = undefined
     -- clientWithRoute (Proxy :: Proxy sublayout)
     --                 (foldl' prependPathParts req paramlist')
     --                 (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
@@ -335,12 +342,15 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
 -- | Pick a 'Method' and specify where the server you want to query is. You get
 -- back the full `Response`.
 -- TODO redo
--- instance HasClient Raw where
---   type Client Raw = String -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
+instance (MonadWidget t m) => HasClient t m Raw where
+  type Client t m Raw = Behavior t (Maybe XhrRequest)
+                      -> Event t ()
+                      -> m (Event t XhrResponse)
 
---   clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
---   clientWithRoute Proxy req baseurl httpMethod = do
---     performRequest httpMethod req baseurl 
+  -- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw
+  clientWithRoute p q req baseurl xhrs triggers = do
+    let okReq = fmapMaybe id $ tag xhrs triggers
+    performRequestAsync okReq
 
 -- | If you use a 'ReqBody' in one of your endpoints in your API,
 -- the corresponding querying function will automatically take
@@ -379,12 +389,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
 --                     baseurl 
 
 -- | Make the querying function append @path@ to the request path.
-instance (KnownSymbol path, HasClient t m sublayout) => HasClient t m (path :> sublayout) where
+instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m (path :> sublayout) where
   type Client t m (path :> sublayout) = Client t m sublayout
 
-  clientWithRoute Proxy req baseurl =
-     clientWithRoute (Proxy :: Proxy sublayout)
-                     (prependToPathParts (constant p) req)
+  clientWithRoute Proxy q req baseurl =
+     clientWithRoute (Proxy :: Proxy sublayout) q
+                     (prependToPathParts (constant (Just p)) req)
                      baseurl
 
     where p = symbolVal (Proxy :: Proxy path)
@@ -392,26 +402,26 @@ instance (KnownSymbol path, HasClient t m sublayout) => HasClient t m (path :> s
 instance HasClient t m api => HasClient t m (Vault :> api) where
   type Client t m (Vault :> api) = Client t m api
 
-  clientWithRoute Proxy req baseurl =
-    clientWithRoute (Proxy :: Proxy api) req baseurl
+  clientWithRoute Proxy q req baseurl =
+    clientWithRoute (Proxy :: Proxy api) q req baseurl
 
 instance HasClient t m api => HasClient t m (RemoteHost :> api) where
   type Client t m (RemoteHost :> api) = Client t m api
 
-  clientWithRoute Proxy req baseurl =
-    clientWithRoute (Proxy :: Proxy api) req baseurl
+  clientWithRoute Proxy q req baseurl =
+    clientWithRoute (Proxy :: Proxy api) q req baseurl
 
 instance HasClient t m api => HasClient t m (IsSecure :> api) where
   type Client t m (IsSecure :> api) = Client t m api
 
-  clientWithRoute Proxy req baseurl =
-    clientWithRoute (Proxy :: Proxy api) req baseurl
+  clientWithRoute Proxy q req baseurl =
+    clientWithRoute (Proxy :: Proxy api) q req baseurl
 
 instance HasClient t m subapi =>
   HasClient t m (WithNamedConfig name config subapi) where
 
   type Client t m (WithNamedConfig name config subapi) = Client t m subapi
-  clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
+  clientWithRoute Proxy q = clientWithRoute (Proxy :: Proxy subapi) q
 
 
 {- Note [Non-Empty Content Types]

testserver/Main.hs

@@ -14,9 +14,11 @@ import           Snap.Http.Server
 import           Snap.Core
 import           Servant.Server.Internal.SnapShims
 
-import           Servant
+import           Servant -- hiding (serveDirectory)
 import           Servant.Server
+-- import           Snap.Util.FileServe
 import           API
+import Snap
 
 -- * Example
 
@@ -30,28 +32,37 @@ instance ToJSON Greet
 testApi :: Proxy API
 testApi = Proxy
 
+data App = App
+
 -- Server-side handlers.
 --
 -- There's one handler per endpoint, which, just like in the type
 -- that represents the API, are glued together using :<|>.
 --
 -- Each handler runs in the 'ExceptT ServantErr IO' monad.
-server :: Server API Snap
-server = return () :<|> return 100
+server :: Server API (Handler App App)
+server = return () :<|> return 100 :<|> serveDirectory "static"
 
-  where helloH name Nothing = helloH name (Just False)
-        helloH name (Just False) = return . Greet $ "Hello, " <> name
-        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+  -- where helloH name Nothing = helloH name (Just False)
+  --       helloH name (Just False) = return . Greet $ "Hello, " <> name
+  --       helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
 
-        postGreetH greet = return greet
+  --       postGreetH greet = return greet
 
-        deleteGreetH _ = return ()
+  --       deleteGreetH _ = return ()
 
 -- Turn the server into a WAI app. 'serve' is provided by servant,
 -- more precisely by the Servant.Server module.
-test :: Application Snap
+test :: Application (Handler App App)
 test = serve testApi server
 
+initApp :: SnapletInit App App
+initApp = makeSnaplet "myapp" "example" Nothing $ do
+  addRoutes [("", applicationToSnap test)
+            -- ,("",    serveDirectory "static")
+            ]
+  return App
+
 -- Put this all to work!
 main :: IO ()
-main = quickHttpServe $ applicationToSnap (serve testApi server)
+main = serveSnaplet mempty initApp

testserver/static/index.html

@@ -0,0 +1,11 @@
+<!DOCTYPE html>
+<html>
+  <head>
+    <script language="javascript" src="rts.js"></script>
+    <script language="javascript" src="lib.js"></script>
+    <script language="javascript" src="out.js"></script>
+  </head>
+  <body>
+  </body>
+  <script language="javascript" src="runmain.js" defer></script>
+</html>

toSite.sh

@@ -0,0 +1 @@
+cp dist/build/example/example.jsexe/* testserver/static