ilyakooo0/servant-reflex
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-reflex.git synced 2024-09-11 07:15:29 +03:00
Code Issues Projects Releases Wiki Activity

added support for diacratic chars in json text, bumped servant upper bounds

Browse Source
This commit is contained in:
Schell Scivally 2017-02-27 11:46:08 -08:00
parent 183d8db62f
commit d72d6a7dec
11 changed files with 191 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -6,3 +6,4 @@ log
*.webapp
*.stats
out
reflex-platform

2
deps/servant vendored

@ -1 +1 @@
Subproject commit 2a21e14e6e4ec01a7eed2f0c617162adaa803ab7
Subproject commit be723b85bcae402a7da9f1f6e953ae552191d110

32
exec/API.hs
View File

@ -1,10 +1,32 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module API where
import Data.Text (Text)
import Servant.API
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Text (Text)
import Servant.API
newtype Question = Question { unQuestion :: Text } deriving (Show)
instance ToJSON Question where
toJSON (Question txt) = object ["question" .= txt]
instance FromJSON Question where
parseJSON (Object v) = Question <$> v .: "question"
parseJSON x = typeMismatch "Couldn't find key 'question'" x
newtype Answer = Answer { unAnswer :: Text } deriving (Show)
instance ToJSON Answer where
toJSON (Answer txt) = object ["answer" .= txt]
instance FromJSON Answer where
parseJSON (Object v) = Answer <$> v .: "answer"
parseJSON x = typeMismatch "Couldn't find key 'answer'" x
-- | API spec for server, client, and docs
type API = "getunit" :> Get '[JSON] ()
@ -16,6 +38,8 @@ type API = "getunit" :> Get '[JSON] ()
:<|> "double" :> ReqBody '[JSON] Double
:> Post '[JSON] Double
:<|> "a" :> "b" :> QueryFlag "gusto" :> Get '[JSON] Text
:<|> "qna" :> ReqBody '[JSON] Question
:> Post '[JSON] Answer
:<|> Raw
type GET = Get '[JSON] ()

19
exec/Example.hs
View File

@ -42,7 +42,7 @@ run = do
el "br" (return ())
-- Name the computed API client functions
let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> doRaw) =
let (getUnit :<|> getInt :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> doRaw) =
client api (Proxy :: Proxy m) url
elClass "div" "demo-group" $ do
@ -89,11 +89,11 @@ run = do
elClass "div" "demo-group" $ do
text "A Double to double"
el "br" $ return ()
dblinp <- fmap value $ divClass "double-input" $ textInput def
dblBtn <- divClass "double-button" $ button "Double it"
dblinp <- fmap value $ divClass "double-input" $ textInput def
dblBtn <- divClass "double-button" $ button "Double it"
dblResp <- dbl (fmap (note "read failure" . readMaybe . T.unpack) $
dblinp) dblBtn
divClass "double-errors" $ dynText =<<
divClass "double-errors" $ dynText =<<
holdDyn "(no errors)" (fmapMaybe reqFailure dblResp)
el "br" (return ())
divClass "double-result" $ el "p" $ dynText =<<
@ -109,6 +109,17 @@ run = do
fmapMaybe reqSuccess $
multiResp)
el "br" $ return ()
elClass "div" "demo-group" $ do
text "JSON Unicode encoding test"
txt <- value <$> textInput def
ev <- button "Question"
let dQ = Right . Question <$> traceDyn "will send: " txt
rr <- qna dQ ev
el "p" $
dynText =<< holdDyn "No Answer" (unAnswer <$> fmapMaybe reqSuccess rr)
showXhrResponse :: XhrResponse -> Text
showXhrResponse (XhrResponse stat stattxt rbmay rtmay respHeaders) =
T.unlines ["stat: " <> tShow stat

32
overrides-ghc.nix
View File

@ -1,10 +1,16 @@
{ reflex-platform, ... }:
let
let
pkgs = import <nixpkgs> {};
c2n = reflex-platform.cabal2nixResult;
in reflex-platform.ghc.override {
overrides = self: super: {
servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});
#servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap) {});
servant-snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n (pkgs.fetchFromGitHub {
owner = "schell";
repo = "servant-snap";
rev = "6732e7eebebcb25162924ba3d25fb37647d0749a";
sha256 = "07dh8ab1ffv5k6xik5m7zz6l3dcg6n1qbh8ndjnci0z2rim22asw";
})) {});
snap = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap) {});
snap-server = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-server) {});
io-streams = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/io-streams) {});
@ -13,6 +19,28 @@ in reflex-platform.ghc.override {
xmlhtml = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/xmlhtml) {});
snap-core = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant-snap/deps/snap/deps/snap-core) {});
servant = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/servant/servant) {});
Glob = pkgs.haskell.lib.dontCheck super.Glob;
natural-transformation = self.callPackage (
{ mkDerivation, base, containers, fetchgit, quickcheck-instances
, stdenv, tasty, tasty-quickcheck
}:
mkDerivation {
pname = "natural-transformation";
version = "0.4";
src = fetchgit {
url = "https://github.com/ku-fpg/natural-transformation";
sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";
rev = "b1200c09dcafd034e32846413913b74735c8ba56";
};
libraryHaskellDepends = [ base ];
testHaskellDepends = [
base containers quickcheck-instances tasty tasty-quickcheck
];
homepage = "https://github.com/ku-fpg/natural-transformation";
description = "A natural transformation package";
license = stdenv.lib.licenses.bsd3;
}
) {};
http-api-data = pkgs.haskell.lib.dontCheck (self.callPackage (c2n deps/http-api-data) {});
};
}

