mirror of
https://github.com/ilyakooo0/servant-reflex.git
synced 2024-09-11 07:15:29 +03:00
added support for diacratic chars in json text, bumped servant upper bounds
This commit is contained in:
parent
183d8db62f
commit
d72d6a7dec
1
.gitignore
vendored
1
.gitignore
vendored
@ -6,3 +6,4 @@ log
|
||||
*.webapp
|
||||
*.stats
|
||||
out
|
||||
reflex-platform
|
||||
|
2
deps/servant
vendored
2
deps/servant
vendored
@ -1 +1 @@
|
||||
Subproject commit 2a21e14e6e4ec01a7eed2f0c617162adaa803ab7
|
||||
Subproject commit be723b85bcae402a7da9f1f6e953ae552191d110
|
32
exec/API.hs
32
exec/API.hs
@ -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] ()
|
||||
|
@ -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
|
||||
|
@ -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) {});
|
||||
};
|
||||
}
|
||||
|
@ -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;
|
||||
}
|
||||
) {};
|
||||
};
|
||||
}
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user