mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-10-26 02:11:36 +03:00
Dynamic servant api, tagDyn to catch most recent parameters; update example
This commit is contained in:
parent
d8a9c572ce
commit
2cd77cf982
@ -59,12 +59,12 @@ run = do
|
||||
text "Name"
|
||||
el "br" $ return ()
|
||||
inp :: Dynamic t Text <- fmap value (textInput def)
|
||||
let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) (current inp)
|
||||
let checkedName = fmap (\i -> bool (QParamSome i) (QParamInvalid "Need a name") (T.null i)) inp
|
||||
el "br" $ return ()
|
||||
|
||||
text "Greetings (space-separated)"
|
||||
el "br" $ return ()
|
||||
greetings <- fmap (fmap T.words . current . value) (textInput def)
|
||||
greetings <- fmap (fmap T.words . value) (textInput def)
|
||||
|
||||
el "br" $ return ()
|
||||
|
||||
@ -72,8 +72,9 @@ run = do
|
||||
|
||||
el "br" $ return ()
|
||||
sayhiClicks :: Event t () <- button "Say hi"
|
||||
let triggers = leftmost [sayhiClicks, () <$ updated inp]
|
||||
|
||||
resp <- sayhi checkedName greetings (current gusto) sayhiClicks
|
||||
resp <- sayhi checkedName greetings gusto triggers
|
||||
dynText =<< holdDyn "No hi yet" (leftmost [fmapMaybe reqSuccess resp, fmapMaybe reqFailure resp])
|
||||
|
||||
elClass "div" "demo-group" $ do
|
||||
@ -81,14 +82,14 @@ run = do
|
||||
el "br" $ return ()
|
||||
dblinp <- value <$> textInput def
|
||||
dblBtn <- button "Double it"
|
||||
dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ current dblinp) dblBtn
|
||||
dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $ dblinp) dblBtn
|
||||
dynText =<< holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
|
||||
el "br" (return ())
|
||||
display =<< holdDyn "No number yet" (fmap tShow $ fmapMaybe reqSuccess dblResp)
|
||||
|
||||
elClass "div" "demo-group" $ do
|
||||
text "Multi-part path"
|
||||
b <- (current . value) <$> checkbox False def
|
||||
b <- value <$> checkbox False def
|
||||
mpGo <- button "Test"
|
||||
multiResp <- multi b mpGo
|
||||
dynText =<< holdDyn "No res yet" (fmap tShow $ fmapMaybe reqSuccess $ multiResp)
|
||||
|
@ -35,7 +35,7 @@ library
|
||||
reflex == 0.4.*,
|
||||
reflex-dom == 0.3.*,
|
||||
safe >= 0.3.9 && < 0.4,
|
||||
servant >= 0.5 && < 0.8,
|
||||
servant >= 0.5 && < 0.9,
|
||||
string-conversions >= 0.4 && < 0.5,
|
||||
text >= 1.2 && < 1.3,
|
||||
transformers >= 0.4 && < 0.5
|
||||
|
@ -71,28 +71,28 @@ qParamToQueryPart (QParamSome a) = Right (Just $ toQueryParam a)
|
||||
qParamToQueryPart QNone = Right Nothing
|
||||
qParamToQueryPart (QParamInvalid e) = Left e
|
||||
|
||||
data QueryPart t = QueryPartParam (Behavior t (Either Text (Maybe Text)))
|
||||
| QueryPartParams (Behavior t [Text])
|
||||
| QueryPartFlag (Behavior t Bool)
|
||||
data QueryPart t = QueryPartParam (Dynamic t (Either Text (Maybe Text)))
|
||||
| QueryPartParams (Dynamic t [Text])
|
||||
| QueryPartFlag (Dynamic t Bool)
|
||||
|
||||
data Req t = Req
|
||||
{ reqMethod :: Text
|
||||
, reqPathParts :: [Behavior t (Either Text Text)]
|
||||
, reqPathParts :: [Dynamic t (Either Text Text)]
|
||||
, qParams :: [(Text, QueryPart t)]
|
||||
, reqBody :: Maybe (Behavior t (Either Text (BL.ByteString, Text)))
|
||||
, reqBody :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
|
||||
-- , reqAccept :: [MediaType] -- TODO ?
|
||||
, headers :: [(Text, Behavior t Text)]
|
||||
, authData :: Maybe (Behavior t (Maybe BasicAuthData))
|
||||
, headers :: [(Text, Dynamic t Text)]
|
||||
, authData :: Maybe (Dynamic t (Maybe BasicAuthData))
|
||||
}
|
||||
|
||||
defReq :: Reflex t => Req t
|
||||
defReq = Req "GET" [] [] Nothing [] Nothing
|
||||
|
||||
prependToPathParts :: Reflex t => Behavior t (Either Text Text) -> Req t -> Req t
|
||||
prependToPathParts :: Reflex t => Dynamic t (Either Text Text) -> Req t -> Req t
|
||||
prependToPathParts p req =
|
||||
req { reqPathParts = p : reqPathParts req }
|
||||
|
||||
addHeader :: (ToHttpApiData a, Reflex t) => Text -> Behavior t (Either Text a) -> Req t -> Req t
|
||||
addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
|
||||
addHeader name val req = req { headers = headers req
|
||||
<> [(name, fmap (TE.decodeUtf8 . toHeader) val)]
|
||||
-- <> [(name, (fmap . fmap) (decodeUtf8 . toHeader) val)]
|
||||
@ -115,19 +115,19 @@ performRequest :: forall t m.MonadWidget t m
|
||||
performRequest reqMeth req reqHost trigger = do
|
||||
|
||||
-- Ridiculous functor-juggling! How to clean this up?
|
||||
let t :: Behavior t [Either Text Text]
|
||||
let t :: Dynamic t [Either Text Text]
|
||||
t = sequence $ reverse $ reqPathParts req
|
||||
|
||||
baseUrl :: Behavior t (Either Text Text)
|
||||
baseUrl = Right . showBaseUrl <$> current reqHost
|
||||
baseUrl :: Dynamic t (Either Text Text)
|
||||
baseUrl = Right . showBaseUrl <$> reqHost
|
||||
|
||||
urlParts :: Behavior t (Either Text [Text])
|
||||
urlParts :: Dynamic t (Either Text [Text])
|
||||
urlParts = fmap sequence t
|
||||
|
||||
urlPath :: Behavior t (Either Text Text)
|
||||
urlPath :: Dynamic t (Either Text Text)
|
||||
urlPath = (fmap.fmap) (T.intercalate "/") urlParts
|
||||
|
||||
queryPartString :: (Text, QueryPart t) -> Behavior t (Maybe (Either Text Text))
|
||||
queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
|
||||
queryPartString (pName, qp) = case qp of
|
||||
QueryPartParam p -> ffor p $ \case
|
||||
Left e -> Just (Left e)
|
||||
@ -142,10 +142,10 @@ performRequest reqMeth req reqHost trigger = do
|
||||
False -> Nothing
|
||||
|
||||
|
||||
queryPartStrings :: [Behavior t (Maybe (Either Text Text))]
|
||||
queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]
|
||||
queryPartStrings = map queryPartString (qParams req)
|
||||
queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Behavior t (Either Text [Text])
|
||||
queryString :: Behavior t (Either Text Text) =
|
||||
queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
|
||||
queryString :: Dynamic t (Either Text Text) =
|
||||
ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
|
||||
-- ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") (sequence qs)
|
||||
xhrUrl = (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q) baseUrl urlPath queryString
|
||||
@ -154,7 +154,7 @@ performRequest reqMeth req reqHost trigger = do
|
||||
x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
|
||||
| otherwise = x <> "/" <> y
|
||||
|
||||
xhrHeaders :: Behavior t [(Text, Text)]
|
||||
xhrHeaders :: Dynamic t [(Text, Text)]
|
||||
xhrHeaders = sequence $ ffor (headers req) $ \(hName, hVal) -> fmap (hName,) hVal
|
||||
|
||||
mkConfigBody :: [(Text,Text)] -> (Either Text (BL.ByteString, Text)) -> Either Text (XhrRequestConfig LT.Text)
|
||||
@ -165,7 +165,7 @@ performRequest reqMeth req reqHost trigger = do
|
||||
, _xhrRequestConfig_headers =
|
||||
Map.insert "Content-Type" bCT (_xhrRequestConfig_headers def)}
|
||||
|
||||
xhrOpts :: Behavior t (Either Text (XhrRequestConfig LT.Text))
|
||||
xhrOpts :: Dynamic t (Either Text (XhrRequestConfig LT.Text))
|
||||
xhrOpts = case reqBody req of
|
||||
Nothing -> fmap (\h -> Right $ XhrRequestConfig
|
||||
(Map.fromList h) Nothing Nothing Nothing "") xhrHeaders
|
||||
@ -178,14 +178,14 @@ performRequest reqMeth req reqHost trigger = do
|
||||
{ _xhrRequestConfig_user = Just $ TE.decodeUtf8 u
|
||||
, _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
|
||||
|
||||
addAuth :: Behavior t (Either Text (XhrRequestConfig x)) -> Behavior t (Either Text (XhrRequestConfig x))
|
||||
addAuth :: Dynamic t (Either Text (XhrRequestConfig x)) -> Dynamic t (Either Text (XhrRequestConfig x))
|
||||
addAuth xhr = case authData req of
|
||||
Nothing -> xhr
|
||||
Just auth -> liftA2 mkAuth auth xhr
|
||||
|
||||
xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
|
||||
|
||||
let reqs = tag xhrReq trigger
|
||||
let reqs = tagDyn xhrReq trigger
|
||||
okReqs = fmapMaybe (either (const Nothing) Just) reqs
|
||||
badReqs = fmapMaybe (either Just (const Nothing)) reqs
|
||||
|
||||
|
@ -47,7 +47,7 @@ import Reflex.Dom
|
||||
-- > myApi = Proxy
|
||||
-- >
|
||||
-- > getAllBooks :: Event t () -> m (Event t (Either XhrError ((),[Book])))
|
||||
-- > postNewBook :: Behavior t (Maybe Book) -> Event t ()
|
||||
-- > postNewBook :: Dynamic t (Maybe Book) -> Event t ()
|
||||
-- -> m (Event t (Either XhrError (Book,Book)))
|
||||
-- > (getAllBooks :<|> postNewBook) = client myApi host
|
||||
-- > where host = constDyn $ BaseUrl Http "localhost" 8080
|
||||
@ -76,7 +76,7 @@ instance (HasClient t m a, HasClient t m b) => HasClient t m (a :<|> b) where
|
||||
-- >
|
||||
-- > getBook :: MonadWidget t m
|
||||
-- => Dynamic t BaseUrl
|
||||
-- -> Behavior t (Maybe Text)
|
||||
-- -> Dynamic t (Maybe Text)
|
||||
-- -> Event t ()
|
||||
-- -> m (Event t (Either XhrError (Text, Book)))
|
||||
-- > getBook = client myApi (constDyn host)
|
||||
@ -84,7 +84,7 @@ instance (MonadWidget t m, KnownSymbol capture, ToHttpApiData a, HasClient t m s
|
||||
=> HasClient t m (Capture capture a :> sublayout) where
|
||||
|
||||
type Client t m (Capture capture a :> sublayout) =
|
||||
Behavior t (Either Text a) -> Client t m sublayout
|
||||
Dynamic t (Either Text a) -> Client t m sublayout
|
||||
|
||||
clientWithRoute Proxy q req baseurl val =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
@ -176,7 +176,7 @@ instance (KnownSymbol sym, ToHttpApiData a,
|
||||
=> HasClient t m (Header sym a :> sublayout) where
|
||||
|
||||
type Client t m (Header sym a :> sublayout) =
|
||||
Behavior t (Either Text a) -> Client t m sublayout
|
||||
Dynamic t (Either Text a) -> Client t m sublayout
|
||||
|
||||
clientWithRoute Proxy q req baseurl _ =
|
||||
clientWithRoute (Proxy :: Proxy sublayout)
|
||||
@ -231,7 +231,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
|
||||
|
||||
type Client t m (QueryParam sym a :> sublayout) =
|
||||
-- TODO (Maybe a), or (Maybe (Maybe a))? (should the user be able to send a Nothing)
|
||||
Behavior t (QParam a) -> Client t m sublayout
|
||||
Dynamic t (QParam a) -> Client t m sublayout
|
||||
|
||||
-- if mparam = Nothing, we don't add it to the query string
|
||||
clientWithRoute Proxy q req baseurl mparam =
|
||||
@ -276,7 +276,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
|
||||
=> HasClient t m (QueryParams sym a :> sublayout) where
|
||||
|
||||
type Client t m (QueryParams sym a :> sublayout) =
|
||||
Behavior t [a] -> Client t m sublayout
|
||||
Dynamic t [a] -> Client t m sublayout
|
||||
|
||||
clientWithRoute Proxy q req baseurl paramlist =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
|
||||
@ -315,7 +315,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
|
||||
=> HasClient t m (QueryFlag sym :> sublayout) where
|
||||
|
||||
type Client t m (QueryFlag sym :> sublayout) =
|
||||
Behavior t Bool -> Client t m sublayout
|
||||
Dynamic t Bool -> Client t m sublayout
|
||||
|
||||
clientWithRoute Proxy q req baseurl flag =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
|
||||
@ -329,7 +329,7 @@ instance (KnownSymbol sym, HasClient t m sublayout, Reflex t)
|
||||
-- back the full `Response`.
|
||||
-- TODO redo
|
||||
instance (MonadWidget t m) => HasClient t m Raw where
|
||||
type Client t m Raw = Behavior t (Either Text (XhrRequest ()))
|
||||
type Client t m Raw = Dynamic t (Either Text (XhrRequest ()))
|
||||
-> Event t ()
|
||||
-> m (Event t (ReqResult ()))
|
||||
|
||||
@ -340,8 +340,8 @@ instance (MonadWidget t m) => HasClient t m Raw where
|
||||
Right jx -> Right $ jx {_xhrRequest_url = path
|
||||
<> _xhrRequest_url jx})
|
||||
xhrs
|
||||
(showBaseUrl <$> current baseurl)
|
||||
reqs = tag xhrs' triggers
|
||||
(showBaseUrl <$> baseurl)
|
||||
reqs = tagDyn xhrs' triggers
|
||||
okReq = fmapMaybe hush reqs
|
||||
badReq = fmapMaybe tattle reqs
|
||||
resps <- performRequestAsync okReq
|
||||
@ -379,7 +379,7 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
|
||||
=> HasClient t m (ReqBody (ct ': cts) a :> sublayout) where
|
||||
|
||||
type Client t m (ReqBody (ct ': cts) a :> sublayout) =
|
||||
Behavior t (Either Text a) -> Client t m sublayout
|
||||
Dynamic t (Either Text a) -> Client t m sublayout
|
||||
|
||||
clientWithRoute Proxy q req baseurl body =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) q req' baseurl
|
||||
@ -397,7 +397,7 @@ instance (KnownSymbol path, HasClient t m sublayout, Reflex t) => HasClient t m
|
||||
|
||||
clientWithRoute Proxy q req baseurl =
|
||||
clientWithRoute (Proxy :: Proxy sublayout) q
|
||||
(prependToPathParts (constant (Right $ T.pack p)) req)
|
||||
(prependToPathParts (pure (Right $ T.pack p)) req)
|
||||
baseurl
|
||||
|
||||
where p = symbolVal (Proxy :: Proxy path)
|
||||
@ -423,7 +423,7 @@ instance HasClient t m api => HasClient t m (IsSecure :> api) where
|
||||
instance (HasClient t m api, Reflex t)
|
||||
=> HasClient t m (BasicAuth realm usr :> api) where
|
||||
|
||||
type Client t m (BasicAuth realm usr :> api) = Behavior t (Maybe BasicAuthData)
|
||||
type Client t m (BasicAuth realm usr :> api) = Dynamic t (Maybe BasicAuthData)
|
||||
-> Client t m api
|
||||
|
||||
clientWithRoute Proxy q req baseurl authdata =
|
||||
|
@ -12,6 +12,7 @@ import qualified Data.List as L
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Data.Text hiding (length, null, map, head, toUpper)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import Snap.Http.Server
|
||||
import Snap.Core
|
||||
@ -45,16 +46,17 @@ data App = App
|
||||
-- Each handler runs in the 'ExceptT ServantErr IO' monad.
|
||||
server :: Server API (Handler App App)
|
||||
server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDirectory "static"
|
||||
where sayhi nm greetings withGusto = case nm of
|
||||
Nothing -> return ("Sorry, who are you?" :: String)
|
||||
where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
|
||||
sayhi nm greetings withGusto = case nm of
|
||||
Nothing -> return ("Sorry, who are you?" :: Text)
|
||||
Just n -> do
|
||||
let modifier = bool id (map toUpper) withGusto
|
||||
let modifier = bool id T.toUpper withGusto
|
||||
greetPart
|
||||
| null greetings = "Hi, "
|
||||
| length greetings == 1 = L.head greetings ++ ", "
|
||||
| otherwise = L.intercalate ", " (L.init greetings)
|
||||
++ ", and " ++ L.last greetings ++ ", "
|
||||
return . modifier $ greetPart ++ n
|
||||
| length greetings == 1 = L.head greetings <> ", "
|
||||
| otherwise = T.intercalate ", " (L.init greetings)
|
||||
<> ", and " <> L.last greetings <> ", "
|
||||
return . modifier $ greetPart <> n
|
||||
dbl x = return $ x * 2
|
||||
multi = return . bool "Box unchecked" "Box Checked"
|
||||
|
||||
|
@ -19,6 +19,13 @@ executable back
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: aeson, base >=4.8 && <4.9, snap, snap-server, snap-core, servant, servant-snap, text
|
||||
build-depends: aeson >= 0.9 && < 0.12
|
||||
, base >=4.8 && <4.10
|
||||
, snap >= 1.0 && < 1.1
|
||||
, snap-server >= 1.0 && < 1.1
|
||||
, snap-core >= 1.0 && < 1.1
|
||||
, servant >= 0.7.1 && < 0.8
|
||||
, servant-snap
|
||||
, text >= 1.2 && < 1.3
|
||||
-- hs-source-dirs:
|
||||
default-language: Haskell2010
|
||||
|
32
testserver/tr.nix
Normal file
32
testserver/tr.nix
Normal file
@ -0,0 +1,32 @@
|
||||
{ reflex-platform, ... }:
|
||||
let
|
||||
|
||||
dontCheck = (import <nixpkgs> {}).pkgs.haskell.lib.dontCheck;
|
||||
cabal2nixResult = reflex-platform.cabal2nixResult;
|
||||
nixpkgs = (import <nixpkgs> {});
|
||||
in
|
||||
reflex-platform.ghc.override {
|
||||
overrides = self: super: {
|
||||
servant-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap) {});
|
||||
snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap) {});
|
||||
io-streams = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams) {});
|
||||
io-streams-haproxy = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/io-streams-haproxy) {});
|
||||
heist = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/heist) {});
|
||||
xmlhtml = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/xmlhtml) {});
|
||||
snap-core = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-core) {});
|
||||
snap-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap/deps/snap-server) {});
|
||||
snap-loader-static = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-static) {});
|
||||
snap-loader-dynamic = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/snap-loader-dynamic) {});
|
||||
hspec-snap = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/hspec-snap) {});
|
||||
|
||||
# servant-foreign = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-foreign) {});
|
||||
# servant-js = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-js) {});
|
||||
# servant-docs = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-docs) {});
|
||||
# servant-client = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-client) {});
|
||||
# servant-blaze = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-blaze) {});
|
||||
# servant-lucid = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-lucid) {});
|
||||
# servant-server = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant-server) {});
|
||||
# servant = dontCheck (self.callPackage (cabal2nixResult ../deps/servant-snap/deps/servant/servant) {});
|
||||
|
||||
};
|
||||
}
|
Loading…
Reference in New Issue
Block a user