21
overrides.nix
View File

@ -10,5 +10,26 @@ reflex-platform.ghcjs.override {
overrides = self: super: {
servant = dontCheck (self.callPackage (cabal2nixResult deps/servant/servant) {});
http-api-data = dontCheck (self.callPackage (cabal2nixResult deps/http-api-data) {});
natural-transformation = self.callPackage (
{ mkDerivation, base, containers, fetchgit, quickcheck-instances
, stdenv, tasty, tasty-quickcheck
}:
mkDerivation {
pname = "natural-transformation";
version = "0.4";
src = fetchgit {
url = "https://github.com/ku-fpg/natural-transformation";
sha256 = "0xbnnxbf5ydszbhf7h5ra3mrqy4mcyqc3zb2k8bwm1zyqrz6v0fs";
rev = "b1200c09dcafd034e32846413913b74735c8ba56";
};
libraryHaskellDepends = [ base ];
testHaskellDepends = [
base containers quickcheck-instances tasty tasty-quickcheck
];
homepage = "https://github.com/ku-fpg/natural-transformation";
description = "A natural transformation package";
license = stdenv.lib.licenses.bsd3;
}
) {};
};
}

7
servant-reflex.cabal
View File

@ -1,5 +1,5 @@
Name: servant-reflex
Version: 0.2
Version: 0.3.0
Synopsis: Servant reflex API generator
Description: Servant reflex API generator
License: AllRightsReserved
@ -21,6 +21,7 @@ library
hs-source-dirs: src
build-depends:
aeson,
base >= 4.8 && < 4.10,
bytestring >= 0.10 && < 0.11,
case-insensitive >= 1.2.0.4 && < 1.3,
@ -35,7 +36,7 @@ library
reflex >= 0.5 && < 0.6,
reflex-dom == 0.4 && < 0.5,
safe >= 0.3.9 && < 0.4,
servant >= 0.5 && < 0.9,
servant >= 0.8 && < 0.11,
string-conversions >= 0.4 && < 0.5,
text >= 1.2 && < 1.3,
transformers >= 0.4 && < 0.6
@ -45,7 +46,7 @@ library
default-language: Haskell2010
executable example
build-depends: reflex, servant-reflex, base, scientific, servant, reflex-dom, text
build-depends: aeson, reflex, servant-reflex, base, scientific, servant, reflex-dom, text
default-language: Haskell2010
main-is: Example.hs
other-modules: API

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

@ -210,15 +210,9 @@ performRequest reqMeth req reqHost trigger = do
return (resps, badReqs)
#ifdef ghcjs_HOST_OS
type XhrPayload = String
bytesToPayload :: BL.ByteString -> XhrPayload
bytesToPayload = BL.unpack
#else
type XhrPayload = T.Text
bytesToPayload :: BL.ByteString -> XhrPayload
bytesToPayload = T.pack . BL.unpack
#endif
bytesToPayload = TE.decodeUtf8 . BL.toStrict
performRequestNoBody :: forall t m .(SupportsServantReflex t m)
=> Text

129
src/Servant/Reflex.hs
View File

