mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +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
|
||||||
cabal.sandbox.config
|
cabal.sandbox.config
|
||||||
dist
|
dist
|
||||||
|
*.js
|
||||||
|
log
|
||||||
|
*.webapp
|
||||||
|
*.stats
|
||||||
|
@ -7,3 +7,4 @@ import Servant.API
|
|||||||
|
|
||||||
type API = "getunit" :> Get '[JSON] ()
|
type API = "getunit" :> Get '[JSON] ()
|
||||||
:<|> "getint" :> Get '[JSON] Int
|
:<|> "getint" :> Get '[JSON] Int
|
||||||
|
:<|> Raw
|
||||||
|
@ -3,6 +3,8 @@
|
|||||||
|
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
import Servant.API
|
||||||
import Servant.Reflex
|
import Servant.Reflex
|
||||||
import API
|
import API
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
@ -19,9 +21,25 @@ main = mainWidget run
|
|||||||
|
|
||||||
run :: forall t m. MonadWidget t m => m ()
|
run :: forall t m. MonadWidget t m => m ()
|
||||||
run = do
|
run = do
|
||||||
let (getUnit :: Event t () -> m (Event t ((),()))) = client api url
|
let (getUnit :<|> getInt :<|> doRaw) = client api (Proxy :: Proxy m) (constDyn url)
|
||||||
b :: Event t () <- button "Get unit"
|
b :: Event t () <- button "Get unit"
|
||||||
res :: Event t ((),()) <- getUnit b
|
b' :: Event t () <- button "Get int"
|
||||||
c <- foldDyn (\_ (n :: Int) -> succ n) 0 res
|
res :: Event t (Maybe (), XhrResponse) <- getUnit b
|
||||||
display c
|
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.IO.Class
|
||||||
-- import Control.Monad.Trans.Except
|
-- import Control.Monad.Trans.Except
|
||||||
import Data.ByteString.Char8 hiding (pack, filter, map, null, elem)
|
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.Foldable as F
|
||||||
import qualified Data.List as L
|
import qualified Data.List as L
|
||||||
|
import Data.Proxy
|
||||||
-- import Data.Monoid
|
-- import Data.Monoid
|
||||||
-- import Data.String
|
-- import Data.String
|
||||||
-- import Data.String.Conversions
|
-- import Data.String.Conversions
|
||||||
@ -26,6 +29,7 @@ import qualified Data.List as L
|
|||||||
-- import Network.URI hiding (path)
|
-- import Network.URI hiding (path)
|
||||||
-- import Servant.API.ContentTypes
|
-- import Servant.API.ContentTypes
|
||||||
import Servant.Common.BaseUrl
|
import Servant.Common.BaseUrl
|
||||||
|
import Servant.API.ContentTypes
|
||||||
import Reflex
|
import Reflex
|
||||||
import Reflex.Dom
|
import Reflex.Dom
|
||||||
|
|
||||||
@ -133,19 +137,24 @@ performRequest reqMethod req _ trigger = do
|
|||||||
|
|
||||||
-- TODO implement
|
-- TODO implement
|
||||||
-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
|
-- => String -> Req -> BaseUrl -> ExceptT ServantError IO [HTTP.Header]
|
||||||
|
-- TODO Proxy probably not needed
|
||||||
performRequestNoBody ::
|
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)
|
-> Event t () -> m (Event t XhrResponse)
|
||||||
performRequestNoBody reqMethod req reqHost trigger = do
|
performRequestNoBody _ reqMethod req reqHost trigger = do
|
||||||
performRequest reqMethod req reqHost trigger
|
performRequest reqMethod req reqHost trigger
|
||||||
-- return hdrs
|
-- return hdrs
|
||||||
|
|
||||||
performRequestCT :: (MonadWidget t m, FromHttpApiData a)
|
performRequestCT :: (MonadWidget t m, FromHttpApiData a, MimeUnrender ct a)
|
||||||
=> String -> Req t -> Dynamic t BaseUrl
|
=> Proxy ct -> String -> Req t -> Dynamic t BaseUrl
|
||||||
-> Event t () -> m (Event t (Maybe a, XhrResponse))
|
-> 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
|
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
|
-- partialRequest <- liftIO $ reqToRequest req reqHost
|
||||||
|
@ -18,7 +18,6 @@
|
|||||||
module Servant.Reflex
|
module Servant.Reflex
|
||||||
( client
|
( client
|
||||||
, HasClient(..)
|
, HasClient(..)
|
||||||
, ServantError(..)
|
|
||||||
, module Servant.Common.BaseUrl
|
, module Servant.Common.BaseUrl
|
||||||
) where
|
) where
|
||||||
|
|
||||||
@ -29,6 +28,7 @@ import Data.List
|
|||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
import Data.String.Conversions
|
import Data.String.Conversions
|
||||||
import Data.Text (unpack)
|
import Data.Text (unpack)
|
||||||
|
import qualified Data.ByteString.Char8 as BS
|
||||||
import GHC.TypeLits
|
import GHC.TypeLits
|
||||||
-- import Network.HTTP.Media
|
-- import Network.HTTP.Media
|
||||||
-- import qualified Network.HTTP.Types as H
|
-- import qualified Network.HTTP.Types as H
|
||||||
@ -36,6 +36,7 @@ import GHC.TypeLits
|
|||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.Common.BaseUrl
|
import Servant.Common.BaseUrl
|
||||||
import Servant.Common.Req
|
import Servant.Common.Req
|
||||||
|
import Servant.API.ContentTypes
|
||||||
import Reflex
|
import Reflex
|
||||||
import Reflex.Dom
|
import Reflex.Dom
|
||||||
import Reflex.Dom.Xhr
|
import Reflex.Dom.Xhr
|
||||||
@ -55,22 +56,23 @@ import Reflex.Dom.Xhr
|
|||||||
-- -> m (Event t (Either XhrError (Book,Book)))
|
-- -> m (Event t (Either XhrError (Book,Book)))
|
||||||
-- > (getAllBooks :<|> postNewBook) = client myApi host
|
-- > (getAllBooks :<|> postNewBook) = client myApi host
|
||||||
-- > where host = constDyn $ BaseUrl Http "localhost" 8080
|
-- > 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 :: (HasClient t m layout, MonadWidget t m)
|
||||||
client p baseurl = clientWithRoute p defReq baseurl
|
=> 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
|
-- | This class lets us define how each API combinator
|
||||||
-- influences the creation of an HTTP request. It's mostly
|
-- influences the creation of an HTTP request. It's mostly
|
||||||
-- an internal class, you can just use 'client'.
|
-- an internal class, you can just use 'client'.
|
||||||
class HasClient t m layout where
|
class HasClient t m layout where
|
||||||
type Client t m layout :: *
|
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
|
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
|
type Client t m (a :<|> b) = Client t m a :<|> Client t m b
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
|
clientWithRoute (Proxy :: Proxy a) q req baseurl :<|>
|
||||||
clientWithRoute (Proxy :: Proxy b) req baseurl
|
clientWithRoute (Proxy :: Proxy b) q req baseurl
|
||||||
|
|
||||||
-- Capture. Example:
|
-- Capture. Example:
|
||||||
-- > type MyApi = "books" :> Capture "isbn" Text :> Get '[JSON] Book
|
-- > 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) =
|
type Client t m (Capture capture a :> sublayout) =
|
||||||
Behavior t (Maybe a) -> Client t m sublayout
|
Behavior t (Maybe a) -> Client t m sublayout
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl val =
|
clientWithRoute Proxy q req baseurl val =
|
||||||
clientWithRoute (Proxy :: Proxy sublayout)
|
clientWithRoute (Proxy :: Proxy sublayout)
|
||||||
|
q
|
||||||
(prependToPathParts p req)
|
(prependToPathParts p req)
|
||||||
baseurl
|
baseurl
|
||||||
|
|
||||||
where p = fmap (unpack . toUrlPiece) val
|
where p = (fmap . fmap) (unpack . toUrlPiece) val
|
||||||
|
|
||||||
-- VERB (Returning content) --
|
-- VERB (Returning content) --
|
||||||
instance {-# OVERLAPPABLE #-}
|
instance {-# OVERLAPPABLE #-}
|
||||||
-- Note [Non-Empty Content Types]
|
-- 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
|
) => HasClient t m (Verb method status cts' a) where
|
||||||
type Client t m (Verb method status cts' a) =
|
type Client t m (Verb method status cts' a) =
|
||||||
Event t () -> m (Event t (Maybe a, XhrResponse))
|
Event t () -> m (Event t (Maybe a, XhrResponse))
|
||||||
-- TODO how to access input types here?
|
-- TODO how to access input types here?
|
||||||
-- ExceptT ServantError IO a
|
-- ExceptT ServantError IO a
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
performRequestCT (Proxy :: Proxy ct) method 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??
|
-- TODO Overlapping error??
|
||||||
-- -- VERB (No content) --
|
-- -- VERB (No content) --
|
||||||
@ -180,12 +183,14 @@ instance (KnownSymbol sym, ToHttpApiData a,
|
|||||||
type Client t m (Header sym a :> sublayout) =
|
type Client t m (Header sym a :> sublayout) =
|
||||||
Behavior t (Maybe a) -> Client t m sublayout
|
Behavior t (Maybe a) -> Client t m sublayout
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl mval =
|
clientWithRoute Proxy q req baseurl mval =
|
||||||
clientWithRoute (Proxy :: Proxy sublayout)
|
clientWithRoute (Proxy :: Proxy sublayout)
|
||||||
(maybe req
|
q
|
||||||
(\value -> Servant.Common.Req.addHeader hname value req)
|
req
|
||||||
mval
|
-- (maybe req -- TODO Need to pass the header in
|
||||||
)
|
-- (\value -> Servant.Common.Req.addHeader hname value req)
|
||||||
|
-- mval
|
||||||
|
-- )
|
||||||
baseurl
|
baseurl
|
||||||
|
|
||||||
where hname = symbolVal (Proxy :: Proxy sym)
|
where hname = symbolVal (Proxy :: Proxy sym)
|
||||||
@ -198,8 +203,8 @@ instance HasClient t m sublayout
|
|||||||
type Client t m (HttpVersion :> sublayout) =
|
type Client t m (HttpVersion :> sublayout) =
|
||||||
Client t m sublayout
|
Client t m sublayout
|
||||||
|
|
||||||
clientWithRoute Proxy =
|
clientWithRoute Proxy q =
|
||||||
clientWithRoute (Proxy :: Proxy sublayout)
|
clientWithRoute (Proxy :: Proxy sublayout) q
|
||||||
|
|
||||||
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
-- | If you use a 'QueryParam' in one of your endpoints in your API,
|
||||||
-- the corresponding querying function will automatically take
|
-- 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
|
Behavior t (Maybe a) -> Client t m sublayout
|
||||||
|
|
||||||
-- if mparam = Nothing, we don't add it to the query string
|
-- 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)
|
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
|
baseurl
|
||||||
|
|
||||||
where pname = cs pname'
|
-- where pname = cs pname'
|
||||||
pname' = symbolVal (Proxy :: Proxy sym)
|
-- pname' = symbolVal (Proxy :: Proxy sym)
|
||||||
mparamText = fmap toQueryParam mparam
|
-- mparamText = fmap toQueryParam mparam
|
||||||
|
|
||||||
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
-- | If you use a 'QueryParams' in one of your endpoints in your API,
|
||||||
-- the corresponding querying function will automatically take
|
-- 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) =
|
type Client t m (QueryParams sym a :> sublayout) =
|
||||||
[a] -> Client t m sublayout
|
[a] -> Client t m sublayout
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl paramlist = undefined
|
clientWithRoute Proxy _ req baseurl paramlist = undefined
|
||||||
-- clientWithRoute (Proxy :: Proxy sublayout)
|
-- clientWithRoute (Proxy :: Proxy sublayout)
|
||||||
-- (foldl' prependPathParts req paramlist')
|
-- (foldl' prependPathParts req paramlist')
|
||||||
-- (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
|
-- (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
|
-- | Pick a 'Method' and specify where the server you want to query is. You get
|
||||||
-- back the full `Response`.
|
-- back the full `Response`.
|
||||||
-- TODO redo
|
-- TODO redo
|
||||||
-- instance HasClient Raw where
|
instance (MonadWidget t m) => HasClient t m Raw where
|
||||||
-- type Client Raw = String -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
|
type Client t m Raw = Behavior t (Maybe XhrRequest)
|
||||||
|
-> Event t ()
|
||||||
|
-> m (Event t XhrResponse)
|
||||||
|
|
||||||
-- clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
|
-- clientWithRoute :: Proxy Raw -> Proxy m -> Req -> BaseUrl -> Client t m Raw
|
||||||
-- clientWithRoute Proxy req baseurl httpMethod = do
|
clientWithRoute p q req baseurl xhrs triggers = do
|
||||||
-- performRequest httpMethod req baseurl
|
let okReq = fmapMaybe id $ tag xhrs triggers
|
||||||
|
performRequestAsync okReq
|
||||||
|
|
||||||
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
-- | If you use a 'ReqBody' in one of your endpoints in your API,
|
||||||
-- the corresponding querying function will automatically take
|
-- the corresponding querying function will automatically take
|
||||||
@ -379,12 +389,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout)
|
|||||||
-- baseurl
|
-- baseurl
|
||||||
|
|
||||||
-- | Make the querying function append @path@ to the request path.
|
-- | 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
|
type Client t m (path :> sublayout) = Client t m sublayout
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
clientWithRoute (Proxy :: Proxy sublayout)
|
clientWithRoute (Proxy :: Proxy sublayout) q
|
||||||
(prependToPathParts (constant p) req)
|
(prependToPathParts (constant (Just p)) req)
|
||||||
baseurl
|
baseurl
|
||||||
|
|
||||||
where p = symbolVal (Proxy :: Proxy path)
|
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
|
instance HasClient t m api => HasClient t m (Vault :> api) where
|
||||||
type Client t m (Vault :> api) = Client t m api
|
type Client t m (Vault :> api) = Client t m api
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
clientWithRoute (Proxy :: Proxy api) req baseurl
|
clientWithRoute (Proxy :: Proxy api) q req baseurl
|
||||||
|
|
||||||
instance HasClient t m api => HasClient t m (RemoteHost :> api) where
|
instance HasClient t m api => HasClient t m (RemoteHost :> api) where
|
||||||
type Client t m (RemoteHost :> api) = Client t m api
|
type Client t m (RemoteHost :> api) = Client t m api
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
clientWithRoute (Proxy :: Proxy api) req baseurl
|
clientWithRoute (Proxy :: Proxy api) q req baseurl
|
||||||
|
|
||||||
instance HasClient t m api => HasClient t m (IsSecure :> api) where
|
instance HasClient t m api => HasClient t m (IsSecure :> api) where
|
||||||
type Client t m (IsSecure :> api) = Client t m api
|
type Client t m (IsSecure :> api) = Client t m api
|
||||||
|
|
||||||
clientWithRoute Proxy req baseurl =
|
clientWithRoute Proxy q req baseurl =
|
||||||
clientWithRoute (Proxy :: Proxy api) req baseurl
|
clientWithRoute (Proxy :: Proxy api) q req baseurl
|
||||||
|
|
||||||
instance HasClient t m subapi =>
|
instance HasClient t m subapi =>
|
||||||
HasClient t m (WithNamedConfig name config subapi) where
|
HasClient t m (WithNamedConfig name config subapi) where
|
||||||
|
|
||||||
type Client t m (WithNamedConfig name config subapi) = Client t m subapi
|
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]
|
{- Note [Non-Empty Content Types]
|
||||||
|
@ -14,9 +14,11 @@ import Snap.Http.Server
|
|||||||
import Snap.Core
|
import Snap.Core
|
||||||
import Servant.Server.Internal.SnapShims
|
import Servant.Server.Internal.SnapShims
|
||||||
|
|
||||||
import Servant
|
import Servant -- hiding (serveDirectory)
|
||||||
import Servant.Server
|
import Servant.Server
|
||||||
|
-- import Snap.Util.FileServe
|
||||||
import API
|
import API
|
||||||
|
import Snap
|
||||||
|
|
||||||
-- * Example
|
-- * Example
|
||||||
|
|
||||||
@ -30,28 +32,37 @@ instance ToJSON Greet
|
|||||||
testApi :: Proxy API
|
testApi :: Proxy API
|
||||||
testApi = Proxy
|
testApi = Proxy
|
||||||
|
|
||||||
|
data App = App
|
||||||
|
|
||||||
-- Server-side handlers.
|
-- Server-side handlers.
|
||||||
--
|
--
|
||||||
-- There's one handler per endpoint, which, just like in the type
|
-- There's one handler per endpoint, which, just like in the type
|
||||||
-- that represents the API, are glued together using :<|>.
|
-- that represents the API, are glued together using :<|>.
|
||||||
--
|
--
|
||||||
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
|
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
|
||||||
server :: Server API Snap
|
server :: Server API (Handler App App)
|
||||||
server = return () :<|> return 100
|
server = return () :<|> return 100 :<|> serveDirectory "static"
|
||||||
|
|
||||||
where helloH name Nothing = helloH name (Just False)
|
-- where helloH name Nothing = helloH name (Just False)
|
||||||
helloH name (Just False) = return . Greet $ "Hello, " <> name
|
-- helloH name (Just False) = return . Greet $ "Hello, " <> name
|
||||||
helloH name (Just True) = return . Greet . toUpper $ "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,
|
-- Turn the server into a WAI app. 'serve' is provided by servant,
|
||||||
-- more precisely by the Servant.Server module.
|
-- more precisely by the Servant.Server module.
|
||||||
test :: Application Snap
|
test :: Application (Handler App App)
|
||||||
test = serve testApi server
|
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!
|
-- Put this all to work!
|
||||||
main :: IO ()
|
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