ilyakooo0/servant-reflex
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-reflex.git synced 2024-10-26 02:11:36 +03:00
Code Issues Projects Releases Wiki Activity

Dynamic servant api, tagDyn to catch most recent parameters; update example

Browse Source
This commit is contained in:
Greg Hale 2016-07-19 12:25:58 -04:00
parent d8a9c572ce
commit 2cd77cf982
7 changed files with 91 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
exec/Example.hs
View File

@ -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)

2
servant-reflex.cabal
View File

@ -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

44
src/Servant/Common/Req.hs
View File

@ -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

26
src/Servant/Reflex.hs
View File

@ -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 =

16
testserver/Main.hs
View File

@ -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"

9
testserver/testserver.cabal
View File

@ -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
View 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) {});
};
}