@ -1,16 +1,16 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- #include "overlapping-compat.h"
-- | This module provides 'client' which can automatically generate
@ -25,42 +25,42 @@ module Servant.Reflex
-------------------------------------------------------------------------------
import Control.Applicative
import Data.Monoid ((<>))
import qualified Data.Set as Set
import qualified Data.Text.Encoding as E
import Data.CaseInsensitive (mk)
import Data.Proxy (Proxy (..))
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import GHC.TypeLits (KnownSymbol, symbolVal)
import Servant.API ((:<|>)(..),(:>), BasicAuth,
BasicAuthData, BuildHeadersTo(..),
Capture, contentType, Header,
Headers(..), HttpVersion, IsSecure,
MimeRender(..), MimeUnrender,
NoContent, QueryFlag, QueryParam,
QueryParams, Raw, ReflectMethod(..),
RemoteHost, ReqBody,
ToHttpApiData(..), Vault, Verb)
import Servant.Common.BaseUrl (BaseUrl(..), Scheme(..), baseUrlWidget,
showBaseUrl,
SupportsServantReflex)
import Servant.Common.Req (Req, ReqResult(..), QParam(..),
QueryPart(..), addHeader, authData,
defReq, prependToPathParts,
performRequestCT,
performRequestNoBody,
qParamToQueryPart, reqBody,
reqSuccess, reqFailure,
reqMethod, respHeaders, response,
qParams)
import Reflex.Dom (Dynamic, Event, Reflex,
XhrRequest(..),
XhrResponseHeaders(..),
XhrResponse(..), ffor, fmapMaybe,
leftmost, performRequestAsync,
tagPromptlyDyn )
import Data.Aeson (ToJSON, encode)
import Data.CaseInsensitive (mk)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Debug.Trace (traceShow)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Reflex.Dom (Dynamic, Event, Reflex,
XhrRequest (..), XhrResponse (..),
XhrResponseHeaders (..), ffor,
fmapMaybe, leftmost,
performRequestAsync, tagPromptlyDyn)
import Servant.API ((:<|>) (..), (:>), BasicAuth,
BasicAuthData, BuildHeadersTo (..),
Capture, Header, Headers (..),
HttpVersion, IsSecure, MimeRender (..),
MimeUnrender, NoContent, QueryFlag,
QueryParam, QueryParams, Raw,
ReflectMethod (..), RemoteHost,
ReqBody, ToHttpApiData (..), Vault,
Verb, contentType)
import Servant.Common.BaseUrl (BaseUrl (..), Scheme (..),
SupportsServantReflex, baseUrlWidget,
showBaseUrl)
import Servant.Common.Req (QParam (..), QueryPart (..), Req,
ReqResult (..), addHeader, authData,
defReq, performRequestCT,
performRequestNoBody,
prependToPathParts, qParamToQueryPart,
qParams, reqBody, reqFailure,
reqMethod, reqSuccess, respHeaders,
response)
-- * Accessing APIs as a Client
@ -79,7 +79,7 @@ import Reflex.Dom (Dynamic, Event, Reflex,
-- > where host = constDyn $ BaseUrl Http "localhost" 8080
client :: (HasClient t m layout)
=> Proxy layout -> Proxy m -> Dynamic t BaseUrl -> Client t m layout
client p q baseurl = clientWithRoute p q defReq baseurl
client p q = clientWithRoute p q defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
@ -118,7 +118,7 @@ instance (SupportsServantReflex t m, ToHttpApiData a, HasClient t m sublayout)
(prependToPathParts p req)
baseurl
where p = (fmap . fmap) (toUrlPiece) val
where p = (fmap . fmap) toUrlPiece val
-- VERB (Returning content) --
instance {-# OVERLAPPABLE #-}
@ -129,8 +129,8 @@ instance {-# OVERLAPPABLE #-}
Event t () -> m (Event t (ReqResult a))
-- TODO how to access input types here?
-- ExceptT ServantError IO a
clientWithRoute Proxy _ req baseurl =
performRequestCT (Proxy :: Proxy ct) method req' baseurl
clientWithRoute Proxy _ req =
performRequestCT (Proxy :: Proxy ct) method req'
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
req' = req { reqMethod = method }
@ -142,8 +142,8 @@ instance {-# OVERLAPPING #-}
Event t () -> m (Event t (ReqResult NoContent))
-- TODO: how to access input types here?
-- ExceptT ServantError IO NoContent
clientWithRoute Proxy _ req baseurl =
performRequestNoBody method req baseurl
clientWithRoute Proxy _ =
performRequestNoBody method
where method = E.decodeUtf8 $ reflectMethod (Proxy :: Proxy method)
toHeaders :: BuildHeadersTo ls => ReqResult a -> ReqResult (Headers ls a)
@ -163,7 +163,7 @@ instance {-# OVERLAPPABLE #-} BuildHeaderKeysTo '[]
instance {-# OVERLAPPABLE #-} (BuildHeaderKeysTo xs, KnownSymbol h)
=> BuildHeaderKeysTo '[(Header h v) ': xs] where
buildHeaderKeysTo _ = (T.pack $ symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
buildHeaderKeysTo _ = T.pack (symbolVal (Proxy :: Proxy h)) : buildHeaderKeysTo (Proxy :: Proxy xs)
-- HEADERS Verb (Content) --
-- Headers combinator not treated in fully general case,
@ -237,8 +237,7 @@ instance HasClient t m sublayout
type Client t m (HttpVersion :> sublayout) =
Client t m sublayout
clientWithRoute Proxy q =
clientWithRoute (Proxy :: Proxy sublayout) q
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy sublayout)
-- | If you use a 'QueryParam' in one of your endpoints in your API,
@ -323,7 +322,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient t m sublayout, Reflex t)
where req' = req { qParams = (T.pack pname, params') : qParams req }
pname = symbolVal (Proxy :: Proxy sym)
params' = QueryPartParams $ (fmap . fmap) (toQueryParam)
params' = QueryPartParams $ (fmap . fmap) toQueryParam
paramlist
@ -415,7 +414,7 @@ tattle = either Just (const Nothing)
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
instance (Show a, ToJSON a, 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) =
@ -434,30 +433,26 @@ instance (MimeRender ct a, HasClient t m sublayout, Reflex t)
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 q req baseurl =
clientWithRoute Proxy q req =
clientWithRoute (Proxy :: Proxy sublayout) q
(prependToPathParts (pure (Right $ T.pack p)) req)
baseurl
where p = symbolVal (Proxy :: Proxy path)
instance HasClient t m api => HasClient t m (Vault :> api) where
type Client t m (Vault :> api) = Client t m api
clientWithRoute Proxy q req baseurl =
clientWithRoute (Proxy :: Proxy api) q req baseurl
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
instance HasClient t m api => HasClient t m (RemoteHost :> api) where
type Client t m (RemoteHost :> api) = Client t m api
clientWithRoute Proxy q req baseurl =
clientWithRoute (Proxy :: Proxy api) q req baseurl
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
instance HasClient t m api => HasClient t m (IsSecure :> api) where
type Client t m (IsSecure :> api) = Client t m api
clientWithRoute Proxy q req baseurl =
clientWithRoute (Proxy :: Proxy api) q req baseurl
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy api)
instance (HasClient t m api, Reflex t)
=> HasClient t m (BasicAuth realm usr :> api) where

26
testserver/Main.hs
View File

@ -5,24 +5,27 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.Bool
import Data.Char (toUpper)
import qualified Data.List as L
import Data.Char (toUpper)
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 Data.Text hiding (head, length, map,
null, toUpper)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import GHC.Generics
import Snap.Http.Server
import Snap.Core
import Servant.Server.Internal.SnapShims
import Snap.Core
import Snap.Http.Server
import Servant -- hiding (serveDirectory)
import Servant
import Servant.Server
-- import Snap.Util.FileServe
import API
import Snap
import Snap
-- * Example
@ -45,7 +48,7 @@ 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"
server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> qna :<|> serveDirectory "static"
where sayhi :: Maybe Text -> [Text] -> Bool -> Handler App App Text
sayhi nm greetings withGusto = case nm of
Nothing -> return ("Sorry, who are you?" :: Text)
@ -59,6 +62,11 @@ server = return () :<|> return 100 :<|> sayhi :<|> dbl :<|> multi :<|> serveDire
return . modifier $ greetPart <> n
dbl x = return $ x * 2
multi = return . bool "Box unchecked" "Box Checked"
qna q = do
liftIO $ do
putStrLn $ "qna got: " ++ show q
T.putStrLn $ unQuestion q
return $ Answer $ unQuestion q
-- Turn the server into a WAI app. 'serve' is provided by servant,
-- more precisely by the Servant.Server module.

22
testserver/testserver.cabal
View File

@ -1,31 +1,31 @@
-- Initial back.cabal generated by cabal init. For further documentation,
-- Initial back.cabal generated by cabal init. For further documentation,
-- see http://haskell.org/cabal/users-guide/
name: testserver
version: 0.1.0.0
-- synopsis:
-- description:
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Greg Hale
maintainer: imalsogreg@gmail.com
-- copyright:
-- category:
-- copyright:
-- category:
build-type: Simple
-- extra-source-files:
-- extra-source-files:
cabal-version: >=1.10
executable back
main-is: Main.hs
-- other-modules:
-- other-extensions:
-- other-modules:
-- other-extensions:
build-depends: aeson >= 0.9 && < 1.1
, 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.9
, servant-snap >= 0.7 && < 0.8
, servant >= 0.10 && < 0.11
, servant-snap >= 0.7.2 && < 0.8
, text >= 1.2 && < 1.3
-- hs-source-dirs:
-- hs-source-dirs:
default-language: Haskell2010