mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-10-26 02:11:36 +03:00
Fix type errors and example client and server
This commit is contained in:
parent
24b5f87ad4
commit
0d570fd84a
4
.gitignore
vendored
4
.gitignore
vendored
@ -1,3 +1,7 @@
|
||||
.cabal-sandbox
|
||||
cabal.sandbox.config
|
||||
dist
|
||||
*.js
|
||||
log
|
||||
*.webapp
|
||||
*.stats
|
||||
|
@ -7,3 +7,4 @@ import Servant.API
|
||||
|
||||
type API = "getunit" :> Get '[JSON] ()
|
||||
:<|> "getint" :> Get '[JSON] Int
|
||||
:<|> Raw
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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]
|
||||
|
@ -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
|
||||
|
11
testserver/static/index.html
Normal file
11
testserver/static/index.html
Normal file
@ -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>
|
Loading…
Reference in New Issue
Block a user