From 9473d86eaeec1a4db16751dc0f9d0c4329ef3d25 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Thu, 3 Aug 2017 18:13:12 +0100 Subject: [PATCH 01/45] Instance of Generic for Value already exists with aeson update --- solga/test/Test.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/solga/test/Test.hs b/solga/test/Test.hs index 4ed30aa..331a901 100644 --- a/solga/test/Test.hs +++ b/solga/test/Test.hs @@ -93,7 +93,6 @@ spec = with (return $ serve testAPI) $ do resp <- get path liftIO $ decode (simpleBody resp) `shouldBe` Just (String seg) -deriving instance Generic Value instance Arbitrary Value where arbitrary = sized arbJSON @@ -133,4 +132,4 @@ instance Arbitrary a => Arbitrary (V.Vector a) where instance Arbitrary S.Scientific where arbitrary = S.scientific <$> arbitrary <*> arbitrary - shrink s = map (uncurry S.scientific) $ shrink $ ( S.coefficient s, S.base10Exponent s ) \ No newline at end of file + shrink s = map (uncurry S.scientific) $ shrink $ ( S.coefficient s, S.base10Exponent s ) From 9daa604b59f53faa567fe5e20f70d9fcefdbe4cb Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Thu, 3 Aug 2017 18:30:10 +0100 Subject: [PATCH 02/45] Updated resolver to Nightly 2017-07-31 to get to ghc-8.2.1 After running stack solver, the following changes were made: removed: safe-exceptions-0.1.1.0 added: swagger2-2.1.4.1 http-media-0.7.1.1 --- stack.yaml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 69ac7ac..df0223f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: nightly-2016-11-07 +resolver: nightly-2017-07-31 # Local packages, usually specified by relative directory name packages: @@ -10,7 +10,8 @@ packages: # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: -- safe-exceptions-0.1.1.0 +- swagger2-2.1.4.1 +- http-media-0.7.1.1 # Override default flag values for local packages and extra-deps flags: {} From 10daf8298a0829d7af58616035d9e2a792527e22 Mon Sep 17 00:00:00 2001 From: Fintan Halpenny Date: Thu, 3 Aug 2017 18:32:14 +0100 Subject: [PATCH 03/45] Added equational constraint as a solution to build error --- solga/src/Solga.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/solga/src/Solga.hs b/solga/src/Solga.hs index 43f212a..d929e3d 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -283,7 +283,7 @@ class Abbreviated a where type Brief a :: * type instance Brief a = a brief :: Brief a -> a - default brief :: a -> a + default brief :: Brief a ~ a => Brief a -> a brief = id instance Abbreviated Raw where From c2e227d89f729779789c9c4387eeff6d6d68b99d Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Mon, 14 Aug 2017 13:43:37 +0200 Subject: [PATCH 04/45] Fix build with Aeson 1.2.1.0. --- solga/solga.cabal | 2 +- solga/src/Solga.hs | 9 ++++++++- solga/test/Test.hs | 2 -- stack.yaml | 3 ++- 4 files changed, 11 insertions(+), 5 deletions(-) diff --git a/solga/solga.cabal b/solga/solga.cabal index 50bcf49..74ed628 100644 --- a/solga/solga.cabal +++ b/solga/solga.cabal @@ -21,7 +21,7 @@ library wai, bytestring, containers, - aeson >= 1.0.0.0, + aeson >= 1.2.1.0, wai-extra, http-types, resourcet, diff --git a/solga/src/Solga.hs b/solga/src/Solga.hs index 43f212a..58582b5 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -42,6 +42,7 @@ module Solga , SolgaError , badRequest , notFound + , internalServerError -- * Router implementation , Router(..) , Responder @@ -54,7 +55,6 @@ import Control.Exception.Safe import Control.Monad import Control.Monad.Trans.Resource import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Encode as Aeson import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as Char8 import qualified Data.Map.Strict as Map @@ -372,3 +372,10 @@ notFound msg = SolgaError { errorStatus = HTTP.notFound404 , errorMessage = msg } + +-- | Create a @500 Internal Server Error@ error with a given message. +internalServerError :: Text.Text -> SolgaError +internalServerError msg = SolgaError + { errorStatus = HTTP.internalServerError500 + , errorMessage = msg + } diff --git a/solga/test/Test.hs b/solga/test/Test.hs index 4ed30aa..26a97d2 100644 --- a/solga/test/Test.hs +++ b/solga/test/Test.hs @@ -93,8 +93,6 @@ spec = with (return $ serve testAPI) $ do resp <- get path liftIO $ decode (simpleBody resp) `shouldBe` Just (String seg) -deriving instance Generic Value - instance Arbitrary Value where arbitrary = sized arbJSON where diff --git a/stack.yaml b/stack.yaml index 69ac7ac..acf539a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: nightly-2016-11-07 +resolver: lts-9.0 # Local packages, usually specified by relative directory name packages: @@ -11,6 +11,7 @@ packages: # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: - safe-exceptions-0.1.1.0 +- aeson-1.2.1.0 # Override default flag values for local packages and extra-deps flags: {} From c7564bca7a4dabe77d63822dfda0321b23176c65 Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Mon, 14 Aug 2017 13:58:45 +0200 Subject: [PATCH 05/45] Add 401 Unauthorized. --- solga/src/Solga.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/solga/src/Solga.hs b/solga/src/Solga.hs index 58582b5..dea9aeb 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -41,6 +41,7 @@ module Solga -- * Error handling , SolgaError , badRequest + , unauthorized , notFound , internalServerError -- * Router implementation @@ -366,6 +367,13 @@ badRequest msg = SolgaError , errorMessage = msg } +-- | Create a @401 Unauthorized@ error with a given message. +unauthorized :: Text.Text -> SolgaError +unauthorized msg = SolgaError + { errorStatus = HTTP.unauthorized401 + , errorMessage = msg + } + -- | Create a @404 Not Found@ error with a given message. notFound :: Text.Text -> SolgaError notFound msg = SolgaError From 4ec02f2c938200bc5ef9f1b1f9e92600abe95d6d Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Mon, 14 Aug 2017 14:18:25 +0200 Subject: [PATCH 06/45] Add 403 Forbidden. --- solga/src/Solga.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/solga/src/Solga.hs b/solga/src/Solga.hs index dea9aeb..d95ff47 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -42,6 +42,7 @@ module Solga , SolgaError , badRequest , unauthorized + , forbidden , notFound , internalServerError -- * Router implementation @@ -374,6 +375,13 @@ unauthorized msg = SolgaError , errorMessage = msg } +-- | Create a @403 Forbidden@ error with a given message. +forbidden :: Text.Text -> SolgaError +forbidden msg = SolgaError + { errorStatus = HTTP.forbidden403 + , errorMessage = msg + } + -- | Create a @404 Not Found@ error with a given message. notFound :: Text.Text -> SolgaError notFound msg = SolgaError From bf91768c2908fe767357c760f8818b6324f556ec Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Thu, 7 Sep 2017 00:10:22 +0200 Subject: [PATCH 07/45] split datatypes definitions out from router... ...in preparation to ghcjs client side library, which we do not want to burden with inappropriate dependencies such as wai. --- solga-core/LICENSE | 20 ++ solga-core/Setup.hs | 2 + solga-core/solga-core.cabal | 25 ++ solga-core/src/Solga/Core.hs | 142 ++++++++++ solga-router/LICENSE | 20 ++ solga-router/Setup.hs | 2 + solga-router/solga-router.cabal | 56 ++++ solga-router/src/Solga/Router.hs | 289 +++++++++++++++++++++ {solga => solga-router}/test/Test.hs | 3 +- solga-swagger/solga-swagger.cabal | 2 +- solga-swagger/src/Solga/Swagger.hs | 8 +- solga/solga.cabal | 36 +-- solga/src/Solga.hs | 375 +-------------------------- stack.yaml | 2 + 14 files changed, 572 insertions(+), 410 deletions(-) create mode 100644 solga-core/LICENSE create mode 100644 solga-core/Setup.hs create mode 100644 solga-core/solga-core.cabal create mode 100644 solga-core/src/Solga/Core.hs create mode 100644 solga-router/LICENSE create mode 100644 solga-router/Setup.hs create mode 100644 solga-router/solga-router.cabal create mode 100644 solga-router/src/Solga/Router.hs rename {solga => solga-router}/test/Test.hs (98%) diff --git a/solga-core/LICENSE b/solga-core/LICENSE new file mode 100644 index 0000000..a31a05d --- /dev/null +++ b/solga-core/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Patrick Chilton + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/solga-core/Setup.hs b/solga-core/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/solga-core/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/solga-core/solga-core.cabal b/solga-core/solga-core.cabal new file mode 100644 index 0000000..054cf86 --- /dev/null +++ b/solga-core/solga-core.cabal @@ -0,0 +1,25 @@ +name: solga-core +version: 0.1.0.0 +synopsis: Simple typesafe web routing +description: A library for easily specifying web APIs and implementing them in a type-safe way. +license: MIT +license-file: LICENSE +author: Patrick Chilton +maintainer: chpatrick@gmail.com +copyright: Copyright (C) 2016 Patrick Chilton +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.Core + build-depends: base >= 4.8 && < 5, + case-insensitive, + bytestring + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs new file mode 100644 index 0000000..c154b6e --- /dev/null +++ b/solga-core/src/Solga/Core.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +module Solga.Core + ( -- * Path components + type (:>), type (/>) + , Get + , Post + , JSON(..) + , Raw(..) + , RawResponse(..) + , End(..) + , WithIO(..) + , Seg(..) + , OneOfSegs(..) + , Capture(..) + , Method(..) + , HeaderName + , Header + , ResponseHeaders + , ExtraHeaders(..) + , NoCache(..) + , ReqBodyJSON(..) + , MultiPartParam + , MultiPartFile + , MultiPartFileInfo(..) + , MultiPartData + , ReqBodyMultipart(..) + , Endpoint + , (:<|>)(..) + ) where + +import GHC.TypeLits +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) + +--------------------------------------------------- + +-- | Compose routers. This is just type application, +-- ie.: @Foo :> Bar :> Baz == Foo (Bar Baz)@ +type f :> g = f g +infixr 2 :> + +-- | Serve a given WAI `Wai.Application`. +newtype Raw a = Raw { rawApp :: a } + +-- | Serve a given WAI `Wai.Response`. +newtype RawResponse a = RawResponse { rawResponse :: a } + +-- | Only accept the end of a path. +newtype End next = End { endNext :: next } + +-- | Match a constant directory in the path. +-- +-- When specifying APIs, use the `/>` combinator to specify sub-paths: +-- @"foo" `/>` `JSON` Bar@ +newtype Seg (seg :: Symbol) next = Seg { segNext :: next } + deriving (Eq, Ord, Show) + +-- | Match a path, segment, e.g @"foo" `/>` `JSON` Bar@ +type seg /> g = Seg seg :> g +infixr 2 /> + +-- | Try to route with @left@, or try to route with @right@. +data left :<|> right = (:<|>) { altLeft :: left, altRight :: right } + deriving (Eq, Ord, Show) + +infixr 1 :<|> + +-- | Match any of a set of path segments. +data OneOfSegs (segs :: [ Symbol ]) next = OneOfSegs { oneOfSegsNext :: next } + +-- | Capture a path segment and pass it on. +newtype Capture a next = Capture { captureNext :: a -> next } + +-- | Accepts requests with a certain method. +newtype Method (method :: Symbol) next = Method { methodNext :: next } + deriving (Eq, Ord, Show) + +-- | Return a given JSON object +newtype JSON a = JSON { jsonResponse :: a } + deriving (Eq, Ord, Show) + +type HeaderName = CI ByteString +type Header = (HeaderName, ByteString) +type ResponseHeaders = [Header] + +-- | Set extra headers on responses. +-- Existing headers will be overriden if specified here. +data ExtraHeaders next = ExtraHeaders + { extraHeaders :: ResponseHeaders + , extraHeadersNext :: next + } + +-- | Prevent caching for sub-routers. +newtype NoCache next = NoCache { noCacheNext :: next } + +-- | Parse a JSON request body. +newtype ReqBodyJSON a next = ReqBodyJSON { reqBodyJSONNext :: a -> next } + +-- | Produce a response with `IO`. +newtype WithIO next = WithIO { withIONext :: IO next } + +type MultiPartParam = (ByteString, ByteString) +type MultiPartFile y = (ByteString, MultiPartFileInfo y) + +data MultiPartFileInfo c = MultiPartFileInfo + { mpfiName :: ByteString + , mpfiContentType :: ByteString + , mpfiContent :: FilePath + } + +-- | A parsed "multipart/form-data" request. +type MultiPartData y = ([MultiPartParam], [MultiPartFile y]) + +-- | Accept a "multipart/form-data" request. +-- Files will be stored in a temporary directory and will be deleted +-- automatically after the request is processed. +data ReqBodyMultipart y a next = ReqBodyMultipart + { reqMultiPartParse :: MultiPartData y -> Either String a + , reqMultiPartNext :: a -> next + } + +-- | Useful synonym for dynamic endpoints: accept requests with a given method, compute a JSON response in `IO` and don't cache. +type Endpoint method a = End :> NoCache :> Method method :> WithIO :> a + +-- | Handle a "GET" request and produce a "JSON" response, with `IO`. +type Get a = Endpoint "GET" (JSON a) +-- | Handle a "POST" request and produce a "JSON" response, with `IO`. +type Post a = Endpoint "POST" (JSON a) + diff --git a/solga-router/LICENSE b/solga-router/LICENSE new file mode 100644 index 0000000..a31a05d --- /dev/null +++ b/solga-router/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Patrick Chilton + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/solga-router/Setup.hs b/solga-router/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/solga-router/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/solga-router/solga-router.cabal b/solga-router/solga-router.cabal new file mode 100644 index 0000000..79cfcef --- /dev/null +++ b/solga-router/solga-router.cabal @@ -0,0 +1,56 @@ +name: solga-router +version: 0.1.0.0 +synopsis: Simple typesafe web routing +description: A library for easily specifying web APIs and implementing them in a type-safe way. +license: MIT +license-file: LICENSE +author: Patrick Chilton +maintainer: chpatrick@gmail.com +copyright: Copyright (C) 2016 Patrick Chilton +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.Router + build-depends: base >= 4.8 && < 5, + solga-core, + text, + wai, + bytestring, + containers, + aeson >= 1.0.0.0, + wai-extra, + http-types, + resourcet, + safe-exceptions + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite solga-router-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base + , solga-router + , solga-core + , text + , bytestring + , wai + , wai-extra + , aeson + , hspec + , hspec-wai + , hspec-wai-json + , http-types + , unordered-containers + , hashable + , vector + , scientific + , QuickCheck diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs new file mode 100644 index 0000000..7844574 --- /dev/null +++ b/solga-router/src/Solga/Router.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +module Solga.Router + ( -- * Serving APIs + serve, serveThrow + -- * Abbreviation + , Abbreviated(..) + -- * Error handling + , SolgaError + , badRequest + , notFound + -- * Router implementation + , FromSegment(..) + , Router(..) + , Responder + , tryRouteNext + , tryRouteNextIO + ) where + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Trans.Resource +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Map.Strict as Map +import Data.Monoid +import Data.Proxy +import qualified Data.Text as Text +import Data.Text.Encoding +import GHC.Generics +import GHC.TypeLits +import qualified Network.Wai as Wai +import qualified Network.Wai.Parse as Wai +import qualified Network.HTTP.Types as HTTP + +import Solga.Core + +--------------------------------------------------- + +-- | The right hand side of `Application`. `Request` is already known. +type Responder = (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived + +-- | Routers are the basic typeclass of Solga: their types describe +-- what type of requests they accept, and their values describe how to handle them. +-- +-- You can use `Generic` to get free instance of `Router` for any data type with one constructor +-- and `Router`s as fields. The fields will be considered alternatives, as if you wrote `:<|>` between them. +class Router r where + -- | Given a request, if the router supports the given request + -- return a function that constructs a response with a concrete router. + tryRoute :: Wai.Request -> Maybe (r -> Responder) + default tryRoute :: (Generic r, Router (Rep r ())) => Wai.Request -> Maybe (r -> Responder) + tryRoute = tryRouteNext (from :: r -> Rep r ()) + +-- | Try to route using a type @r@ by providing a function to turn it into a `Router` @r'@. +-- Useful for passing routing on to the next step. +tryRouteNext :: Router r' => (r -> r') -> Wai.Request -> Maybe (r -> Responder) +tryRouteNext f req = (. f) <$> tryRoute req + +-- | Like `tryRouteNext` but in `IO`. +tryRouteNextIO :: Router r' => (r -> IO r') -> Wai.Request -> Maybe (r -> Responder) +tryRouteNextIO f req = do + nextRouter <- tryRoute req + Just $ \router cont -> do + next <- f router + nextRouter next cont + +-- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses and other errors as HTTP 500. +serve :: Router r => r -> Wai.Application +serve router req cont = + serveThrow router req cont + `catchAny` \someEx -> + let + ( status, body ) = case fromException someEx of + Just SolgaError { errorStatus, errorMessage } -> ( errorStatus, Builder.byteString $ encodeUtf8 errorMessage ) + Nothing -> ( HTTP.internalServerError500, "Internal Server Error" ) + in cont $ Wai.responseBuilder status [] body + +-- | Serve a `Router` with Solga, throwing `SolgaError`s. +serveThrow :: Router r => r -> Wai.Application +serveThrow router req cont = case tryRoute req of + Nothing -> throwIO $ notFound "" + Just r -> r router cont + +instance (a ~ Wai.Application) => Router (Raw a) where + tryRoute req = Just $ \(Raw app) -> app req + +instance (a ~ Wai.Response) => Router (RawResponse a) where + tryRoute _ = Just $ \(RawResponse response) cont -> cont response + +instance Router next => Router (End next) where + tryRoute req = case Wai.pathInfo req of + [] -> tryRouteNext endNext req + _ -> Nothing + +instance (KnownSymbol seg, Router next) => Router (Seg seg next) where + tryRoute req = case Wai.pathInfo req of + s : segs | Text.unpack s == symbolVal (Proxy :: Proxy seg) -> + tryRouteNext segNext req { Wai.pathInfo = segs } + _ -> Nothing + +instance (Router left, Router right) => Router (left :<|> right) where + tryRoute req = tryRouteNext altLeft req <|> tryRouteNext altRight req + +instance (KnownSymbol seg, Router next, Router (OneOfSegs segs next)) => Router (OneOfSegs (seg ': segs) next) where + tryRoute = tryRouteNext $ \(OneOfSegs next) -> (Seg next :: Seg seg next) :<|> (OneOfSegs next :: OneOfSegs segs next) + +instance Router next => Router (OneOfSegs '[] next) where + tryRoute _ = Nothing + +-- | The class of types that can be parsed from a path segment. +class FromSegment a where + fromSegment :: Text.Text -> Maybe a + +instance FromSegment Text.Text where + fromSegment = Just + +instance (FromSegment a, Router next) => Router (Capture a next) where + tryRoute req = case Wai.pathInfo req of + seg : segs -> do + capture <- fromSegment seg + tryRouteNext (\c -> captureNext c capture) req { Wai.pathInfo = segs } + _ -> Nothing + +instance (KnownSymbol method, Router next) => Router (Method method next) where + tryRoute req = do + guard (Char8.unpack (Wai.requestMethod req) == symbolVal (Proxy :: Proxy method)) + tryRouteNext methodNext req + +instance Aeson.ToJSON a => Router (JSON a) where + tryRoute _ = Just $ \json cont -> + cont $ Wai.responseBuilder HTTP.status200 headers $ Aeson.fromEncoding $ Aeson.toEncoding $ jsonResponse json + where headers = [ ( HTTP.hContentType, "application/json" ) ] + +instance Router next => Router (ExtraHeaders next) where + tryRoute req = do + nextRouter <- tryRoute req + return $ \(ExtraHeaders headers next) cont -> do + let addHeaders oldHeaders = Map.assocs (Map.fromList headers `Map.union` Map.fromList oldHeaders) + nextRouter next $ \response -> + cont $ Wai.mapResponseHeaders addHeaders response + +instance Router next => Router (NoCache next) where + tryRoute = tryRouteNext (ExtraHeaders [cacheControlDisableCaching] . noCacheNext) + where + cacheControlDisableCaching = ("Cache-Control", "no-store, no-cache, must-revalidate, max-age=0") + +instance (Aeson.FromJSON a, Router next) => Router (ReqBodyJSON a next) where + tryRoute req = tryRouteNextIO getNext req + where + getNext rbj = do + reqBody <- Wai.requestBody req + case Aeson.eitherDecodeStrict reqBody of + Left err -> throwIO $ badRequest $ "Could not decode JSON request: " <> Text.pack (show err) + Right val -> return (reqBodyJSONNext rbj val) + +instance Router next => Router (WithIO next) where + tryRoute = tryRouteNextIO withIONext + +instance (fp ~ FilePath, Router next) => Router (ReqBodyMultipart fp a next) where + tryRoute req = flip fmap (tryRoute req) $ \nextRouter rmp cont -> + runResourceT $ withInternalState $ \s -> do + (params, fileInfos0) <- Wai.parseRequestBody (Wai.tempFileBackEnd s) req + let fileInfos = do + (parName, Wai.FileInfo{..}) <- fileInfos0 + return + ( parName + , MultiPartFileInfo + { mpfiName = fileName + , mpfiContentType = fileContentType + , mpfiContent = fileContent + } + ) + let multiPart :: MultiPartData FilePath = (params, fileInfos) + case reqMultiPartParse rmp multiPart of + Left err -> throwIO $ badRequest $ "Could not decode form request: " <> Text.pack err + Right val -> nextRouter (reqMultiPartNext rmp val) cont + +-- | Most `Router`s are really just newtypes. By using `brief`, you can +-- construct trees of `Router`s by providing only their inner types, much +-- like Servant. +class Abbreviated a where + type Brief a :: * + type instance Brief a = a + brief :: Brief a -> a + default brief :: Brief a ~ a => Brief a -> a + brief = id + +instance Abbreviated (Raw a) where + type Brief (Raw a) = a + brief = Raw + +instance Abbreviated (RawResponse a) where + type Brief (RawResponse a) = a + brief = RawResponse + +instance Abbreviated next => Abbreviated (End next) where + type Brief (End next) = Brief next + brief = End . brief + +instance Abbreviated next => Abbreviated (Seg seg next) where + type Brief (Seg seg next) = Brief next + brief = Seg . brief + +instance (Abbreviated left, Abbreviated right) => Abbreviated (left :<|> right) where + type Brief (left :<|> right) = Brief left :<|> Brief right + brief (l :<|> r) = brief l :<|> brief r + +instance Abbreviated next => Abbreviated (OneOfSegs segs next) where + type Brief (OneOfSegs segs next) = Brief next + brief = OneOfSegs . brief + +instance Abbreviated next => Abbreviated (Capture a next) where + type Brief (Capture a next) = a -> Brief next + brief = Capture . fmap brief + +instance Abbreviated next => Abbreviated (Method method next) where + type Brief (Method method next) = Brief next + brief = Method . brief + +instance Abbreviated (JSON a) where + type Brief (JSON a) = a + brief = JSON + +instance Abbreviated (ExtraHeaders next) + +instance Abbreviated next => Abbreviated (NoCache next) where + type Brief (NoCache next) = Brief next + brief = NoCache . brief + +instance Abbreviated next => Abbreviated (ReqBodyJSON a next) where + type Brief (ReqBodyJSON a next) = a -> Brief next + brief = ReqBodyJSON . fmap brief + +instance Abbreviated next => Abbreviated (WithIO next) where + type Brief (WithIO next) = IO (Brief next) + brief = WithIO . fmap brief + +instance Abbreviated (ReqBodyMultipart fp a next) + +-- Generic routers + +deriving instance Router r => Router (K1 i r p) +deriving instance Router (f p) => Router (M1 i c f p) + +instance (Router (left p), Router (right p)) => Router ((left :*: right) p) where + tryRoute req = routeLeft <|> routeRight + where + routeLeft = tryRouteNext (\(left :*: _) -> left) req + routeRight = tryRouteNext (\(_ :*: right) -> right) req + +-- Error handling + +-- | A `Router`-related exception with a corresponding HTTP error code. +data SolgaError = SolgaError + { errorStatus :: HTTP.Status + , errorMessage :: Text.Text + } deriving (Eq, Ord, Show) + +instance Exception SolgaError + +-- | Create a @400 Bad Request@ error with a given message. +badRequest :: Text.Text -> SolgaError +badRequest msg = SolgaError + { errorStatus = HTTP.badRequest400 + , errorMessage = msg + } + +-- | Create a @404 Not Found@ error with a given message. +notFound :: Text.Text -> SolgaError +notFound msg = SolgaError + { errorStatus = HTTP.notFound404 + , errorMessage = msg + } diff --git a/solga/test/Test.hs b/solga-router/test/Test.hs similarity index 98% rename from solga/test/Test.hs rename to solga-router/test/Test.hs index 331a901..83d8828 100644 --- a/solga/test/Test.hs +++ b/solga-router/test/Test.hs @@ -27,7 +27,8 @@ import GHC.Generics (Generic) import Network.HTTP.Types.URI import Network.Wai.Test -import Solga +import Solga.Core +import Solga.Router main :: IO () main = hspec spec diff --git a/solga-swagger/solga-swagger.cabal b/solga-swagger/solga-swagger.cabal index b2db570..45cd40d 100644 --- a/solga-swagger/solga-swagger.cabal +++ b/solga-swagger/solga-swagger.cabal @@ -17,7 +17,7 @@ cabal-version: >=1.10 library exposed-modules: Solga.Swagger build-depends: base >= 4.8 && < 5, - solga, + solga-core, swagger2 >= 2.1, lens, text, diff --git a/solga-swagger/src/Solga/Swagger.hs b/solga-swagger/src/Solga/Swagger.hs index ee084de..015d385 100644 --- a/solga-swagger/src/Solga/Swagger.hs +++ b/solga-swagger/src/Solga/Swagger.hs @@ -41,7 +41,7 @@ import GHC.TypeLits import Data.Swagger as Swagger import Data.Swagger.Declare -import Solga +import Solga.Core data Context = Context { contextMethod :: Maybe HTTP.Method -- ^ Any method currently set. @@ -106,7 +106,7 @@ pathsFromContext response ctx@Context { contextMethod, pathSegments, operationCo let pathItem = mempty & methodSetter ?~ operation return $ OHMS.singleton path pathItem -instance RouterSwagger RawResponse where +instance RouterSwagger (RawResponse a) where genPaths _ = pathsFromContext mempty instance ToSchema a => RouterSwagger (JSON a) where @@ -136,7 +136,7 @@ instance RouterSwagger next => RouterSwagger (NoCache next) where instance RouterSwagger next => RouterSwagger (ExtraHeaders next) where genPaths = passPaths -instance RouterSwagger (ReqBodyMultipart a next) where +instance RouterSwagger (ReqBodyMultipart fp a next) where genPaths = noPaths instance RouterSwagger (OneOfSegs '[] next) where @@ -149,7 +149,7 @@ instance (KnownSymbol seg, RouterSwagger next, RouterSwagger (OneOfSegs segs nex nextSegPaths <- genPaths (Proxy :: Proxy (OneOfSegs segs next)) ctx return (nextPaths `OHMS.union` nextSegPaths) -instance RouterSwagger Raw where +instance RouterSwagger (Raw a) where genPaths = noPaths instance (RouterSwagger left, RouterSwagger right) => RouterSwagger (left :<|> right) where diff --git a/solga/solga.cabal b/solga/solga.cabal index 50bcf49..2e176db 100644 --- a/solga/solga.cabal +++ b/solga/solga.cabal @@ -1,5 +1,5 @@ name: solga -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Simple typesafe web routing description: A library for easily specifying web APIs and implementing them in a type-safe way. license: MIT @@ -17,38 +17,8 @@ cabal-version: >=1.10 library exposed-modules: Solga build-depends: base >= 4.8 && < 5, - text, - wai, - bytestring, - containers, - aeson >= 1.0.0.0, - wai-extra, - http-types, - resourcet, - safe-exceptions + solga-core, + solga-router hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - -test-suite solga-tests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Test.hs - ghc-options: -Wall - default-language: Haskell2010 - build-depends: base - , solga - , text - , bytestring - , wai - , wai-extra - , aeson - , hspec - , hspec-wai - , hspec-wai-json - , http-types - , unordered-containers - , hashable - , vector - , scientific - , QuickCheck \ No newline at end of file diff --git a/solga/src/Solga.hs b/solga/src/Solga.hs index d929e3d..4a98447 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -1,374 +1,7 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} module Solga - ( -- * Serving APIs - serve, serveThrow - -- * Basic routers - , type (:>), type (/>) - , Get - , Post - , JSON(..) - , Raw(..) - , RawResponse(..) - , End(..) - , WithIO(..) - , Seg(..) - , OneOfSegs(..) - , FromSegment(..) - , Capture(..) - , Method(..) - , ExtraHeaders(..) - , NoCache(..) - , ReqBodyJSON(..) - , MultiPartData - , ReqBodyMultipart(..) - , Endpoint - , (:<|>)(..) - -- * Abbreviation - , Abbreviated(..) - -- * Error handling - , SolgaError - , badRequest - , notFound - -- * Router implementation - , Router(..) - , Responder - , tryRouteNext - , tryRouteNextIO + ( module Solga.Core + , module Solga.Router ) where -import Control.Applicative -import Control.Exception.Safe -import Control.Monad -import Control.Monad.Trans.Resource -import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Encode as Aeson -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Char8 as Char8 -import qualified Data.Map.Strict as Map -import Data.Monoid -import Data.Proxy -import qualified Data.Text as Text -import Data.Text.Encoding -import GHC.Generics -import GHC.TypeLits -import qualified Network.Wai as Wai -import qualified Network.Wai.Parse as Wai -import qualified Network.HTTP.Types as HTTP - ---------------------------------------------------- - --- | The right hand side of `Application`. `Request` is already known. -type Responder = (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived - --- | Routers are the basic typeclass of Solga: their types describe --- what type of requests they accept, and their values describe how to handle them. --- --- You can use `Generic` to get free instance of `Router` for any data type with one constructor --- and `Router`s as fields. The fields will be considered alternatives, as if you wrote `:<|>` between them. -class Router r where - -- | Given a request, if the router supports the given request - -- return a function that constructs a response with a concrete router. - tryRoute :: Wai.Request -> Maybe (r -> Responder) - default tryRoute :: (Generic r, Router (Rep r ())) => Wai.Request -> Maybe (r -> Responder) - tryRoute = tryRouteNext (from :: r -> Rep r ()) - --- | Try to route using a type @r@ by providing a function to turn it into a `Router` @r'@. --- Useful for passing routing on to the next step. -tryRouteNext :: Router r' => (r -> r') -> Wai.Request -> Maybe (r -> Responder) -tryRouteNext f req = (. f) <$> tryRoute req - --- | Like `tryRouteNext` but in `IO`. -tryRouteNextIO :: Router r' => (r -> IO r') -> Wai.Request -> Maybe (r -> Responder) -tryRouteNextIO f req = do - nextRouter <- tryRoute req - Just $ \router cont -> do - next <- f router - nextRouter next cont - --- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses and other errors as HTTP 500. -serve :: Router r => r -> Wai.Application -serve router req cont = - serveThrow router req cont - `catchAny` \someEx -> - let - ( status, body ) = case fromException someEx of - Just SolgaError { errorStatus, errorMessage } -> ( errorStatus, Builder.byteString $ encodeUtf8 errorMessage ) - Nothing -> ( HTTP.internalServerError500, "Internal Server Error" ) - in cont $ Wai.responseBuilder status [] body - --- | Serve a `Router` with Solga, throwing `SolgaError`s. -serveThrow :: Router r => r -> Wai.Application -serveThrow router req cont = case tryRoute req of - Nothing -> throwIO $ notFound "" - Just r -> r router cont - --- | Compose routers. This is just type application, --- ie.: @Foo :> Bar :> Baz == Foo (Bar Baz)@ -type f :> g = f g -infixr 2 :> - --- | Serve a given WAI `Wai.Application`. -newtype Raw = Raw { rawApp :: Wai.Application } - -instance Router Raw where - tryRoute req = Just $ \(Raw app) -> app req - --- | Serve a given WAI `Wai.Response`. -newtype RawResponse = RawResponse { rawResponse :: Wai.Response } -instance Router RawResponse where - tryRoute _ = Just $ \(RawResponse response) cont -> cont response - --- | Only accept the end of a path. -newtype End next = End { endNext :: next } -instance Router next => Router (End next) where - tryRoute req = case Wai.pathInfo req of - [] -> tryRouteNext endNext req - _ -> Nothing - --- | Match a constant directory in the path. --- --- When specifying APIs, use the `/>` combinator to specify sub-paths: --- @"foo" `/>` `JSON` Bar@ -newtype Seg (seg :: Symbol) next = Seg { segNext :: next } - deriving (Eq, Ord, Show) - --- | Match a path, segment, e.g @"foo" `/>` `JSON` Bar@ -type seg /> g = Seg seg :> g -infixr 2 /> - -instance (KnownSymbol seg, Router next) => Router (Seg seg next) where - tryRoute req = case Wai.pathInfo req of - s : segs | Text.unpack s == symbolVal (Proxy :: Proxy seg) -> - tryRouteNext segNext req { Wai.pathInfo = segs } - _ -> Nothing - --- | Try to route with @left@, or try to route with @right@. -data left :<|> right = (:<|>) { altLeft :: left, altRight :: right } - deriving (Eq, Ord, Show) - -infixr 1 :<|> - -instance (Router left, Router right) => Router (left :<|> right) where - tryRoute req = tryRouteNext altLeft req <|> tryRouteNext altRight req - --- | Match any of a set of path segments. -data OneOfSegs (segs :: [ Symbol ]) next = OneOfSegs { oneOfSegsNext :: next } - -instance (KnownSymbol seg, Router next, Router (OneOfSegs segs next)) => Router (OneOfSegs (seg ': segs) next) where - tryRoute = tryRouteNext $ \(OneOfSegs next) -> (Seg next :: Seg seg next) :<|> (OneOfSegs next :: OneOfSegs segs next) - -instance Router next => Router (OneOfSegs '[] next) where - tryRoute _ = Nothing - --- | The class of types that can be parsed from a path segment. -class FromSegment a where - fromSegment :: Text.Text -> Maybe a - -instance FromSegment Text.Text where - fromSegment = Just - --- | Capture a path segment and pass it on. -newtype Capture a next = Capture { captureNext :: a -> next } - -instance (FromSegment a, Router next) => Router (Capture a next) where - tryRoute req = case Wai.pathInfo req of - seg : segs -> do - capture <- fromSegment seg - tryRouteNext (\c -> captureNext c capture) req { Wai.pathInfo = segs } - _ -> Nothing - --- | Accepts requests with a certain method. -newtype Method (method :: Symbol) next = Method { methodNext :: next } - deriving (Eq, Ord, Show) - -instance (KnownSymbol method, Router next) => Router (Method method next) where - tryRoute req = do - guard (Char8.unpack (Wai.requestMethod req) == symbolVal (Proxy :: Proxy method)) - tryRouteNext methodNext req - --- | Return a given JSON object -newtype JSON a = JSON { jsonResponse :: a } - deriving (Eq, Ord, Show) - -instance Aeson.ToJSON a => Router (JSON a) where - tryRoute _ = Just $ \json cont -> - cont $ Wai.responseBuilder HTTP.status200 headers $ Aeson.fromEncoding $ Aeson.toEncoding $ jsonResponse json - where headers = [ ( HTTP.hContentType, "application/json" ) ] - --- | Set extra headers on responses. --- Existing headers will be overriden if specified here. -data ExtraHeaders next = ExtraHeaders - { extraHeaders :: HTTP.ResponseHeaders - , extraHeadersNext :: next - } - -instance Router next => Router (ExtraHeaders next) where - tryRoute req = do - nextRouter <- tryRoute req - return $ \(ExtraHeaders headers next) cont -> do - let addHeaders oldHeaders = Map.assocs (Map.fromList headers `Map.union` Map.fromList oldHeaders) - nextRouter next $ \response -> - cont $ Wai.mapResponseHeaders addHeaders response - --- | Prevent caching for sub-routers. -newtype NoCache next = NoCache { noCacheNext :: next } - -instance Router next => Router (NoCache next) where - tryRoute = tryRouteNext (ExtraHeaders [cacheControlDisableCaching] . noCacheNext) - where - cacheControlDisableCaching = ("Cache-Control", "no-store, no-cache, must-revalidate, max-age=0") - --- | Parse a JSON request body. -newtype ReqBodyJSON a next = ReqBodyJSON { reqBodyJSONNext :: a -> next } - -instance (Aeson.FromJSON a, Router next) => Router (ReqBodyJSON a next) where - tryRoute req = tryRouteNextIO getNext req - where - getNext rbj = do - reqBody <- Wai.requestBody req - case Aeson.eitherDecodeStrict reqBody of - Left err -> throwIO $ badRequest $ "Could not decode JSON request: " <> Text.pack (show err) - Right val -> return (reqBodyJSONNext rbj val) - --- | Produce a response with `IO`. -newtype WithIO next = WithIO { withIONext :: IO next } - -instance Router next => Router (WithIO next) where - tryRoute = tryRouteNextIO withIONext - --- | A parsed "multipart/form-data" request. -type MultiPartData = ([Wai.Param], [Wai.File FilePath]) - --- | Accept a "multipart/form-data" request. --- Files will be stored in a temporary directory and will be deleted --- automatically after the request is processed. -data ReqBodyMultipart a next = ReqBodyMultipart - { reqMultiPartParse :: MultiPartData -> Either String a - , reqMultiPartNext :: a -> next - } - -instance Router next => Router (ReqBodyMultipart a next) where - tryRoute req = flip fmap (tryRoute req) $ \nextRouter rmp cont -> - runResourceT $ withInternalState $ \s -> do - multiPart <- Wai.parseRequestBody (Wai.tempFileBackEnd s) req - case reqMultiPartParse rmp multiPart of - Left err -> throwIO $ badRequest $ "Could not decode form request: " <> Text.pack err - Right val -> nextRouter (reqMultiPartNext rmp val) cont - --- | Useful synonym for dynamic endpoints: accept requests with a given method, compute a JSON response in `IO` and don't cache. -type Endpoint method a = End :> NoCache :> Method method :> WithIO :> a - --- | Handle a "GET" request and produce a "JSON" response, with `IO`. -type Get a = Endpoint "GET" (JSON a) --- | Handle a "POST" request and produce a "JSON" response, with `IO`. -type Post a = Endpoint "POST" (JSON a) - --- | Most `Router`s are really just newtypes. By using `brief`, you can --- construct trees of `Router`s by providing only their inner types, much --- like Servant. -class Abbreviated a where - type Brief a :: * - type instance Brief a = a - brief :: Brief a -> a - default brief :: Brief a ~ a => Brief a -> a - brief = id - -instance Abbreviated Raw where - type Brief Raw = Wai.Application - brief = Raw - -instance Abbreviated RawResponse where - type Brief RawResponse = Wai.Response - brief = RawResponse - -instance Abbreviated next => Abbreviated (End next) where - type Brief (End next) = Brief next - brief = End . brief - -instance Abbreviated next => Abbreviated (Seg seg next) where - type Brief (Seg seg next) = Brief next - brief = Seg . brief - -instance (Abbreviated left, Abbreviated right) => Abbreviated (left :<|> right) where - type Brief (left :<|> right) = Brief left :<|> Brief right - brief (l :<|> r) = brief l :<|> brief r - -instance Abbreviated next => Abbreviated (OneOfSegs segs next) where - type Brief (OneOfSegs segs next) = Brief next - brief = OneOfSegs . brief - -instance Abbreviated next => Abbreviated (Capture a next) where - type Brief (Capture a next) = a -> Brief next - brief = Capture . fmap brief - -instance Abbreviated next => Abbreviated (Method method next) where - type Brief (Method method next) = Brief next - brief = Method . brief - -instance Abbreviated (JSON a) where - type Brief (JSON a) = a - brief = JSON - -instance Abbreviated (ExtraHeaders next) - -instance Abbreviated next => Abbreviated (NoCache next) where - type Brief (NoCache next) = Brief next - brief = NoCache . brief - -instance Abbreviated next => Abbreviated (ReqBodyJSON a next) where - type Brief (ReqBodyJSON a next) = a -> Brief next - brief = ReqBodyJSON . fmap brief - -instance Abbreviated next => Abbreviated (WithIO next) where - type Brief (WithIO next) = IO (Brief next) - brief = WithIO . fmap brief - -instance Abbreviated (ReqBodyMultipart a next) - --- Generic routers - -deriving instance Router r => Router (K1 i r p) -deriving instance Router (f p) => Router (M1 i c f p) - -instance (Router (left p), Router (right p)) => Router ((left :*: right) p) where - tryRoute req = routeLeft <|> routeRight - where - routeLeft = tryRouteNext (\(left :*: _) -> left) req - routeRight = tryRouteNext (\(_ :*: right) -> right) req - --- Error handling - --- | A `Router`-related exception with a corresponding HTTP error code. -data SolgaError = SolgaError - { errorStatus :: HTTP.Status - , errorMessage :: Text.Text - } deriving (Eq, Ord, Show) - -instance Exception SolgaError - --- | Create a @400 Bad Request@ error with a given message. -badRequest :: Text.Text -> SolgaError -badRequest msg = SolgaError - { errorStatus = HTTP.badRequest400 - , errorMessage = msg - } - --- | Create a @404 Not Found@ error with a given message. -notFound :: Text.Text -> SolgaError -notFound msg = SolgaError - { errorStatus = HTTP.notFound404 - , errorMessage = msg - } +import Solga.Core +import Solga.Router diff --git a/stack.yaml b/stack.yaml index df0223f..cb18ee9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,6 +7,8 @@ resolver: nightly-2017-07-31 packages: - 'solga' - 'solga-swagger' +- 'solga-core' +- 'solga-router' # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: From 3cba1bdc684cfbd7e718a37b574fee0134dc73d9 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Fri, 8 Sep 2017 16:47:44 +0200 Subject: [PATCH 08/45] add library to make requests against solga endpoints --- .travis.yml | 2 +- solga-client/LICENSE | 20 ++++ solga-client/Setup.hs | 2 + solga-client/solga-client.cabal | 52 +++++++++ solga-client/src/Solga/Client.hs | 176 +++++++++++++++++++++++++++++++ solga-client/test/Test.hs | 140 ++++++++++++++++++++++++ stack.yaml | 1 + 7 files changed, 392 insertions(+), 1 deletion(-) create mode 100644 solga-client/LICENSE create mode 100644 solga-client/Setup.hs create mode 100644 solga-client/solga-client.cabal create mode 100644 solga-client/src/Solga/Client.hs create mode 100644 solga-client/test/Test.hs diff --git a/.travis.yml b/.travis.yml index fad01fd..845c15e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -174,4 +174,4 @@ script: done ;; esac - set +ex \ No newline at end of file + set +ex diff --git a/solga-client/LICENSE b/solga-client/LICENSE new file mode 100644 index 0000000..b58d2fd --- /dev/null +++ b/solga-client/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Francesco Mazzoli + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/solga-client/Setup.hs b/solga-client/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/solga-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/solga-client/solga-client.cabal b/solga-client/solga-client.cabal new file mode 100644 index 0000000..31aa8ac --- /dev/null +++ b/solga-client/solga-client.cabal @@ -0,0 +1,52 @@ +name: solga-client +version: 0.1.0.0 +synopsis: Simple typesafe web routing +description: A library for easily making requests to solga endpoints +license: MIT +license-file: LICENSE +author: Francesco Mazzoli +maintainer: f@mazzo.li +copyright: Copyright (C) 2017 Francesco Mazzoli +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.Client + build-depends: base >= 4.8 && < 5, + solga-core, + aeson, + http-client, + bytestring, + text, + blaze-builder, + http-types + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite solga-client-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base + , solga-core + , solga-client + , solga-router + , text + , wai + , aeson + , hspec + , http-types + , unordered-containers + , hashable + , vector + , scientific + , QuickCheck + , http-client + , warp diff --git a/solga-client/src/Solga/Client.hs b/solga-client/src/Solga/Client.hs new file mode 100644 index 0000000..ac53429 --- /dev/null +++ b/solga-client/src/Solga/Client.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +module Solga.Client + ( Client(..) + , SomeRequestData(..) + , choose + , RawRequest(..) + , ToSegment(..) + , WithData(..) + , GetResponse(..) + ) where + +import Data.Kind +import Data.Proxy +import qualified Data.Aeson as Aeson +import qualified Network.HTTP.Client as Http +import qualified Network.HTTP.Client.MultipartFormData as Http +import GHC.Generics +import qualified Data.ByteString.Char8 as BSC8 +import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Monoid ((<>)) +import qualified Data.Text.Encoding as T +import Data.Text (Text) +import Network.HTTP.Types (urlEncodeBuilder) +import qualified Blaze.ByteString.Builder as Blaze +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Text as T + +import Solga.Core + +data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) + +class Client r where + type RequestData r :: * -> * + type RequestData r = SomeRequestData r + performRequest :: proxy r -> Http.Request -> Http.Manager -> RequestData r a -> IO a + default + performRequest :: forall (proxy :: * -> *) a. + (RequestData r ~ SomeRequestData r) + => proxy r -> Http.Request -> Http.Manager -> RequestData r a -> IO a + performRequest _p req mgr (SomeRequestData p perf) = performRequest p req mgr perf + +choose :: forall in_ out a. + (Client in_, RequestData out ~ SomeRequestData out) + => (out -> in_) -> RequestData in_ a -> RequestData out a +choose _f perf = SomeRequestData (Proxy @in_) perf + +newtype RawRequest a = RawRequest {unRequestDataRaw :: Http.Request -> Http.Manager -> IO a} + +instance Client (Raw a) where + type RequestData (Raw a) = RawRequest + performRequest _p mgr req (RawRequest f) = f mgr req + +instance Client (RawResponse a) where + type RequestData (RawResponse a) = RawRequest + performRequest _p mgr req (RawRequest f) = f mgr req + +instance (Client next) => Client (End next) where + type RequestData (End next) = RequestData next + performRequest _p mgr req perf = performRequest (Proxy @next) mgr req perf + +addSegment :: Http.Request -> Text -> Http.Request +addSegment req segtxt = req + { Http.path = if BS.null (Http.path req) || BSC8.last (Http.path req) == '/' + then Http.path req <> seg + else Http.path req <> "/" <> seg + } + where + seg = BSL.toStrict (Blaze.toLazyByteString (urlEncodeBuilder False (T.encodeUtf8 segtxt))) + +instance (Client next, KnownSymbol seg) => Client (Seg seg next) where + type RequestData (Seg seg next) = RequestData next + performRequest _p req mgr perf = + performRequest (Proxy @next) (addSegment req (T.pack (symbolVal (Proxy @seg)))) mgr perf + +instance (Client left, Client right) => Client (left :<|> right) where + type RequestData (left :<|> right) = RequestData left :+: RequestData right + performRequest _p mgr req = \case + L1 perf -> performRequest (Proxy @left) mgr req perf + R1 perf -> performRequest (Proxy @right) mgr req perf + +data WhichSeg (segs :: [Symbol]) where + ThisSeg :: KnownSymbol seg => WhichSeg (seg ': segs) + ThatSeg :: WhichSeg segs -> WhichSeg (seg ': segs) + +thisSeg :: forall seg segs. KnownSymbol seg => WhichSeg (seg ': segs) -> String +thisSeg _ = symbolVal (Proxy @seg) + +whichSeg :: WhichSeg segs -> String +whichSeg ts@ThisSeg = thisSeg ts +whichSeg (ThatSeg ws) = whichSeg ws + +instance (Client next) => Client (OneOfSegs segs next) where + type RequestData (OneOfSegs segs next) = WithData (WhichSeg segs) (RequestData next) + performRequest _p req mgr (WithData ws perf) = + performRequest (Proxy @next) (addSegment req (T.pack (whichSeg ws))) mgr perf + +class ToSegment a where + toSegment :: a -> Text + +instance ToSegment Text where + toSegment = id + +data WithData a next b = WithData + { ardData :: a + , ardNext :: next b + } + +instance (Client next, ToSegment a) => Client (Capture a next) where + type RequestData (Capture a next) = WithData a (RequestData next) + performRequest _p req mgr (WithData x perf) = + performRequest (Proxy @next) (addSegment req (toSegment x)) mgr perf + +instance (Client next, KnownSymbol method) => Client (Method method next) where + type RequestData (Method seg next) = RequestData next + performRequest _p req mgr perf = performRequest + (Proxy @next) req{Http.method = BSC8.pack (symbolVal (Proxy @method))} mgr perf + +newtype GetResponse resp a b = GetResponse {unGetResponse :: Http.Response resp -> a -> IO b} + +instance (Aeson.FromJSON a) => Client (JSON a) where + -- note that we do not decode eagerly because it's often the case that the body + -- cannot be decoded since web servers return invalid json on errors + -- (e.g. "Internal server error" on a 500 rather than a json encoded error) + type RequestData (JSON a) = GetResponse BSL.ByteString (Either String a) + performRequest _p req mgr (GetResponse f) = do + resp <- Http.httpLbs req mgr + let decode = Aeson.eitherDecode' (Http.responseBody resp) + f resp decode + +instance (Client next) => Client (ExtraHeaders next) where + type RequestData (ExtraHeaders next) = RequestData next + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf + +instance (Client next) => Client (NoCache next) where + type RequestData (NoCache next) = RequestData next + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf + +instance (Client next, Aeson.ToJSON a) => Client (ReqBodyJSON a next) where + type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) + performRequest _p req mgr (WithData x perf) = performRequest + (Proxy @next) req{Http.requestBody = Http.RequestBodyLBS (Aeson.encode x)} mgr perf + +instance (Client next) => Client (WithIO next) where + type RequestData (WithIO next) = RequestData next + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf + +instance (Client next) => Client (ReqBodyMultipart fp a next) where + type + RequestData (ReqBodyMultipart fp a next) = + WithData ([Http.Part], Maybe ByteString) (RequestData next) + performRequest _p req mgr (WithData (parts, mbBoundary) perf) = do + req' <- case mbBoundary of + Nothing -> Http.formDataBody parts req + Just x -> Http.formDataBodyWithBoundary x parts req + performRequest (Proxy @next) req' mgr perf + diff --git a/solga-client/test/Test.hs b/solga-client/test/Test.hs new file mode 100644 index 0000000..812a246 --- /dev/null +++ b/solga-client/test/Test.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -ddump-deriv #-} + +module Main (main) where + +import Test.Hspec +import Test.QuickCheck (genericShrink, property, ioProperty, Arbitrary(..), Gen, sized, oneof, scale, listOf) + +import Data.Aeson hiding (json) +import Data.Hashable +import qualified Data.Scientific as S +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HMS +import qualified Data.Vector as V +import Data.Traversable +import GHC.Generics (Generic) +import Network.HTTP.Types +import qualified Network.HTTP.Client as Http +import Data.Proxy (Proxy(..)) +import qualified Network.Wai.Handler.Warp as Warp + +import Solga.Core +import Solga.Router +import Solga.Client + +main :: IO () +main = do + Warp.withApplication (return (serve testAPI)) (hspec . spec) + +data TestAPI = TestAPI + { basic :: "basic" /> Get T.Text + , echoJSON :: "echo-json" /> ReqBodyJSON Value :> Post Value + , internalError :: "fubar" /> Get T.Text + , echoCapture :: "echo-capture" /> Capture T.Text :> Get T.Text + } deriving (Generic) +instance Router TestAPI +instance Client TestAPI + +testAPI :: TestAPI +testAPI = TestAPI + { basic = brief (return "basic") + , echoJSON = brief return + , internalError = brief (return $ error "quality programming") + , echoCapture = brief return + } + +req :: Warp.Port -> RequestData TestAPI a -> IO a +req p x = do + mgr <- Http.newManager Http.defaultManagerSettings + performRequest (Proxy @TestAPI) Http.defaultRequest{Http.port = p} mgr x + +spec :: Warp.Port -> Spec +spec port = do + -- tests basic routing + describe "GET /basic" $ do + it "responds with 200" $ do + req port $ choose basic $ GetResponse $ \resp _txt -> + Http.responseStatus resp `shouldBe` status200 + + it "responds with \"basic\"" $ do + req port $ choose basic $ GetResponse $ \_resp decodeTxt -> do + Right txt <- return decodeTxt + txt `shouldBe` "basic" + + -- tests ReqBodyJSON and JSON + describe "POST /echo-json" $ do + it "responds with 200" $ + req port $ choose echoJSON $ WithData (String "test") $ GetResponse $ \resp _txt -> + Http.responseStatus resp `shouldBe` status200 + + it "responds with same JSON" $ property $ \val -> do + ioProperty $ req port $ choose echoJSON $ WithData val $ GetResponse $ \_resp decodeVal -> do + Right val' <- return decodeVal + return (val == val') + + -- tests exception handling + describe "GET /fubar" $ do + it "responds with 500" $ + req port $ choose internalError $ GetResponse $ \resp _ -> + Http.responseStatus resp `shouldBe` status500 + + -- tests Capture + describe "GET /echo-capture" $ do + it "responds with 200" $ + req port $ choose echoCapture $ WithData "test" $ GetResponse $ \resp _ -> + Http.responseStatus resp `shouldBe` status200 + + it "responds with captured segment" $ property $ \seg -> do + ioProperty $ req port $ choose echoCapture $ WithData seg $ GetResponse $ \_ decodeSeg -> do + Right seg' <- return decodeSeg + return (seg == seg') + +deriving instance Generic Value + +instance Arbitrary Value where + arbitrary = sized arbJSON + where + arbJSON :: Int -> Gen Value + arbJSON n + | n == 0 = oneof leaves + | otherwise = oneof (leaves ++ branches (arbJSON (n `div` 4))) + leaves = + [ String <$> arbitrary + , Number <$> arbitrary + , Bool <$> arbitrary + , pure Null + ] + branches child = + [ do + values <- scale (`div` 4) (listOf child) + entries <- for values $ \val -> do + key <- arbitrary + return ( key, val ) + return $ Object $ HMS.fromList entries + , (Array . V.fromList) <$> scale (`div` 4) (listOf child) + ] + shrink = genericShrink + +instance (Eq key, Hashable key, Arbitrary key, Arbitrary value) => Arbitrary (HMS.HashMap key value) where + arbitrary = HMS.fromList <$> arbitrary + shrink = map HMS.fromList . shrink . HMS.toList + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + shrink = map T.pack . shrink . T.unpack + +instance Arbitrary a => Arbitrary (V.Vector a) where + arbitrary = V.fromList <$> arbitrary + shrink = map V.fromList . shrink . V.toList + +instance Arbitrary S.Scientific where + arbitrary = S.scientific <$> arbitrary <*> arbitrary + shrink s = map (uncurry S.scientific) $ shrink $ ( S.coefficient s, S.base10Exponent s ) diff --git a/stack.yaml b/stack.yaml index cb18ee9..0a53c0a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ packages: - 'solga-swagger' - 'solga-core' - 'solga-router' +- 'solga-client' # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: From cd2002b5ee03637df33107eb92dc5be64dfbc0f7 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sat, 9 Sep 2017 19:03:17 +0200 Subject: [PATCH 09/45] add ghcjs version of client library --- solga-client-ghcjs/LICENSE | 20 ++ solga-client-ghcjs/Setup.hs | 2 + solga-client-ghcjs/solga-client-ghcjs.cabal | 25 +++ solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 208 +++++++++++++++++++ stack-ghcjs.yaml | 20 ++ 5 files changed, 275 insertions(+) create mode 100644 solga-client-ghcjs/LICENSE create mode 100644 solga-client-ghcjs/Setup.hs create mode 100644 solga-client-ghcjs/solga-client-ghcjs.cabal create mode 100644 solga-client-ghcjs/src/Solga/Client/GHCJS.hs create mode 100644 stack-ghcjs.yaml diff --git a/solga-client-ghcjs/LICENSE b/solga-client-ghcjs/LICENSE new file mode 100644 index 0000000..b58d2fd --- /dev/null +++ b/solga-client-ghcjs/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Francesco Mazzoli + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/solga-client-ghcjs/Setup.hs b/solga-client-ghcjs/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/solga-client-ghcjs/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal new file mode 100644 index 0000000..1315970 --- /dev/null +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -0,0 +1,25 @@ +name: solga-client-ghcjs +version: 0.1.0.0 +synopsis: Simple typesafe web routing +description: A library for easily making requests to solga endpoints +license: MIT +license-file: LICENSE +author: Francesco Mazzoli +maintainer: f@mazzo.li +copyright: Copyright (C) 2017 Francesco Mazzoli +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.Client.GHCJS + build-depends: base >= 4.8 && < 5, + solga-core, + ghcjs-base, + dlist + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs new file mode 100644 index 0000000..ab70870 --- /dev/null +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE RecordWildCards #-} +module Solga.Client.GHCJS where + {- + ( Client(..) + , SomeRequestData(..) + , choose + , RawRequest(..) + , ToSegment(..) + , WithData(..) + , GetResponse(..) + ) where + -} + +import Data.Kind +import Data.Proxy +import GHC.Generics +import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) +import Data.Monoid ((<>)) +import qualified JavaScript.Web.XMLHttpRequest as Xhr +import Control.Exception (Exception, throwIO) +import qualified Data.JSString as JSS +import Data.JSString (JSString) +import Data.Typeable (Typeable) +import qualified Data.DList as DList +import Data.DList (DList) +import Data.String (fromString) +import qualified JavaScript.JSON.Types.Class as Json +import qualified JavaScript.JSON.Types.Internal as Json +import GHCJS.Types (Immutable) + +import Solga.Core hiding (Header) + +data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) + +type Header = (JSString, JSString) + +data Request = Request + { reqMethod :: String + , reqHost :: JSString + , reqSegments :: DList JSString + , reqQueryString :: JSString + , reqData :: Xhr.RequestData + , reqLogin :: Maybe (JSString, JSString) + , reqHeaders :: [Header] + , reqWithCredentials :: Bool + } + +newtype BadMethod = BadMethod String + deriving (Eq, Show, Typeable) +instance Exception BadMethod + +foreign import javascript unsafe + "encodeURI($1)" + js_encodeURI :: JSString -> IO JSString + +toXhrRequest :: Request -> IO Xhr.Request +toXhrRequest Request{..} = do + meth <- case reqMethod of + "GET" -> return Xhr.GET + "POST" -> return Xhr.POST + "PUT" -> return Xhr.PUT + "DELETE" -> return Xhr.DELETE + x -> throwIO (BadMethod x) + uri <- js_encodeURI (reqHost <> "/" <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + return Xhr.Request + { Xhr.reqMethod = meth + , Xhr.reqURI = uri + , Xhr.reqLogin = reqLogin + , Xhr.reqHeaders = reqHeaders + , Xhr.reqWithCredentials = reqWithCredentials + , Xhr.reqData = reqData + } + +class Client r where + type RequestData r :: * -> * + type RequestData r = SomeRequestData r + performRequest :: proxy r -> Request -> RequestData r a -> IO a + default + performRequest :: forall (proxy :: * -> *) a. + (RequestData r ~ SomeRequestData r) + => proxy r -> Request -> RequestData r a -> IO a + performRequest _p req (SomeRequestData p perf) = performRequest p req perf + +choose :: forall in_ out a. + (Client in_, RequestData out ~ SomeRequestData out) + => (out -> in_) -> RequestData in_ a -> RequestData out a +choose _f perf = SomeRequestData (Proxy @in_) perf + +newtype RawRequest a = RawRequest {unRequestDataRaw :: Request -> IO a} + +instance Client (Raw a) where + type RequestData (Raw a) = RawRequest + performRequest _p req (RawRequest f) = f req + +instance Client (RawResponse a) where + type RequestData (RawResponse a) = RawRequest + performRequest _p req (RawRequest f) = f req + +instance (Client next) => Client (End next) where + type RequestData (End next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + +addSegment :: Request -> JSString -> Request +addSegment req seg = req{reqSegments = reqSegments req <> DList.singleton seg} + +instance (Client next, KnownSymbol seg) => Client (Seg seg next) where + type RequestData (Seg seg next) = RequestData next + performRequest _p req perf = + performRequest (Proxy @next) (addSegment req (fromString (symbolVal (Proxy @seg)))) perf + +instance (Client left, Client right) => Client (left :<|> right) where + type RequestData (left :<|> right) = RequestData left :+: RequestData right + performRequest _p req = \case + L1 perf -> performRequest (Proxy @left) req perf + R1 perf -> performRequest (Proxy @right) req perf + +data WhichSeg (segs :: [Symbol]) where + ThisSeg :: KnownSymbol seg => WhichSeg (seg ': segs) + ThatSeg :: WhichSeg segs -> WhichSeg (seg ': segs) + +thisSeg :: forall seg segs. KnownSymbol seg => WhichSeg (seg ': segs) -> String +thisSeg _ = symbolVal (Proxy @seg) + +whichSeg :: WhichSeg segs -> String +whichSeg ts@ThisSeg = thisSeg ts +whichSeg (ThatSeg ws) = whichSeg ws + +instance (Client next) => Client (OneOfSegs segs next) where + type RequestData (OneOfSegs segs next) = WithData (WhichSeg segs) (RequestData next) + performRequest _p req (WithData ws perf) = + performRequest (Proxy @next) (addSegment req (fromString (whichSeg ws))) perf + +class ToSegment a where + toSegment :: a -> JSString + +instance ToSegment JSString where + toSegment = id + +data WithData a next b = WithData + { ardData :: a + , ardNext :: next b + } + +instance (Client next, ToSegment a) => Client (Capture a next) where + type RequestData (Capture a next) = WithData a (RequestData next) + performRequest _p req (WithData x perf) = + performRequest (Proxy @next) (addSegment req (toSegment x)) perf + +instance (Client next, KnownSymbol method) => Client (Method method next) where + type RequestData (Method seg next) = RequestData next + performRequest _p req perf = performRequest + (Proxy @next) req{reqMethod = symbolVal (Proxy @method)} perf + +newtype GetResponse resp a b = GetResponse {unGetResponse :: Xhr.Response resp -> a -> IO b} + +instance (Json.FromJSON a) => Client (JSON a) where + -- note that we do not decode eagerly because it's often the case that the body + -- cannot be decoded since web servers return invalid json on errors + -- (e.g. "Internal server error" on a 500 rather than a json encoded error) + type RequestData (JSON a) = GetResponse (Json.SomeValue Immutable) (Maybe (Either String a)) + performRequest _p req (GetResponse f) = do + resp <- Xhr.xhr =<< toXhrRequest req + f resp $ do + data_ <- Xhr.contents resp + return (Json.parseEither Json.parseJSON data_) + +instance (Client next) => Client (ExtraHeaders next) where + type RequestData (ExtraHeaders next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + +instance (Client next) => Client (NoCache next) where + type RequestData (NoCache next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + +instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where + type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) + performRequest _p req (WithData x perf) = performRequest + (Proxy @next) req{reqData = Xhr.StringData (Json.encode (Json.toJSON x))} perf + +instance (Client next) => Client (WithIO next) where + type RequestData (WithIO next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + +instance (Client next) => Client (ReqBodyMultipart fp a next) where + type + RequestData (ReqBodyMultipart fp a next) = + WithData [(JSString, Xhr.FormDataVal)] (RequestData next) + performRequest _p req (WithData fd perf) = do + performRequest (Proxy @next) req{reqData = Xhr.FormData fd} perf diff --git a/stack-ghcjs.yaml b/stack-ghcjs.yaml new file mode 100644 index 0000000..eccd01c --- /dev/null +++ b/stack-ghcjs.yaml @@ -0,0 +1,20 @@ +packages: +- 'solga-core' +- 'solga-client-ghcjs' +- location: + git: git@github.com:bitonic/ghcjs-base.git + commit: e36e6be8a99a240c51319abd36827cc00e0c3cf2 + extra-dep: true +allow-newer: true +flags: {} +extra-package-dbs: [] + +resolver: lts-8.11 +compiler: ghcjs-0.2.1.9008011_ghc-8.0.2 +compiler-check: match-exact +setup-info: + ghcjs: + source: + ghcjs-0.2.1.9008011_ghc-8.0.2: + url: https://github.com/matchwood/ghcjs-stack-dist/raw/master/ghcjs-0.2.1.9008011.tar.gz + sha1: a72a5181124baf64bcd0e68a8726e65914473b3b From 1ebbbaab22a8b68be2d9fd771c3a249a100f5f48 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 10 Sep 2017 16:38:20 +0200 Subject: [PATCH 10/45] make the multipart types better --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 10 +++++----- solga-client/src/Solga/Client.hs | 11 ++++++----- solga-client/test/Test.hs | 2 -- solga-core/src/Solga/Core.hs | 10 +++++----- solga-router/src/Solga/Router.hs | 6 +++--- solga-swagger/src/Solga/Swagger.hs | 2 +- 6 files changed, 20 insertions(+), 21 deletions(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index ab70870..2814d5c 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -200,9 +200,9 @@ instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf -instance (Client next) => Client (ReqBodyMultipart fp a next) where +instance (Client next) => Client (ReqBodyMultipart a next) where type - RequestData (ReqBodyMultipart fp a next) = - WithData [(JSString, Xhr.FormDataVal)] (RequestData next) - performRequest _p req (WithData fd perf) = do - performRequest (Proxy @next) req{reqData = Xhr.FormData fd} perf + RequestData (ReqBodyMultipart a next) = + WithData (a, a -> [(JSString, Xhr.FormDataVal)]) (RequestData next) + performRequest _p req (WithData (x, f) perf) = do + performRequest (Proxy @next) req{reqData = Xhr.FormData (f x)} perf diff --git a/solga-client/src/Solga/Client.hs b/solga-client/src/Solga/Client.hs index ac53429..e9ed5f7 100644 --- a/solga-client/src/Solga/Client.hs +++ b/solga-client/src/Solga/Client.hs @@ -131,7 +131,7 @@ instance (Client next, ToSegment a) => Client (Capture a next) where performRequest (Proxy @next) (addSegment req (toSegment x)) mgr perf instance (Client next, KnownSymbol method) => Client (Method method next) where - type RequestData (Method seg next) = RequestData next + type RequestData (Method method next) = RequestData next performRequest _p req mgr perf = performRequest (Proxy @next) req{Http.method = BSC8.pack (symbolVal (Proxy @method))} mgr perf @@ -164,11 +164,12 @@ instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf -instance (Client next) => Client (ReqBodyMultipart fp a next) where +instance (Client next) => Client (ReqBodyMultipart a next) where type - RequestData (ReqBodyMultipart fp a next) = - WithData ([Http.Part], Maybe ByteString) (RequestData next) - performRequest _p req mgr (WithData (parts, mbBoundary) perf) = do + RequestData (ReqBodyMultipart a next) = + WithData (a, a -> ([Http.Part], Maybe ByteString)) (RequestData next) + performRequest _p req mgr (WithData (x, f) perf) = do + let (parts, mbBoundary) = f x req' <- case mbBoundary of Nothing -> Http.formDataBody parts req Just x -> Http.formDataBodyWithBoundary x parts req diff --git a/solga-client/test/Test.hs b/solga-client/test/Test.hs index 812a246..bb995c0 100644 --- a/solga-client/test/Test.hs +++ b/solga-client/test/Test.hs @@ -97,8 +97,6 @@ spec port = do Right seg' <- return decodeSeg return (seg == seg') -deriving instance Generic Value - instance Arbitrary Value where arbitrary = sized arbJSON where diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index c154b6e..a20d437 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -113,22 +113,22 @@ newtype ReqBodyJSON a next = ReqBodyJSON { reqBodyJSONNext :: a -> next } newtype WithIO next = WithIO { withIONext :: IO next } type MultiPartParam = (ByteString, ByteString) -type MultiPartFile y = (ByteString, MultiPartFileInfo y) +type MultiPartFile = (ByteString, MultiPartFileInfo) -data MultiPartFileInfo c = MultiPartFileInfo +data MultiPartFileInfo = MultiPartFileInfo { mpfiName :: ByteString , mpfiContentType :: ByteString , mpfiContent :: FilePath } -- | A parsed "multipart/form-data" request. -type MultiPartData y = ([MultiPartParam], [MultiPartFile y]) +type MultiPartData = ([MultiPartParam], [MultiPartFile]) -- | Accept a "multipart/form-data" request. -- Files will be stored in a temporary directory and will be deleted -- automatically after the request is processed. -data ReqBodyMultipart y a next = ReqBodyMultipart - { reqMultiPartParse :: MultiPartData y -> Either String a +data ReqBodyMultipart a next = ReqBodyMultipart + { reqMultiPartParse :: MultiPartData -> Either String a , reqMultiPartNext :: a -> next } diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 7844574..18dca1b 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -172,7 +172,7 @@ instance (Aeson.FromJSON a, Router next) => Router (ReqBodyJSON a next) where instance Router next => Router (WithIO next) where tryRoute = tryRouteNextIO withIONext -instance (fp ~ FilePath, Router next) => Router (ReqBodyMultipart fp a next) where +instance (Router next) => Router (ReqBodyMultipart a next) where tryRoute req = flip fmap (tryRoute req) $ \nextRouter rmp cont -> runResourceT $ withInternalState $ \s -> do (params, fileInfos0) <- Wai.parseRequestBody (Wai.tempFileBackEnd s) req @@ -186,7 +186,7 @@ instance (fp ~ FilePath, Router next) => Router (ReqBodyMultipart fp a next) whe , mpfiContent = fileContent } ) - let multiPart :: MultiPartData FilePath = (params, fileInfos) + let multiPart :: MultiPartData = (params, fileInfos) case reqMultiPartParse rmp multiPart of Left err -> throwIO $ badRequest $ "Could not decode form request: " <> Text.pack err Right val -> nextRouter (reqMultiPartNext rmp val) cont @@ -251,7 +251,7 @@ instance Abbreviated next => Abbreviated (WithIO next) where type Brief (WithIO next) = IO (Brief next) brief = WithIO . fmap brief -instance Abbreviated (ReqBodyMultipart fp a next) +instance Abbreviated (ReqBodyMultipart a next) -- Generic routers diff --git a/solga-swagger/src/Solga/Swagger.hs b/solga-swagger/src/Solga/Swagger.hs index 015d385..3fedb90 100644 --- a/solga-swagger/src/Solga/Swagger.hs +++ b/solga-swagger/src/Solga/Swagger.hs @@ -136,7 +136,7 @@ instance RouterSwagger next => RouterSwagger (NoCache next) where instance RouterSwagger next => RouterSwagger (ExtraHeaders next) where genPaths = passPaths -instance RouterSwagger (ReqBodyMultipart fp a next) where +instance RouterSwagger (ReqBodyMultipart a next) where genPaths = noPaths instance RouterSwagger (OneOfSegs '[] next) where From eeeb8c55f54de3d803b650c8f553318c05b31708 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 11 Sep 2017 13:00:41 +0200 Subject: [PATCH 11/45] simple travis, build on nightly and lts 9 --- .travis.yml | 182 ++++------------------------------------------------ stack.yaml | 1 - 2 files changed, 13 insertions(+), 170 deletions(-) diff --git a/.travis.yml b/.travis.yml index 845c15e..5f4a7ab 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,177 +1,21 @@ -# Copy these contents into the root directory of your Github project in a file -# named .travis.yml - -# Use new container infrastructure to enable caching -language: c -dist: trusty -sudo: required - -# Caching so the next build will be fast too. +sudo: false +language: generic cache: directories: - - $HOME/.ghc - - $HOME/.cabal - $HOME/.stack - -# The different configurations we want to test. We have BUILD=cabal which uses -# cabal-install, and BUILD=stack which uses Stack. More documentation on each -# of those below. -# -# We set the compiler values here to tell Travis to use a different -# cache file per set of arguments. -# -# If you need to have different apt packages for each combination in the -# matrix, you can use a line such as: -# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} -matrix: - include: - # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: - # https://github.com/hvr/multi-ghc-travis - #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.0.4" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.2.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.4.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cab- if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then brew update ; fial GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.6.3" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.8.4" - # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - # - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.10.3" - # addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 8.0.1" - # addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # Build with the newest GHC and cabal-install. This is an accepted failure, - # see below. - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC HEAD" - addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS - # variable, such as using --stack-yaml to point to a different file. - - env: BUILD=stack ARGS="" - compiler: ": #stack default" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - #- env: BUILD=stack ARGS="--resolver lts-2" - # compiler: ": #stack 7.8.4" - # addons: {apt: {packages: [ghc-7.8.4], sources: [hvr-ghc]}} - - #- env: BUILD=stack ARGS="--resolver lts-3" - # compiler: ": #stack 7.10.2" - # addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} - - - env: BUILD=stack ARGS="--resolver lts-7" - compiler: ": #stack 8.0.1" - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - # Nightly builds are allowed to fail - - env: BUILD=stack ARGS="--resolver nightly" - compiler: ": #stack nightly" - addons: {apt: {packages: [libgmp-dev]}} - - # Build on OS X in addition to Linux - - env: BUILD=stack ARGS="" - compiler: ": #stack default osx" - os: osx - -# - env: BUILD=stack ARGS="--resolver lts-2" -# compiler: ": #stack 7.8.4 osx" -# os: osx - -# - env: BUILD=stack ARGS="--resolver lts-3" -# compiler: ": #stack 7.10.2 osx" -# os: osx - - - env: BUILD=stack ARGS="--resolver lts-7" - compiler: ": #stack 8.0.1 osx" - os: osx - - - env: BUILD=stack ARGS="--resolver nightly" - compiler: ": #stack nightly osx" - os: osx - - allow_failures: - - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - - env: BUILD=stack ARGS="--resolver lts-7" - +addons: + apt: + packages: + - libgmp-dev +env: +- ARGS="" +- ARGS="--resolver nightly-2017-09-10" before_install: -# Using compiler above sets CC to an invalid value, so unset it -- unset CC - -# We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" -- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi - -# Download and unpack the stack executable -- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH - mkdir -p ~/.local/bin -- | - if [ `uname` = "Darwin" ] - then - travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin - else - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - fi - - # Use the more reliable S3 mirror of Hackage - mkdir -p $HOME/.cabal - echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config - - if [ "$CABALVER" != "1.16" ] - then - echo 'jobs: $ncpus' >> $HOME/.cabal/config - fi - -# Get the list of packages from the stack.yaml file -- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - +- export PATH=$HOME/.local/bin:$PATH +- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' install: -- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" -- if [ -f configure.ac ]; then autoreconf -i; fi -- | - set -ex - case "$BUILD" in - stack) - stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies - ;; - cabal) - cabal --version - travis_retry cabal update - cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - ;; - esac - set +ex - +- stack --no-terminal --install-ghc $ARGS test --only-dependencies script: -- | - set -ex - case "$BUILD" in - stack) - stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps - ;; - cabal) - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES +- stack --no-terminal test --haddock --no-haddock-deps $ARGS - ORIGDIR=$(pwd) - for dir in $PACKAGES - do - cd $dir - cabal check || [ "$CABALVER" == "1.16" ] - cabal sdist - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") - cd $ORIGDIR - done - ;; - esac - set +ex diff --git a/stack.yaml b/stack.yaml index f9bccec..c5ebfba 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,6 @@ packages: # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: -- safe-exceptions-0.1.1.0 - aeson-1.2.1.0 # Override default flag values for local packages and extra-deps From 4257d7eb14b962157b3462ca67706f3829089343 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sat, 16 Sep 2017 12:04:21 +0200 Subject: [PATCH 12/45] use jsval-json for JSON stuf --- solga-client-ghcjs/solga-client-ghcjs.cabal | 1 + solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 29 ++++++++++++-------- stack-ghcjs.yaml | 4 +-- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index 1315970..9294218 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -19,6 +19,7 @@ library build-depends: base >= 4.8 && < 5, solga-core, ghcjs-base, + jsval-json, dlist hs-source-dirs: src default-language: Haskell2010 diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 2814d5c..797ed3a 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -18,8 +18,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE RecordWildCards #-} -module Solga.Client.GHCJS where - {- +module Solga.Client.GHCJS ( Client(..) , SomeRequestData(..) , choose @@ -27,8 +26,8 @@ module Solga.Client.GHCJS where , ToSegment(..) , WithData(..) , GetResponse(..) + , JSONResponse(..) ) where - -} import Data.Kind import Data.Proxy @@ -43,9 +42,8 @@ import Data.Typeable (Typeable) import qualified Data.DList as DList import Data.DList (DList) import Data.String (fromString) -import qualified JavaScript.JSON.Types.Class as Json -import qualified JavaScript.JSON.Types.Internal as Json -import GHCJS.Types (Immutable) +import qualified JavaScript.JSValJSON as Json +import Data.Traversable (for) import Solga.Core hiding (Header) @@ -172,16 +170,21 @@ instance (Client next, KnownSymbol method) => Client (Method method next) where newtype GetResponse resp a b = GetResponse {unGetResponse :: Xhr.Response resp -> a -> IO b} +newtype JSONResponse = JSONResponse {unJSONResponse :: Json.Value} + +instance Xhr.ResponseType JSONResponse where + getResponseTypeString _ = "json" + wrapResponseType = JSONResponse + instance (Json.FromJSON a) => Client (JSON a) where -- note that we do not decode eagerly because it's often the case that the body -- cannot be decoded since web servers return invalid json on errors -- (e.g. "Internal server error" on a 500 rather than a json encoded error) - type RequestData (JSON a) = GetResponse (Json.SomeValue Immutable) (Maybe (Either String a)) + type RequestData (JSON a) = GetResponse JSONResponse (IO (Maybe (Either String a))) performRequest _p req (GetResponse f) = do resp <- Xhr.xhr =<< toXhrRequest req - f resp $ do - data_ <- Xhr.contents resp - return (Json.parseEither Json.parseJSON data_) + f resp $ for (Xhr.contents resp) $ \(JSONResponse data_) -> + Json.runParser Json.parseJSON data_ instance (Client next) => Client (ExtraHeaders next) where type RequestData (ExtraHeaders next) = RequestData next @@ -193,8 +196,10 @@ instance (Client next) => Client (NoCache next) where instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) - performRequest _p req (WithData x perf) = performRequest - (Proxy @next) req{reqData = Xhr.StringData (Json.encode (Json.toJSON x))} perf + performRequest _p req (WithData x perf) = do + s <- Json.toJSONString =<< Json.toJSON x + performRequest + (Proxy @next) req{reqData = Xhr.StringData s} perf instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next diff --git a/stack-ghcjs.yaml b/stack-ghcjs.yaml index eccd01c..d2782f9 100644 --- a/stack-ghcjs.yaml +++ b/stack-ghcjs.yaml @@ -2,8 +2,8 @@ packages: - 'solga-core' - 'solga-client-ghcjs' - location: - git: git@github.com:bitonic/ghcjs-base.git - commit: e36e6be8a99a240c51319abd36827cc00e0c3cf2 + git: https://github.com/bitonic/jsval-json.git + commit: 5e24033a30afd832ed064be5c51621cf433baada extra-dep: true allow-newer: true flags: {} From 1302c758599ad4c38ce3c6c41786a22790350ac3 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 17 Sep 2017 00:20:47 +0200 Subject: [PATCH 13/45] export request in ghcjs solga --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 797ed3a..c8cefc5 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -27,6 +27,8 @@ module Solga.Client.GHCJS , WithData(..) , GetResponse(..) , JSONResponse(..) + , Request(..) + , Header ) where import Data.Kind @@ -211,3 +213,4 @@ instance (Client next) => Client (ReqBodyMultipart a next) where WithData (a, a -> [(JSString, Xhr.FormDataVal)]) (RequestData next) performRequest _p req (WithData (x, f) perf) = do performRequest (Proxy @next) req{reqData = Xhr.FormData (f x)} perf + From 3580b834a625bcef2069e9d3a4bce09c41187cca Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 17 Sep 2017 15:07:21 +0200 Subject: [PATCH 14/45] move FromSegment to Core --- solga-core/solga-core.cabal | 3 ++- solga-core/src/Solga/Core.hs | 10 ++++++++++ solga-router/src/Solga/Router.hs | 8 -------- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/solga-core/solga-core.cabal b/solga-core/solga-core.cabal index 054cf86..7df8ca4 100644 --- a/solga-core/solga-core.cabal +++ b/solga-core/solga-core.cabal @@ -18,7 +18,8 @@ library exposed-modules: Solga.Core build-depends: base >= 4.8 && < 5, case-insensitive, - bytestring + bytestring, + text hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index a20d437..4778f86 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -39,11 +39,14 @@ module Solga.Core , ReqBodyMultipart(..) , Endpoint , (:<|>)(..) + -- * FromSegment + , FromSegment(..) ) where import GHC.TypeLits import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) +import qualified Data.Text as T --------------------------------------------------- @@ -140,3 +143,10 @@ type Get a = Endpoint "GET" (JSON a) -- | Handle a "POST" request and produce a "JSON" response, with `IO`. type Post a = Endpoint "POST" (JSON a) +-- | The class of types that can be parsed from a path segment. +class FromSegment a where + fromSegment :: T.Text -> Maybe a + +instance FromSegment T.Text where + fromSegment = Just + diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 2fb98c2..3e53e59 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -26,7 +26,6 @@ module Solga.Router , notFound , internalServerError -- * Router implementation - , FromSegment(..) , Router(..) , Responder , tryRouteNext @@ -126,13 +125,6 @@ instance (KnownSymbol seg, Router next, Router (OneOfSegs segs next)) => Router instance Router next => Router (OneOfSegs '[] next) where tryRoute _ = Nothing --- | The class of types that can be parsed from a path segment. -class FromSegment a where - fromSegment :: Text.Text -> Maybe a - -instance FromSegment Text.Text where - fromSegment = Just - instance (FromSegment a, Router next) => Router (Capture a next) where tryRoute req = case Wai.pathInfo req of seg : segs -> do From 2d37ca36eae35487b984018e46444d4a2b0c4007 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 19 Sep 2017 19:07:56 +0200 Subject: [PATCH 15/45] add fromsegment for jsstring --- solga-core/solga-core.cabal | 3 +++ solga-core/src/Solga/Core.hs | 10 ++++++++++ 2 files changed, 13 insertions(+) diff --git a/solga-core/solga-core.cabal b/solga-core/solga-core.cabal index 7df8ca4..a817a4c 100644 --- a/solga-core/solga-core.cabal +++ b/solga-core/solga-core.cabal @@ -20,6 +20,9 @@ library case-insensitive, bytestring, text + if impl(ghcjs) + build-depends: + ghcjs-base hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index 4778f86..dc779eb 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -12,6 +12,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Solga.Core ( -- * Path components type (:>), type (/>) @@ -48,6 +49,11 @@ import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import qualified Data.Text as T +#if defined(ghcjs_HOST_OS) +import Data.JSString (JSString) +import Data.JSString.Text (textToJSString) +#endif + --------------------------------------------------- -- | Compose routers. This is just type application, @@ -150,3 +156,7 @@ class FromSegment a where instance FromSegment T.Text where fromSegment = Just +#if defined(ghcjs_HOST_OS) +instance FromSegment JSString where + fromSegment = Just . textToJSString +#endif From 3b286eb8760a3352dffe827ba75a2b4389ac169d Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 17:10:12 +0200 Subject: [PATCH 16/45] use ghcjs-dom to perform xhr --- solga-client-ghcjs/solga-client-ghcjs.cabal | 3 +- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 122 +++++++++++-------- stack-ghcjs.yaml | 3 + 3 files changed, 73 insertions(+), 55 deletions(-) diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index 9294218..15579ac 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -20,7 +20,8 @@ library solga-core, ghcjs-base, jsval-json, - dlist + dlist, + ghcjs-dom hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index c8cefc5..7391417 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -18,6 +18,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE JavaScriptFFI #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} module Solga.Client.GHCJS ( Client(..) , SomeRequestData(..) @@ -26,8 +31,8 @@ module Solga.Client.GHCJS , ToSegment(..) , WithData(..) , GetResponse(..) - , JSONResponse(..) , Request(..) + , Response(..) , Header ) where @@ -36,60 +41,41 @@ import Data.Proxy import GHC.Generics import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) import Data.Monoid ((<>)) -import qualified JavaScript.Web.XMLHttpRequest as Xhr -import Control.Exception (Exception, throwIO) import qualified Data.JSString as JSS import Data.JSString (JSString) -import Data.Typeable (Typeable) import qualified Data.DList as DList import Data.DList (DList) import Data.String (fromString) import qualified JavaScript.JSValJSON as Json -import Data.Traversable (for) +import qualified GHCJS.DOM.XMLHttpRequest as DOM +import qualified GHCJS.DOM.Types as DOM +import qualified GHCJS.DOM.Enums as DOM +import Data.Foldable (for_) import Solga.Core hiding (Header) -data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) - type Header = (JSString, JSString) -data Request = Request - { reqMethod :: String +data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request + { reqMethod :: JSString , reqHost :: JSString , reqSegments :: DList JSString , reqQueryString :: JSString - , reqData :: Xhr.RequestData - , reqLogin :: Maybe (JSString, JSString) + , reqUser :: Maybe JSString + , reqPassword :: Maybe JSString , reqHeaders :: [Header] - , reqWithCredentials :: Bool + , reqBody :: Maybe body + , reqXHR :: DOM.XMLHttpRequest + -- ^ will be used to send the request, useful if you want to set + -- events on it (e.g. onprogress) } -newtype BadMethod = BadMethod String - deriving (Eq, Show, Typeable) -instance Exception BadMethod +data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) foreign import javascript unsafe "encodeURI($1)" js_encodeURI :: JSString -> IO JSString -toXhrRequest :: Request -> IO Xhr.Request -toXhrRequest Request{..} = do - meth <- case reqMethod of - "GET" -> return Xhr.GET - "POST" -> return Xhr.POST - "PUT" -> return Xhr.PUT - "DELETE" -> return Xhr.DELETE - x -> throwIO (BadMethod x) - uri <- js_encodeURI (reqHost <> "/" <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) - return Xhr.Request - { Xhr.reqMethod = meth - , Xhr.reqURI = uri - , Xhr.reqLogin = reqLogin - , Xhr.reqHeaders = reqHeaders - , Xhr.reqWithCredentials = reqWithCredentials - , Xhr.reqData = reqData - } - class Client r where type RequestData r :: * -> * type RequestData r = SomeRequestData r @@ -156,8 +142,8 @@ instance ToSegment JSString where toSegment = id data WithData a next b = WithData - { ardData :: a - , ardNext :: next b + { wdData :: a + , wdNext :: next b } instance (Client next, ToSegment a) => Client (Capture a next) where @@ -168,25 +154,53 @@ instance (Client next, ToSegment a) => Client (Capture a next) where instance (Client next, KnownSymbol method) => Client (Method method next) where type RequestData (Method seg next) = RequestData next performRequest _p req perf = performRequest - (Proxy @next) req{reqMethod = symbolVal (Proxy @method)} perf - -newtype GetResponse resp a b = GetResponse {unGetResponse :: Xhr.Response resp -> a -> IO b} - -newtype JSONResponse = JSONResponse {unJSONResponse :: Json.Value} - -instance Xhr.ResponseType JSONResponse where - getResponseTypeString _ = "json" - wrapResponseType = JSONResponse + (Proxy @next) req{reqMethod = JSS.pack (symbolVal (Proxy @method))} perf + +data Response a = Response + { responseStatus :: Word + , responseBody :: a + } deriving (Functor, Foldable, Traversable) + +data XHRError = + XHRAborted + | XHRError + +newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> IO b} + +foreign import javascript interruptible + "h$anapoSendXHR($1, null, $c);" + js_send0 :: DOM.XMLHttpRequest -> IO Int +foreign import javascript interruptible + "h$anapoSendXHR($1, $2, $c);" + js_send1 :: DOM.XMLHttpRequest -> DOM.JSVal ->IO Int + +performXHR :: DOM.XMLHttpRequestResponseType -> Request -> IO (Either XHRError (Response DOM.JSVal)) +performXHR respType Request{..} = do + let xhr = reqXHR + DOM.setResponseType xhr respType + uri <- js_encodeURI (reqHost <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + DOM.open xhr reqMethod uri False reqUser reqPassword + for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) + r <- case reqBody of + Nothing -> js_send0 xhr + Just body -> js_send1 xhr =<< DOM.toJSVal body + case r of + 0 -> fmap Right $ do + status <- DOM.getStatus xhr + resp <- DOM.getResponse xhr + return (Response status resp) + 1 -> return (Left XHRAborted) + 2 -> return (Left XHRError) + _ -> error ("performXHR: bad return value " <> show r) instance (Json.FromJSON a) => Client (JSON a) where -- note that we do not decode eagerly because it's often the case that the body -- cannot be decoded since web servers return invalid json on errors -- (e.g. "Internal server error" on a 500 rather than a json encoded error) - type RequestData (JSON a) = GetResponse JSONResponse (IO (Maybe (Either String a))) + type RequestData (JSON a) = GetResponse (IO (Either String a)) performRequest _p req (GetResponse f) = do - resp <- Xhr.xhr =<< toXhrRequest req - f resp $ for (Xhr.contents resp) $ \(JSONResponse data_) -> - Json.runParser Json.parseJSON data_ + resp <- performXHR DOM.XMLHttpRequestResponseTypeJson req + f (fmap (fmap (Json.runParser Json.parseJSON)) resp) instance (Client next) => Client (ExtraHeaders next) where type RequestData (ExtraHeaders next) = RequestData next @@ -198,10 +212,10 @@ instance (Client next) => Client (NoCache next) where instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) - performRequest _p req (WithData x perf) = do + performRequest _p Request{..} (WithData x perf) = do s <- Json.toJSONString =<< Json.toJSON x performRequest - (Proxy @next) req{reqData = Xhr.StringData s} perf + (Proxy @next) Request{reqBody = Just s, ..} perf instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next @@ -210,7 +224,7 @@ instance (Client next) => Client (WithIO next) where instance (Client next) => Client (ReqBodyMultipart a next) where type RequestData (ReqBodyMultipart a next) = - WithData (a, a -> [(JSString, Xhr.FormDataVal)]) (RequestData next) - performRequest _p req (WithData (x, f) perf) = do - performRequest (Proxy @next) req{reqData = Xhr.FormData (f x)} perf - + WithData (a, a -> IO DOM.FormData) (RequestData next) + performRequest _p Request{..} (WithData (x, f) perf) = do + fd <- f x + performRequest (Proxy @next) Request{reqBody = Just fd, ..} perf diff --git a/stack-ghcjs.yaml b/stack-ghcjs.yaml index d2782f9..aaf1641 100644 --- a/stack-ghcjs.yaml +++ b/stack-ghcjs.yaml @@ -8,6 +8,9 @@ packages: allow-newer: true flags: {} extra-package-dbs: [] +extra-deps: +- ghcjs-dom-0.9.2.0 +- ghcjs-dom-jsffi-0.9.2.0 resolver: lts-8.11 compiler: ghcjs-0.2.1.9008011_ghc-8.0.2 From 1538232a7c184a054b709107fc974ec2616d09eb Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 17:35:33 +0200 Subject: [PATCH 17/45] export types --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 7391417..553ea1b 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -34,6 +34,7 @@ module Solga.Client.GHCJS , Request(..) , Response(..) , Header + , XHRError(..) ) where import Data.Kind From 21efab9ceb5ac732729a96d63db4512814be0ca6 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 17:43:41 +0200 Subject: [PATCH 18/45] Eq/Show instances for XHRError --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 553ea1b..aa30a76 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -165,6 +165,7 @@ data Response a = Response data XHRError = XHRAborted | XHRError + deriving (Eq, Show) newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> IO b} From bb4eed98bf915cce0a0cf8444e5d4e399dd02546 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 18:15:10 +0200 Subject: [PATCH 19/45] do async requests --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index aa30a76..082090e 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -181,7 +181,7 @@ performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType uri <- js_encodeURI (reqHost <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) - DOM.open xhr reqMethod uri False reqUser reqPassword + DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of Nothing -> js_send0 xhr From 1a1df45b9a00579615f7a67b4530e70459d763d3 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 18:21:42 +0200 Subject: [PATCH 20/45] add js file to js-sources --- solga-client-ghcjs/jsbits/xhr.js | 21 ++++++++++++++++++++ solga-client-ghcjs/solga-client-ghcjs.cabal | 1 + solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 4 ++-- 3 files changed, 24 insertions(+), 2 deletions(-) create mode 100644 solga-client-ghcjs/jsbits/xhr.js diff --git a/solga-client-ghcjs/jsbits/xhr.js b/solga-client-ghcjs/jsbits/xhr.js new file mode 100644 index 0000000..607041f --- /dev/null +++ b/solga-client-ghcjs/jsbits/xhr.js @@ -0,0 +1,21 @@ +// taken from +// +// see that page for license + +function h$solgaSendXHR(xhr, d, cont) { + xhr.addEventListener('error', function () { + cont(2); + }); + xhr.addEventListener('abort', function() { + cont(1); + }); + xhr.addEventListener('load', function() { + cont(0); + }); + if (d) { + xhr.send(d); + } else { + xhr.send(); + } +} + diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index 15579ac..79b240e 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -25,3 +25,4 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + js-sources: jsbits/xhr.js diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 082090e..dfe228a 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -170,10 +170,10 @@ data XHRError = newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> IO b} foreign import javascript interruptible - "h$anapoSendXHR($1, null, $c);" + "h$solgaSendXHR($1, null, $c);" js_send0 :: DOM.XMLHttpRequest -> IO Int foreign import javascript interruptible - "h$anapoSendXHR($1, $2, $c);" + "h$solgaSendXHR($1, $2, $c);" js_send1 :: DOM.XMLHttpRequest -> DOM.JSVal ->IO Int performXHR :: DOM.XMLHttpRequestResponseType -> Request -> IO (Either XHRError (Response DOM.JSVal)) From a3149222b938bd6e47813c2170c2f2834e58992b Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Sep 2017 18:38:44 +0200 Subject: [PATCH 21/45] start path from / --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index dfe228a..c2af29d 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -180,7 +180,7 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> IO (Either XHRError ( performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - uri <- js_encodeURI (reqHost <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + uri <- js_encodeURI (reqHost <> "/" <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of From 8b761dc54c9db11522bb8a9e3592579a95792b5a Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 27 Sep 2017 02:17:14 +0200 Subject: [PATCH 22/45] simpler multipart data --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index c2af29d..acfc159 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -226,7 +226,6 @@ instance (Client next) => Client (WithIO next) where instance (Client next) => Client (ReqBodyMultipart a next) where type RequestData (ReqBodyMultipart a next) = - WithData (a, a -> IO DOM.FormData) (RequestData next) - performRequest _p Request{..} (WithData (x, f) perf) = do - fd <- f x + WithData DOM.FormData (RequestData next) + performRequest _p Request{..} (WithData fd perf) = performRequest (Proxy @next) Request{reqBody = Just fd, ..} perf From 4f1a86d0d1901b01387280b328b465677d0c47a1 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 1 Oct 2017 19:41:20 +0200 Subject: [PATCH 23/45] build solga-client-ghcjs with normal ghc too --- solga-client-ghcjs/solga-client-ghcjs.cabal | 19 ++- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 131 ++++++++++++++----- stack.yaml | 11 ++ 3 files changed, 126 insertions(+), 35 deletions(-) diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index 79b240e..07ddc86 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -18,11 +18,24 @@ library exposed-modules: Solga.Client.GHCJS build-depends: base >= 4.8 && < 5, solga-core, - ghcjs-base, - jsval-json, dlist, ghcjs-dom + if !impl(ghcjs) + build-depends: + aeson, + uri-encode, + text, + bytestring, + jsaddle, + jsaddle-dom, + exceptions, + transformers + else + build-depends: + ghcjs-base, + jsval-json hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - js-sources: jsbits/xhr.js + if impl(ghcjs) + js-sources: jsbits/xhr.js diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index acfc159..735f7d5 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -23,6 +23,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} module Solga.Client.GHCJS ( Client(..) , SomeRequestData(..) @@ -42,28 +43,48 @@ import Data.Proxy import GHC.Generics import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) import Data.Monoid ((<>)) -import qualified Data.JSString as JSS -import Data.JSString (JSString) import qualified Data.DList as DList import Data.DList (DList) import Data.String (fromString) -import qualified JavaScript.JSValJSON as Json import qualified GHCJS.DOM.XMLHttpRequest as DOM import qualified GHCJS.DOM.Types as DOM import qualified GHCJS.DOM.Enums as DOM import Data.Foldable (for_) +import Control.Monad.IO.Class (liftIO) import Solga.Core hiding (Header) -type Header = (JSString, JSString) +#if defined(ghcjs_HOST_OS) +import qualified JavaScript.JSValJSON as Json +import Data.JSString (JSString) +import qualified Data.JSString as T +type Text = JSString +#else +import qualified Data.Aeson as Json +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.URI.Encode as Uri +import qualified Data.ByteString.Lazy as BSL +import qualified Language.Javascript.JSaddle as JSaddle +import Control.Concurrent.MVar (takeMVar, tryPutMVar, MVar, newEmptyMVar) +import qualified GHCJS.DOM.EventM as DOM.Event +import qualified GHCJS.DOM.XMLHttpRequestEventTarget as DOM.Event +import qualified JSDOM.Generated.XMLHttpRequest as DOM.XMLHttpRequest +import Control.Monad.Catch (bracket) +import Control.Monad (void) +import Control.Monad.Trans.Class (lift) +#endif + +type Header = (Text, Text) data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request - { reqMethod :: JSString - , reqHost :: JSString - , reqSegments :: DList JSString - , reqQueryString :: JSString - , reqUser :: Maybe JSString - , reqPassword :: Maybe JSString + { reqMethod :: Text + , reqHost :: Text + , reqSegments :: DList Text + , reqQueryString :: Text + , reqUser :: Maybe Text + , reqPassword :: Maybe Text , reqHeaders :: [Header] , reqBody :: Maybe body , reqXHR :: DOM.XMLHttpRequest @@ -73,18 +94,14 @@ data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request data SomeRequestData out a = forall in_. (Client in_) => SomeRequestData (Proxy in_) (RequestData in_ a) -foreign import javascript unsafe - "encodeURI($1)" - js_encodeURI :: JSString -> IO JSString - class Client r where type RequestData r :: * -> * type RequestData r = SomeRequestData r - performRequest :: proxy r -> Request -> RequestData r a -> IO a + performRequest :: proxy r -> Request -> RequestData r a -> DOM.JSM a default performRequest :: forall (proxy :: * -> *) a. (RequestData r ~ SomeRequestData r) - => proxy r -> Request -> RequestData r a -> IO a + => proxy r -> Request -> RequestData r a -> DOM.JSM a performRequest _p req (SomeRequestData p perf) = performRequest p req perf choose :: forall in_ out a. @@ -92,7 +109,7 @@ choose :: forall in_ out a. => (out -> in_) -> RequestData in_ a -> RequestData out a choose _f perf = SomeRequestData (Proxy @in_) perf -newtype RawRequest a = RawRequest {unRequestDataRaw :: Request -> IO a} +newtype RawRequest a = RawRequest {unRequestDataRaw :: Request -> DOM.JSM a} instance Client (Raw a) where type RequestData (Raw a) = RawRequest @@ -106,7 +123,7 @@ instance (Client next) => Client (End next) where type RequestData (End next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf -addSegment :: Request -> JSString -> Request +addSegment :: Request -> Text -> Request addSegment req seg = req{reqSegments = reqSegments req <> DList.singleton seg} instance (Client next, KnownSymbol seg) => Client (Seg seg next) where @@ -137,9 +154,9 @@ instance (Client next) => Client (OneOfSegs segs next) where performRequest (Proxy @next) (addSegment req (fromString (whichSeg ws))) perf class ToSegment a where - toSegment :: a -> JSString + toSegment :: a -> Text -instance ToSegment JSString where +instance ToSegment Text where toSegment = id data WithData a next b = WithData @@ -155,7 +172,7 @@ instance (Client next, ToSegment a) => Client (Capture a next) where instance (Client next, KnownSymbol method) => Client (Method method next) where type RequestData (Method seg next) = RequestData next performRequest _p req perf = performRequest - (Proxy @next) req{reqMethod = JSS.pack (symbolVal (Proxy @method))} perf + (Proxy @next) req{reqMethod = T.pack (symbolVal (Proxy @method))} perf data Response a = Response { responseStatus :: Word @@ -167,20 +184,25 @@ data XHRError = | XHRError deriving (Eq, Show) -newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> IO b} +newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> DOM.JSM b} +#if defined(ghcjs_HOST_OS) foreign import javascript interruptible "h$solgaSendXHR($1, null, $c);" js_send0 :: DOM.XMLHttpRequest -> IO Int foreign import javascript interruptible "h$solgaSendXHR($1, $2, $c);" - js_send1 :: DOM.XMLHttpRequest -> DOM.JSVal ->IO Int + js_send1 :: DOM.XMLHttpRequest -> DOM.JSVal -> IO Int -performXHR :: DOM.XMLHttpRequestResponseType -> Request -> IO (Either XHRError (Response DOM.JSVal)) +foreign import javascript unsafe + "encodeURI($1)" + js_encodeURI :: Text -> IO Text + +performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHRError (Response DOM.JSVal)) performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - uri <- js_encodeURI (reqHost <> "/" <> JSS.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + uri <- liftIO (js_encodeURI (reqHost <> "/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of @@ -204,21 +226,66 @@ instance (Json.FromJSON a) => Client (JSON a) where resp <- performXHR DOM.XMLHttpRequestResponseTypeJson req f (fmap (fmap (Json.runParser Json.parseJSON)) resp) -instance (Client next) => Client (ExtraHeaders next) where - type RequestData (ExtraHeaders next) = RequestData next - performRequest _p req perf = performRequest (Proxy @next) req perf +instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where + type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) + performRequest _p Request{..} (WithData x perf) = do + s <- Json.toJSONString =<< Json.toJSON x + performRequest + (Proxy @next) Request{reqBody = Just s, ..} perf -instance (Client next) => Client (NoCache next) where - type RequestData (NoCache next) = RequestData next - performRequest _p req perf = performRequest (Proxy @next) req perf +#else + +performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHRError (Response Text)) +performXHR respType Request{..} = do + let xhr = reqXHR + DOM.setResponseType xhr respType + let uri = Uri.encodeText (reqHost <> "/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + DOM.open xhr reqMethod uri True reqUser reqPassword + for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) + result :: MVar (Either XHRError (Response Text)) <- liftIO newEmptyMVar + let onLoad = lift $ do + status <- DOM.getStatus xhr + resp <- DOM.getResponseTextUnchecked xhr + void (liftIO (tryPutMVar result (Right (Response status resp)))) + bracket + (DOM.Event.on xhr DOM.Event.error (liftIO (void (tryPutMVar result (Left XHRError))))) + id + (\_ -> bracket + (DOM.Event.on xhr DOM.Event.abortEvent (liftIO (void (tryPutMVar result (Left XHRAborted))))) + id + (\_ -> bracket + (DOM.Event.on xhr DOM.Event.load onLoad) + id + (\_ -> do + DOM.XMLHttpRequest.send xhr reqBody + liftIO (takeMVar result)))) + +instance (Json.FromJSON a) => Client (JSON a) where + -- note that we do not decode eagerly because it's often the case that the body + -- cannot be decoded since web servers return invalid json on errors + -- (e.g. "Internal server error" on a 500 rather than a json encoded error) + type RequestData (JSON a) = GetResponse (DOM.JSM (Either String a)) + performRequest _p req (GetResponse f) = do + resp <- performXHR DOM.XMLHttpRequestResponseTypeText req + f (fmap (fmap (return . Json.eitherDecode . BSL.fromStrict . T.encodeUtf8)) resp) instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) performRequest _p Request{..} (WithData x perf) = do - s <- Json.toJSONString =<< Json.toJSON x + let s = JSaddle.toJSString (T.decodeUtf8 (BSL.toStrict (Json.encode x))) performRequest (Proxy @next) Request{reqBody = Just s, ..} perf +#endif + +instance (Client next) => Client (ExtraHeaders next) where + type RequestData (ExtraHeaders next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + +instance (Client next) => Client (NoCache next) where + type RequestData (NoCache next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf diff --git a/stack.yaml b/stack.yaml index c5ebfba..e94997b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,10 +10,21 @@ packages: - 'solga-core' - 'solga-router' - 'solga-client' +- 'solga-client-ghcjs' +- location: + git: https://github.com/bitonic/jsaddle.git + commit: 40b17863a3d4de7346e80937931cc04c8b4b3cd6 + subdirs: + - jsaddle + extra-dep: true # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: - aeson-1.2.1.0 +- ghcjs-dom-0.9.2.0 +- ghcjs-dom-jsaddle-0.9.2.0 +- jsaddle-dom-0.9.2.0 +- ref-tf-0.4.0.1 # Override default flag values for local packages and extra-deps flags: {} From 0a84ebacc65aa7e7ce920dfd6ad7f645dfe7c672 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 2 Oct 2017 14:34:32 +0200 Subject: [PATCH 24/45] disallow setting "host" in xhr request... ...since xhr requests are always in the same host --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 735f7d5..8fbc2be 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -80,7 +80,6 @@ type Header = (Text, Text) data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request { reqMethod :: Text - , reqHost :: Text , reqSegments :: DList Text , reqQueryString :: Text , reqUser :: Maybe Text @@ -202,7 +201,7 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - uri <- liftIO (js_encodeURI (reqHost <> "/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) + uri <- liftIO (js_encodeURI ("/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of @@ -239,7 +238,7 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - let uri = Uri.encodeText (reqHost <> "/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + let uri = Uri.encodeText ("/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) result :: MVar (Either XHRError (Response Text)) <- liftIO newEmptyMVar From f5d02e6e2e4680febce996efc339c22637870923 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 2 Oct 2017 15:25:16 +0200 Subject: [PATCH 25/45] do not prefix XHR path with / --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 8fbc2be..dfa1417 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -201,7 +201,7 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - uri <- liftIO (js_encodeURI ("/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) + uri <- liftIO (js_encodeURI (T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of @@ -238,7 +238,7 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - let uri = Uri.encodeText ("/" <> T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + let uri = Uri.encodeText (T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) result :: MVar (Either XHRError (Response Text)) <- liftIO newEmptyMVar From b0b2c91c1fad83c2ddb897be974043cb97a7078f Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Mon, 2 Oct 2017 16:10:01 +0200 Subject: [PATCH 26/45] correct uri escaping in haskell --- solga-client-ghcjs/solga-client-ghcjs.cabal | 5 ++-- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 24 ++++++++++++++++---- 2 files changed, 23 insertions(+), 6 deletions(-) diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index 07ddc86..c04dbc8 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -23,13 +23,14 @@ library if !impl(ghcjs) build-depends: aeson, - uri-encode, + http-types, text, bytestring, jsaddle, jsaddle-dom, exceptions, - transformers + transformers, + binary else build-depends: ghcjs-base, diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index dfa1417..5e4548c 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -64,7 +64,6 @@ import qualified Data.Aeson as Json import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Network.URI.Encode as Uri import qualified Data.ByteString.Lazy as BSL import qualified Language.Javascript.JSaddle as JSaddle import Control.Concurrent.MVar (takeMVar, tryPutMVar, MVar, newEmptyMVar) @@ -74,6 +73,8 @@ import qualified JSDOM.Generated.XMLHttpRequest as DOM.XMLHttpRequest import Control.Monad.Catch (bracket) import Control.Monad (void) import Control.Monad.Trans.Class (lift) +import qualified Network.HTTP.Types.URI as Http +import qualified Data.Binary.Builder as BB #endif type Header = (Text, Text) @@ -81,7 +82,7 @@ type Header = (Text, Text) data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request { reqMethod :: Text , reqSegments :: DList Text - , reqQueryString :: Text + , reqQuery :: DList (Text, Maybe Text) , reqUser :: Maybe Text , reqPassword :: Maybe Text , reqHeaders :: [Header] @@ -201,7 +202,18 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - uri <- liftIO (js_encodeURI (T.intercalate "/" (DList.toList reqSegments) <> reqQueryString)) + uri <- liftIO $ js_encodeURI $ + "/" <> + T.intercalate "/" (DList.toList reqSegments) <> + case DList.toList reqQuery of + [] -> "" + query -> + "?" <> T.intercalate "&" + [ case mbV of + Nothing -> k + Just v -> k <> "=" <> v + | (k, mbV) <- query + ] DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) r <- case reqBody of @@ -238,7 +250,11 @@ performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHREr performXHR respType Request{..} = do let xhr = reqXHR DOM.setResponseType xhr respType - let uri = Uri.encodeText (T.intercalate "/" (DList.toList reqSegments) <> reqQueryString) + let uri = T.decodeUtf8 $ BSL.toStrict $ BB.toLazyByteString $ Http.encodePath + (DList.toList reqSegments) + [ (T.encodeUtf8 k, fmap T.encodeUtf8 v) + | (k, v) <- DList.toList reqQuery + ] DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) result :: MVar (Either XHRError (Response Text)) <- liftIO newEmptyMVar From 3b16a747410ce4d2cbbadbb7426908d75388fbaa Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 4 Oct 2017 12:44:16 +0200 Subject: [PATCH 27/45] abort request on exception --- solga-client-ghcjs/jsbits/xhr.js | 21 ---- solga-client-ghcjs/solga-client-ghcjs.cabal | 10 +- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 115 ++++++++----------- 3 files changed, 55 insertions(+), 91 deletions(-) delete mode 100644 solga-client-ghcjs/jsbits/xhr.js diff --git a/solga-client-ghcjs/jsbits/xhr.js b/solga-client-ghcjs/jsbits/xhr.js deleted file mode 100644 index 607041f..0000000 --- a/solga-client-ghcjs/jsbits/xhr.js +++ /dev/null @@ -1,21 +0,0 @@ -// taken from -// -// see that page for license - -function h$solgaSendXHR(xhr, d, cont) { - xhr.addEventListener('error', function () { - cont(2); - }); - xhr.addEventListener('abort', function() { - cont(1); - }); - xhr.addEventListener('load', function() { - cont(0); - }); - if (d) { - xhr.send(d); - } else { - xhr.send(); - } -} - diff --git a/solga-client-ghcjs/solga-client-ghcjs.cabal b/solga-client-ghcjs/solga-client-ghcjs.cabal index c04dbc8..10057bf 100644 --- a/solga-client-ghcjs/solga-client-ghcjs.cabal +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -19,7 +19,9 @@ library build-depends: base >= 4.8 && < 5, solga-core, dlist, - ghcjs-dom + ghcjs-dom, + safe-exceptions, + transformers if !impl(ghcjs) build-depends: aeson, @@ -29,14 +31,12 @@ library jsaddle, jsaddle-dom, exceptions, - transformers, binary else build-depends: ghcjs-base, - jsval-json + jsval-json, + ghcjs-dom-jsffi hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - if impl(ghcjs) - js-sources: jsbits/xhr.js diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 5e4548c..3076575 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -51,6 +51,13 @@ import qualified GHCJS.DOM.Types as DOM import qualified GHCJS.DOM.Enums as DOM import Data.Foldable (for_) import Control.Monad.IO.Class (liftIO) +import Control.Exception.Safe (onException, bracket) +import Control.Concurrent.MVar (takeMVar, tryPutMVar, MVar, newEmptyMVar) +import qualified GHCJS.DOM.EventM as DOM.Event +import qualified GHCJS.DOM.XMLHttpRequestEventTarget as DOM.Event +import qualified GHCJS.DOM.XMLHttpRequest as DOM.XMLHttpRequest hiding (send) +import Control.Monad.Trans.Class (lift) +import Control.Monad (void) import Solga.Core hiding (Header) @@ -58,6 +65,7 @@ import Solga.Core hiding (Header) import qualified JavaScript.JSValJSON as Json import Data.JSString (JSString) import qualified Data.JSString as T +import qualified GHCJS.DOM.JSFFI.Generated.XMLHttpRequest as DOM.XMLHttpRequest type Text = JSString #else import qualified Data.Aeson as Json @@ -66,15 +74,9 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as BSL import qualified Language.Javascript.JSaddle as JSaddle -import Control.Concurrent.MVar (takeMVar, tryPutMVar, MVar, newEmptyMVar) -import qualified GHCJS.DOM.EventM as DOM.Event -import qualified GHCJS.DOM.XMLHttpRequestEventTarget as DOM.Event -import qualified JSDOM.Generated.XMLHttpRequest as DOM.XMLHttpRequest -import Control.Monad.Catch (bracket) -import Control.Monad (void) -import Control.Monad.Trans.Class (lift) import qualified Network.HTTP.Types.URI as Http import qualified Data.Binary.Builder as BB +import qualified JSDOM.Generated.XMLHttpRequest as DOM.XMLHttpRequest #endif type Header = (Text, Text) @@ -186,23 +188,10 @@ data XHRError = newtype GetResponse a b = GetResponse {unGetResponse :: Either XHRError (Response a) -> DOM.JSM b} +requestToUri :: Request -> DOM.JSM Text +requestToUri Request{..} = do #if defined(ghcjs_HOST_OS) -foreign import javascript interruptible - "h$solgaSendXHR($1, null, $c);" - js_send0 :: DOM.XMLHttpRequest -> IO Int -foreign import javascript interruptible - "h$solgaSendXHR($1, $2, $c);" - js_send1 :: DOM.XMLHttpRequest -> DOM.JSVal -> IO Int - -foreign import javascript unsafe - "encodeURI($1)" - js_encodeURI :: Text -> IO Text - -performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHRError (Response DOM.JSVal)) -performXHR respType Request{..} = do - let xhr = reqXHR - DOM.setResponseType xhr respType - uri <- liftIO $ js_encodeURI $ + liftIO $ js_encodeURI $ "/" <> T.intercalate "/" (DList.toList reqSegments) <> case DList.toList reqQuery of @@ -214,19 +203,44 @@ performXHR respType Request{..} = do Just v -> k <> "=" <> v | (k, mbV) <- query ] + +foreign import javascript unsafe + "encodeURI($1)" + js_encodeURI :: Text -> IO Text + +#else + return $ T.decodeUtf8 $ BSL.toStrict $ BB.toLazyByteString $ Http.encodePath + (DList.toList reqSegments) + [ (T.encodeUtf8 k, fmap T.encodeUtf8 v) + | (k, v) <- DList.toList reqQuery + ] +#endif + +performXHR :: forall a. (DOM.XMLHttpRequest -> DOM.JSM a) -> DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHRError (Response a)) +performXHR getResp respType req@Request{..} = do + let xhr = reqXHR + DOM.setResponseType xhr respType + uri <- requestToUri req DOM.open xhr reqMethod uri True reqUser reqPassword for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) - r <- case reqBody of - Nothing -> js_send0 xhr - Just body -> js_send1 xhr =<< DOM.toJSVal body - case r of - 0 -> fmap Right $ do - status <- DOM.getStatus xhr - resp <- DOM.getResponse xhr - return (Response status resp) - 1 -> return (Left XHRAborted) - 2 -> return (Left XHRError) - _ -> error ("performXHR: bad return value " <> show r) + result :: MVar (Either XHRError (Response a)) <- liftIO newEmptyMVar + let onLoad = lift $ do + status <- DOM.getStatus xhr + resp <- getResp xhr + void (liftIO (tryPutMVar result (Right (Response status resp)))) + let bracketId a b = bracket a id b + bracketId + (DOM.Event.on xhr DOM.Event.error (liftIO (void (tryPutMVar result (Left XHRError))))) + (\_ -> bracketId + (DOM.Event.on xhr DOM.Event.abortEvent (liftIO (void (tryPutMVar result (Left XHRAborted))))) + (\_ -> bracketId + (DOM.Event.on xhr DOM.Event.load onLoad) + (\_ -> + onException + (DOM.XMLHttpRequest.send xhr reqBody >> liftIO (takeMVar result)) + (DOM.XMLHttpRequest.abort xhr)))) + +#if defined(ghcjs_HOST_OS) instance (Json.FromJSON a) => Client (JSON a) where -- note that we do not decode eagerly because it's often the case that the body @@ -234,7 +248,7 @@ instance (Json.FromJSON a) => Client (JSON a) where -- (e.g. "Internal server error" on a 500 rather than a json encoded error) type RequestData (JSON a) = GetResponse (IO (Either String a)) performRequest _p req (GetResponse f) = do - resp <- performXHR DOM.XMLHttpRequestResponseTypeJson req + resp <- performXHR DOM.XMLHttpRequest.getResponse DOM.XMLHttpRequestResponseTypeJson req f (fmap (fmap (Json.runParser Json.parseJSON)) resp) instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where @@ -246,42 +260,13 @@ instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where #else -performXHR :: DOM.XMLHttpRequestResponseType -> Request -> DOM.JSM (Either XHRError (Response Text)) -performXHR respType Request{..} = do - let xhr = reqXHR - DOM.setResponseType xhr respType - let uri = T.decodeUtf8 $ BSL.toStrict $ BB.toLazyByteString $ Http.encodePath - (DList.toList reqSegments) - [ (T.encodeUtf8 k, fmap T.encodeUtf8 v) - | (k, v) <- DList.toList reqQuery - ] - DOM.open xhr reqMethod uri True reqUser reqPassword - for_ reqHeaders (uncurry (DOM.setRequestHeader xhr)) - result :: MVar (Either XHRError (Response Text)) <- liftIO newEmptyMVar - let onLoad = lift $ do - status <- DOM.getStatus xhr - resp <- DOM.getResponseTextUnchecked xhr - void (liftIO (tryPutMVar result (Right (Response status resp)))) - bracket - (DOM.Event.on xhr DOM.Event.error (liftIO (void (tryPutMVar result (Left XHRError))))) - id - (\_ -> bracket - (DOM.Event.on xhr DOM.Event.abortEvent (liftIO (void (tryPutMVar result (Left XHRAborted))))) - id - (\_ -> bracket - (DOM.Event.on xhr DOM.Event.load onLoad) - id - (\_ -> do - DOM.XMLHttpRequest.send xhr reqBody - liftIO (takeMVar result)))) - instance (Json.FromJSON a) => Client (JSON a) where -- note that we do not decode eagerly because it's often the case that the body -- cannot be decoded since web servers return invalid json on errors -- (e.g. "Internal server error" on a 500 rather than a json encoded error) type RequestData (JSON a) = GetResponse (DOM.JSM (Either String a)) performRequest _p req (GetResponse f) = do - resp <- performXHR DOM.XMLHttpRequestResponseTypeText req + resp <- performXHR DOM.getResponseTextUnchecked DOM.XMLHttpRequestResponseTypeText req f (fmap (fmap (return . Json.eitherDecode . BSL.fromStrict . T.encodeUtf8)) resp) instance (Client next, Json.ToJSON a) => Client (ReqBodyJSON a next) where From 9ec5547412c4b8ba0b37d5adb1149d3e028dc85e Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 12 Nov 2017 16:56:34 +0100 Subject: [PATCH 28/45] 8.2 fix --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 3076575..cdcd821 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -172,7 +172,7 @@ instance (Client next, ToSegment a) => Client (Capture a next) where performRequest (Proxy @next) (addSegment req (toSegment x)) perf instance (Client next, KnownSymbol method) => Client (Method method next) where - type RequestData (Method seg next) = RequestData next + type RequestData (Method method next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req{reqMethod = T.pack (symbolVal (Proxy @method))} perf From 8753517d5be840f5b6419ffff60360e2f705be50 Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Sun, 21 Jan 2018 14:08:15 +0100 Subject: [PATCH 29/45] requestBody -> strictRequestBody --- solga-router/src/Solga/Router.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 3e53e59..d700e14 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -159,8 +159,8 @@ instance (Aeson.FromJSON a, Router next) => Router (ReqBodyJSON a next) where tryRoute req = tryRouteNextIO getNext req where getNext rbj = do - reqBody <- Wai.requestBody req - case Aeson.eitherDecodeStrict reqBody of + reqBody <- Wai.strictRequestBody req + case Aeson.eitherDecode reqBody of Left err -> throwIO $ badRequest $ "Could not decode JSON request: " <> Text.pack (show err) Right val -> return (reqBodyJSONNext rbj val) From ae259ca79d5d32a44bab5188f876972bc2d03927 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 23 Jan 2018 09:28:59 +0100 Subject: [PATCH 30/45] add router to redirect on trailing slashes --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 4 ++++ solga-client/src/Solga/Client.hs | 4 ++++ solga-core/src/Solga/Core.hs | 3 +++ solga-router/src/Solga/Router.hs | 12 ++++++++++++ 4 files changed, 23 insertions(+) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index cdcd821..4a55ae7 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -286,6 +286,10 @@ instance (Client next) => Client (NoCache next) where type RequestData (NoCache next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf +instance (Client next) => Client (RedirectOnTrailingSlash next) where + type RequestData (RedirectOnTrailingSlash next) = RequestData next + performRequest _p req perf = performRequest (Proxy @next) req perf + instance (Client next) => Client (WithIO next) where type RequestData (WithIO next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf diff --git a/solga-client/src/Solga/Client.hs b/solga-client/src/Solga/Client.hs index e9ed5f7..4b22058 100644 --- a/solga-client/src/Solga/Client.hs +++ b/solga-client/src/Solga/Client.hs @@ -155,6 +155,10 @@ instance (Client next) => Client (NoCache next) where type RequestData (NoCache next) = RequestData next performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf +instance (Client next) => Client (RedirectOnTrailingSlash next) where + type RequestData (RedirectOnTrailingSlash next) = RequestData next + performRequest _p req mgr perf = performRequest (Proxy @next) req mgr perf + instance (Client next, Aeson.ToJSON a) => Client (ReqBodyJSON a next) where type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) performRequest _p req mgr (WithData x perf) = performRequest diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index dc779eb..e533a50 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -40,6 +40,7 @@ module Solga.Core , ReqBodyMultipart(..) , Endpoint , (:<|>)(..) + , RedirectOnTrailingSlash(..) -- * FromSegment , FromSegment(..) ) where @@ -160,3 +161,5 @@ instance FromSegment T.Text where instance FromSegment JSString where fromSegment = Just . textToJSString #endif + +newtype RedirectOnTrailingSlash next = RedirectOnTrailingSlash {unRedirectOnTrailingSlash :: next} diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index d700e14..24a65ca 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -186,6 +186,18 @@ instance (Router next) => Router (ReqBodyMultipart a next) where Left err -> throwIO $ badRequest $ "Could not decode form request: " <> Text.pack err Right val -> nextRouter (reqMultiPartNext rmp val) cont +instance (Router next) => Router (RedirectOnTrailingSlash next) where + tryRoute req = do + let pathi = Wai.pathInfo req + let continue = tryRouteNext unRedirectOnTrailingSlash req + if null pathi + then continue + else if last pathi == "" + then do + let resp = Wai.responseLBS HTTP.status301 [(HTTP.hLocation, Wai.rawPathInfo req)] "" + return (\_ cont -> cont resp) + else continue + -- | Most `Router`s are really just newtypes. By using `brief`, you can -- construct trees of `Router`s by providing only their inner types, much -- like Servant. From 4b1396a529180ddbbfb37fd88ed91d85f8228873 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 22 Apr 2018 13:15:01 +0200 Subject: [PATCH 31/45] do not catch all exceptions... ...otherwise warp `setOnException` does not work --- solga-router/src/Solga/Router.hs | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 24a65ca..4ccc49f 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -82,15 +82,12 @@ tryRouteNextIO f req = do next <- f router nextRouter next cont --- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses and other errors as HTTP 500. +-- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses. serve :: Router r => r -> Wai.Application serve router req cont = serveThrow router req cont - `catchAny` \someEx -> - let - ( status, body ) = case fromException someEx of - Just SolgaError { errorStatus, errorMessage } -> ( errorStatus, Builder.byteString $ encodeUtf8 errorMessage ) - Nothing -> ( HTTP.internalServerError500, "Internal Server Error" ) + `catch` \SolgaError{ errorStatus, errorMessage } -> + let ( status, body ) = ( errorStatus, Builder.byteString $ encodeUtf8 errorMessage ) in cont $ Wai.responseBuilder status [] body -- | Serve a `Router` with Solga, throwing `SolgaError`s. From a00277b35bce52965ddba0de6a89321b2295d9d8 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Sun, 22 Apr 2018 14:46:15 +0200 Subject: [PATCH 32/45] disable 500 tests for now in solga-client tests they use hspec-wai which has no exception handling logic and thus exceptions just crash. moreover, `error` out in the monad rather than in the response in the tests for the router, since warp just sends empty responses when the response itself contains errors. --- solga-client/test/Test.hs | 4 ++-- solga-router/test/Test.hs | 7 ------- 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/solga-client/test/Test.hs b/solga-client/test/Test.hs index bb995c0..f3a6dfc 100644 --- a/solga-client/test/Test.hs +++ b/solga-client/test/Test.hs @@ -47,7 +47,7 @@ testAPI :: TestAPI testAPI = TestAPI { basic = brief (return "basic") , echoJSON = brief return - , internalError = brief (return $ error "quality programming") + , internalError = brief (error "quality programming") , echoCapture = brief return } @@ -82,7 +82,7 @@ spec port = do -- tests exception handling describe "GET /fubar" $ do - it "responds with 500" $ + it "responds with 500" $ do req port $ choose internalError $ GetResponse $ \resp _ -> Http.responseStatus resp `shouldBe` status500 diff --git a/solga-router/test/Test.hs b/solga-router/test/Test.hs index 8b1d6ec..a674f0b 100644 --- a/solga-router/test/Test.hs +++ b/solga-router/test/Test.hs @@ -36,7 +36,6 @@ main = hspec spec data TestAPI = TestAPI { basic :: "basic" /> Get T.Text , echoJSON :: "echo-json" /> ReqBodyJSON Value :> Post Value - , internalError :: "fubar" /> Get T.Text , echoCapture :: "echo-capture" /> Capture T.Text :> Get T.Text } deriving (Generic) instance Router TestAPI @@ -45,7 +44,6 @@ testAPI :: TestAPI testAPI = TestAPI { basic = brief (return "basic") , echoJSON = brief return - , internalError = brief (return $ error "quality programming") , echoCapture = brief return } @@ -79,11 +77,6 @@ spec = with (return $ serve testAPI) $ do resp <- post "/echo-json" (encode val) liftIO $ decode (simpleBody resp) `shouldBe` Just (val :: Value) - -- tests exception handling - describe "GET /fubar" $ do - it "responds with 500" $ - get "/fubar" `shouldRespondWith` 500 - -- tests Capture describe "GET /echo-capture" $ do it "responds with 200" $ From 68ee849d20ac75ceac36879f9226449020aa6c95 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Thu, 25 Apr 2019 09:32:43 +0200 Subject: [PATCH 33/45] wrap paths parameter in braces as required by swagger spec --- solga-swagger/src/Solga/Swagger.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/solga-swagger/src/Solga/Swagger.hs b/solga-swagger/src/Solga/Swagger.hs index 3fedb90..fd10f7d 100644 --- a/solga-swagger/src/Solga/Swagger.hs +++ b/solga-swagger/src/Solga/Swagger.hs @@ -194,6 +194,6 @@ instance (Typeable a, ToParamSchema a, RouterSwagger next) => RouterSwagger (Cap let pOtherSchema = mempty & in_ .~ ParamPath & paramSchema .~ pSchema let param = mempty & name .~ paramName & required .~ Just True & schema .~ ParamOther pOtherSchema genPaths (nextProxy p) newCtx - { pathSegments = pathSegments ctx `DL.snoc` paramName + { pathSegments = pathSegments ctx `DL.snoc` ("{" <> paramName <> "}") , operationContext = operationContext newCtx & parameters <>~ [ Inline param ] } From 2a0b6fde7e2d9a71b7060619559854a81e6be1cf Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Thu, 4 Jul 2019 15:47:45 +0200 Subject: [PATCH 34/45] update stack.yaml to make it work with stack 2 --- stack.yaml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/stack.yaml b/stack.yaml index e94997b..112d700 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,12 +11,6 @@ packages: - 'solga-router' - 'solga-client' - 'solga-client-ghcjs' -- location: - git: https://github.com/bitonic/jsaddle.git - commit: 40b17863a3d4de7346e80937931cc04c8b4b3cd6 - subdirs: - - jsaddle - extra-dep: true # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: @@ -25,6 +19,10 @@ extra-deps: - ghcjs-dom-jsaddle-0.9.2.0 - jsaddle-dom-0.9.2.0 - ref-tf-0.4.0.1 +- git: https://github.com/bitonic/jsaddle.git + commit: 40b17863a3d4de7346e80937931cc04c8b4b3cd6 + subdirs: + - jsaddle # Override default flag values for local packages and extra-deps flags: {} From 835ec860ebdb09cf7316693825c1e82bf085933b Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 10 Jul 2019 22:37:17 +0200 Subject: [PATCH 35/45] solga-client-ghcjs: allow users to set base url for request --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 4a55ae7..307ef98 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -84,6 +84,7 @@ type Header = (Text, Text) data Request = forall body. (DOM.IsXMLHttpRequestBody body) => Request { reqMethod :: Text , reqSegments :: DList Text + , reqBaseUrl :: Text , reqQuery :: DList (Text, Maybe Text) , reqUser :: Maybe Text , reqPassword :: Maybe Text @@ -192,7 +193,7 @@ requestToUri :: Request -> DOM.JSM Text requestToUri Request{..} = do #if defined(ghcjs_HOST_OS) liftIO $ js_encodeURI $ - "/" <> + reqBaseUrl <> T.intercalate "/" (DList.toList reqSegments) <> case DList.toList reqQuery of [] -> "" From 5ebda23c5cf6f7c678de8f76ce66326f59e8d7ff Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Sun, 6 May 2018 21:05:01 +0200 Subject: [PATCH 36/45] Add WithReferer. --- solga-core/src/Solga/Core.hs | 3 +++ solga-router/src/Solga/Router.hs | 8 ++++++++ 2 files changed, 11 insertions(+) diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index e533a50..9b3e44b 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -41,6 +41,7 @@ module Solga.Core , Endpoint , (:<|>)(..) , RedirectOnTrailingSlash(..) + , WithReferer(..) -- * FromSegment , FromSegment(..) ) where @@ -163,3 +164,5 @@ instance FromSegment JSString where #endif newtype RedirectOnTrailingSlash next = RedirectOnTrailingSlash {unRedirectOnTrailingSlash :: next} + +newtype WithReferer next = WithReferer { withRefererNext :: Maybe ByteString -> next } \ No newline at end of file diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 4ccc49f..8b1d68b 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -38,6 +38,7 @@ import Control.Monad import Control.Monad.Trans.Resource import qualified Data.Aeson as Aeson import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as Char8 import qualified Data.Map.Strict as Map import Data.Monoid @@ -195,6 +196,9 @@ instance (Router next) => Router (RedirectOnTrailingSlash next) where return (\_ cont -> cont resp) else continue +instance Router next => Router (WithReferer next) where + tryRoute req = tryRouteNext (\(WithReferer f) -> f (Wai.requestHeaderReferer req)) req + -- | Most `Router`s are really just newtypes. By using `brief`, you can -- construct trees of `Router`s by providing only their inner types, much -- like Servant. @@ -257,6 +261,10 @@ instance Abbreviated next => Abbreviated (WithIO next) where instance Abbreviated (ReqBodyMultipart a next) +instance Abbreviated next => Abbreviated (WithReferer next) where + type Brief (WithReferer next) = Maybe BS.ByteString -> Brief next + brief = WithReferer . fmap brief + -- Generic routers deriving instance Router r => Router (K1 i r p) From 7b68cf2985d8585f487bc044aab113609d53f56a Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 7 Apr 2020 18:45:22 +0200 Subject: [PATCH 37/45] wip --- stack.yaml | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/stack.yaml b/stack.yaml index 112d700..b00e827 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,7 +1,7 @@ # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -resolver: lts-9.0 +resolver: lts-14.22 # Local packages, usually specified by relative directory name packages: @@ -11,18 +11,16 @@ packages: - 'solga-router' - 'solga-client' - 'solga-client-ghcjs' +- 'solga-typescript' # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: -- aeson-1.2.1.0 -- ghcjs-dom-0.9.2.0 -- ghcjs-dom-jsaddle-0.9.2.0 -- jsaddle-dom-0.9.2.0 -- ref-tf-0.4.0.1 -- git: https://github.com/bitonic/jsaddle.git - commit: 40b17863a3d4de7346e80937931cc04c8b4b3cd6 - subdirs: - - jsaddle +- ghcjs-dom-0.9.4.0 +- ghcjs-dom-jsaddle-0.9.4.0 +- jsaddle-dom-0.9.4.0 +- jsaddle-0.9.7.0 +- ref-tf-0.4.0.2 +- aeson-typescript-0.2.0.0 # Override default flag values for local packages and extra-deps flags: {} From 731fb54ab288f9399cbb84dcf2434d43f1db57b3 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 18:24:21 +0200 Subject: [PATCH 38/45] Allow to "hide" routes from the client --- solga-client-ghcjs/src/Solga/Client/GHCJS.hs | 8 ++++++++ solga-client/src/Solga/Client.hs | 8 ++++++++ solga-core/src/Solga/Core.hs | 7 ++++++- solga-router/src/Solga/Router.hs | 9 +++++++++ stack.yaml | 2 -- 5 files changed, 31 insertions(+), 3 deletions(-) diff --git a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs index 307ef98..baef158 100644 --- a/solga-client-ghcjs/src/Solga/Client/GHCJS.hs +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -24,6 +24,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} module Solga.Client.GHCJS ( Client(..) , SomeRequestData(..) @@ -36,6 +37,7 @@ module Solga.Client.GHCJS , Response(..) , Header , XHRError(..) + , HiddenRequestData ) where import Data.Kind @@ -126,6 +128,12 @@ instance (Client next) => Client (End next) where type RequestData (End next) = RequestData next performRequest _p req perf = performRequest (Proxy @next) req perf +data HiddenRequestData a + +instance Client (Hidden next) where + type RequestData (Hidden next) = HiddenRequestData + performRequest _p _req perf = case perf of {} + addSegment :: Request -> Text -> Request addSegment req seg = req{reqSegments = reqSegments req <> DList.singleton seg} diff --git a/solga-client/src/Solga/Client.hs b/solga-client/src/Solga/Client.hs index 4b22058..b481bc2 100644 --- a/solga-client/src/Solga/Client.hs +++ b/solga-client/src/Solga/Client.hs @@ -17,6 +17,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE EmptyCase #-} module Solga.Client ( Client(..) , SomeRequestData(..) @@ -25,6 +26,7 @@ module Solga.Client , ToSegment(..) , WithData(..) , GetResponse(..) + , HiddenRequestData ) where import Data.Kind @@ -78,6 +80,12 @@ instance (Client next) => Client (End next) where type RequestData (End next) = RequestData next performRequest _p mgr req perf = performRequest (Proxy @next) mgr req perf +data HiddenRequestData a + +instance Client (Hidden next) where + type RequestData (Hidden next) = HiddenRequestData + performRequest _p _mgr _req perf = case perf of {} + addSegment :: Http.Request -> Text -> Http.Request addSegment req segtxt = req { Http.path = if BS.null (Http.path req) || BSC8.last (Http.path req) == '/' diff --git a/solga-core/src/Solga/Core.hs b/solga-core/src/Solga/Core.hs index 9b3e44b..4a47226 100644 --- a/solga-core/src/Solga/Core.hs +++ b/solga-core/src/Solga/Core.hs @@ -42,6 +42,7 @@ module Solga.Core , (:<|>)(..) , RedirectOnTrailingSlash(..) , WithReferer(..) + , Hidden(..) -- * FromSegment , FromSegment(..) ) where @@ -165,4 +166,8 @@ instance FromSegment JSString where newtype RedirectOnTrailingSlash next = RedirectOnTrailingSlash {unRedirectOnTrailingSlash :: next} -newtype WithReferer next = WithReferer { withRefererNext :: Maybe ByteString -> next } \ No newline at end of file +newtype WithReferer next = WithReferer { withRefererNext :: Maybe ByteString -> next } + +-- | To hide from client libraries +newtype Hidden next = Hidden {hiddenNext :: next} + diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 8b1d68b..584c4dd 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -108,6 +108,11 @@ instance Router next => Router (End next) where [] -> tryRouteNext endNext req _ -> Nothing +instance Router next => Router (Hidden next) where + tryRoute req = case Wai.pathInfo req of + [] -> tryRouteNext hiddenNext req + _ -> Nothing + instance (KnownSymbol seg, Router next) => Router (Seg seg next) where tryRoute req = case Wai.pathInfo req of s : segs | Text.unpack s == symbolVal (Proxy :: Proxy seg) -> @@ -221,6 +226,10 @@ instance Abbreviated next => Abbreviated (End next) where type Brief (End next) = Brief next brief = End . brief +instance Abbreviated next => Abbreviated (Hidden next) where + type Brief (Hidden next) = Brief next + brief = Hidden . brief + instance Abbreviated next => Abbreviated (Seg seg next) where type Brief (Seg seg next) = Brief next brief = Seg . brief diff --git a/stack.yaml b/stack.yaml index b00e827..8cc4eda 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,7 +11,6 @@ packages: - 'solga-router' - 'solga-client' - 'solga-client-ghcjs' -- 'solga-typescript' # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: @@ -20,7 +19,6 @@ extra-deps: - jsaddle-dom-0.9.4.0 - jsaddle-0.9.7.0 - ref-tf-0.4.0.2 -- aeson-typescript-0.2.0.0 # Override default flag values for local packages and extra-deps flags: {} From 8dbb7c9c4a00735ec6c42f45ac62015be73a5bf6 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 18:28:39 +0200 Subject: [PATCH 39/45] Add support for TypeScript --- solga-typescript/LICENSE | 20 ++ solga-typescript/Setup.hs | 2 + solga-typescript/solga-typescript.cabal | 29 ++ solga-typescript/src/Solga/TypeScript.hs | 328 +++++++++++++++++++++++ stack.yaml | 3 + 5 files changed, 382 insertions(+) create mode 100644 solga-typescript/LICENSE create mode 100644 solga-typescript/Setup.hs create mode 100644 solga-typescript/solga-typescript.cabal create mode 100644 solga-typescript/src/Solga/TypeScript.hs diff --git a/solga-typescript/LICENSE b/solga-typescript/LICENSE new file mode 100644 index 0000000..da000dc --- /dev/null +++ b/solga-typescript/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2020 Francesco Mazzoli + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/solga-typescript/Setup.hs b/solga-typescript/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/solga-typescript/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/solga-typescript/solga-typescript.cabal b/solga-typescript/solga-typescript.cabal new file mode 100644 index 0000000..bc06be3 --- /dev/null +++ b/solga-typescript/solga-typescript.cabal @@ -0,0 +1,29 @@ +name: solga-typescript +version: 0.1.0.0 +synopsis: TypeScript types generation for Solga +description: TypeScript types generation for Solga +license: MIT +license-file: LICENSE +author: Francesco Mazzoli +maintainer: f@mazzo.li +copyright: Copyright (C) 2019 Francesco Mazzoli +category: Web +build-type: Simple +homepage: https://github.com/chpatrick/solga +bug-reports: https://github.com/chpatrick/solga/issues +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Solga.TypeScript + build-depends: base >= 4.8 && < 5, + solga-core, + aeson-typescript, + aeson, + text, + unordered-containers, + containers, + dlist + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs new file mode 100644 index 0000000..a057505 --- /dev/null +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +module Solga.TypeScript + ( Info(..) + , Paths(..) + , TypeScriptRoute(..) + , typeScript + ) where + +import qualified Data.Aeson.TypeScript.TH as Aeson +import qualified Data.Aeson.TypeScript.Recursive as Aeson +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HMS +import Solga.Core +import Data.Maybe (isJust, fromMaybe) +import GHC.TypeLits +import Data.Proxy +import GHC.Generics +import qualified Data.DList as DL +import Data.List (foldl') +import Data.Monoid ((<>)) +import Control.Monad (guard) +import qualified Data.Set as S + +{- +export class TypeScriptRoute { + private http: { fetch(url: RequestInfo, init?: RequestInit): Promise }; + private baseUrl: string; + + constructor(baseUrl?: string, http?: { fetch(url: RequestInfo, init?: RequestInit): Promise }) { + this.http = http ? http : window; + this.baseUrl = baseUrl ? baseUrl : ""; + } +} +-} + +{- +data Foo a b = Foo { foo1 :: a, foo2 :: b } + +deriveTypeScript (defaultOptions {fieldLabelModifier = drop 3, constructorTagModifier = map toLower}) ''Foo + +data Bar = Bar (Foo Int Bool) Int + +deriveTypeScript (defaultOptions {fieldLabelModifier = drop 3, constructorTagModifier = map toLower}) ''Bar +-} + +-- The strategy is to build a single TypeScript type to represent all the possible +-- requests that we can do. + +data Info = Info + { infoReqJSON :: Maybe T.Text + , infoReqMultiPart :: Bool + , infoRespJSON :: Maybe T.Text + , infoRespRaw :: Bool + , infoMethod :: Maybe T.Text + } deriving (Eq, Show) + +data Paths = + PathsCapture (DL.DList Paths) + | PathsMatch [Text] (DL.DList Paths) -- match any of these + | PathsEnd Info + | PathsNothing + deriving (Eq, Show) + +generateTypeScript :: forall a. (TypeScriptRoute a) => Proxy a -> Either String (DL.DList Paths, S.Set Aeson.TSType) +generateTypeScript _ = typeScriptRoute (Proxy @a) Info + { infoReqJSON = Nothing + , infoReqMultiPart = False + , infoRespJSON = Nothing + , infoRespRaw = False + , infoMethod = Nothing + } + +class TypeScriptRoute a where + typeScriptRoute :: Proxy a -> Info -> Either String (DL.DList Paths, S.Set Aeson.TSType) + default typeScriptRoute :: (TypeScriptRoute (Rep a ())) => Proxy a -> Info -> Either String (DL.DList Paths, S.Set Aeson.TSType) + typeScriptRoute _ = typeScriptRoute (Proxy @(Rep a ())) + +instance TypeScriptRoute (Raw a) where + typeScriptRoute _ _info = return mempty + +instance (TypeScriptRoute a) => TypeScriptRoute (End a) where + typeScriptRoute _ = typeScriptRoute (Proxy @a) + +instance TypeScriptRoute (RawResponse a) where + typeScriptRoute _ info = return (pure (PathsEnd info{infoRespRaw = True}), mempty) + +instance (Aeson.TypeScript a) => TypeScriptRoute (JSON a) where + typeScriptRoute _ info = return + ( pure (PathsEnd info{infoRespJSON = Just (T.pack (Aeson.getTypeScriptType (Proxy @a)))}) + , S.singleton (Aeson.TSType (Proxy @a)) + ) + +instance (KnownSymbol seg, TypeScriptRoute next) => TypeScriptRoute (Seg seg next) where + typeScriptRoute _ info = do + (paths, types) <- typeScriptRoute (Proxy @next) info + return (pure (PathsMatch [T.pack (symbolVal (Proxy :: Proxy seg))] paths), types) + +instance (TypeScriptRoute left, TypeScriptRoute right) => TypeScriptRoute (left :<|> right) where + typeScriptRoute _ info = mappend <$> typeScriptRoute (Proxy @left) info <*> typeScriptRoute (Proxy @right) info + +class SymbolList (a :: [Symbol]) where + symbolList :: Proxy a -> [T.Text] + +instance SymbolList '[] where + symbolList _ = [] + +instance (KnownSymbol seg, SymbolList segs) => SymbolList (seg ': segs) where + symbolList _ = T.pack (symbolVal (Proxy @seg)) : symbolList (Proxy @segs) + +instance (SymbolList segs, TypeScriptRoute next) => TypeScriptRoute (OneOfSegs segs next) where + typeScriptRoute _ info = do + let segs = symbolList (Proxy @segs) + (paths, types) <- typeScriptRoute (Proxy @next) info + return (pure (PathsMatch segs paths), types) + +instance (TypeScriptRoute next) => TypeScriptRoute (Capture a next) where + typeScriptRoute _ info = do + (paths, types) <- typeScriptRoute (Proxy @next) info + return (pure (PathsCapture paths), types) + +instance (TypeScriptRoute next, KnownSymbol method) => TypeScriptRoute (Method method next) where + typeScriptRoute _ info = case infoMethod info of + Nothing -> typeScriptRoute (Proxy @next) info{infoMethod = Just (T.pack (symbolVal (Proxy @method)))} + Just{} -> Left "Method set multiple times!" + +instance (TypeScriptRoute next) => TypeScriptRoute (ExtraHeaders next) where + typeScriptRoute _ = typeScriptRoute (Proxy @next) + +instance (TypeScriptRoute next) => TypeScriptRoute (NoCache next) where + typeScriptRoute _ = typeScriptRoute (Proxy @next) + +instance (TypeScriptRoute next, Aeson.TypeScript a) => TypeScriptRoute (ReqBodyJSON a next) where + typeScriptRoute _ info = case infoReqJSON info of + Just{} -> Left "Req body set multiple times!" + Nothing -> do + (paths, types) <- typeScriptRoute (Proxy @next) info{infoReqJSON = Just (T.pack (Aeson.getTypeScriptType (Proxy @a)))} + return (paths, S.insert (Aeson.TSType (Proxy @a)) types) + +instance (TypeScriptRoute next) => TypeScriptRoute (WithIO next) where + typeScriptRoute _ = typeScriptRoute (Proxy @next) + +instance (TypeScriptRoute next) => TypeScriptRoute (ReqBodyMultipart a next) where + typeScriptRoute _ info = if infoReqMultiPart info + then Left "Req body set multiple times!" + else typeScriptRoute (Proxy @next) info{infoReqMultiPart = True} + +instance (TypeScriptRoute next) => TypeScriptRoute (WithReferer next) where + typeScriptRoute _ = typeScriptRoute (Proxy @next) + +-- Generic +-- -------------------------------------------------------------------- + +instance TypeScriptRoute r => TypeScriptRoute (K1 i r p) where + typeScriptRoute _ = typeScriptRoute (Proxy @r) + +instance TypeScriptRoute (f p) => TypeScriptRoute (M1 i c f p) where + typeScriptRoute _ = typeScriptRoute (Proxy :: Proxy (f p)) + +instance (TypeScriptRoute (left p), TypeScriptRoute (right p)) => TypeScriptRoute ((left :*: right) p) where + typeScriptRoute _ info = mappend <$> typeScriptRoute (Proxy @(left p)) info <*> typeScriptRoute (Proxy @(right p)) info + +-- To hide from TypeScript +-- -------------------------------------------------------------------- + +instance (TypeScriptRoute next) => TypeScriptRoute (Hidden next) where + typeScriptRoute _ _ = return (pure PathsNothing, mempty) + +-- Computing the typescript stuff +-- -------------------------------------------------------------------- + +-- env.seg("blah").param("foo").send("json-body"); + +data TypeScriptReq + = TSRMultipart + | TSRJson T.Text + | TSRNoBody + +data TypeScriptSend = TypeScriptSend + { tssMethod :: T.Text + , tssReq :: TypeScriptReq + , tssResp :: T.Text + } + +data TypeScriptDict = TypeScriptDict + { tsdSegments :: HMS.HashMap T.Text TypeScriptDict + , tsdCapture :: Maybe TypeScriptDict + , tsdSend :: Maybe TypeScriptSend + } + +data TypeScriptSeg + = TSSConst T.Text + | TSSVar T.Text + +typeScript :: (TypeScriptRoute a) => Proxy a -> T.Text -> T.Text +typeScript p name = case generateTypeScript p of + Left err -> error err + Right (paths, types) -> let + dict = go paths + in T.unlines + [ T.pack $ Aeson.formatTSDeclarations $ do + Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types) + Aeson.getTypeScriptDeclarations typ + , "" + , "interface Send {" + , " send(url: string, method: string): Promise," + , " sendJson(url: string, method: string, req: A): Promise," + , " sendForm(url: string, method: string, req: FormData): Promise," + , "}" + , "function " <> name <> "(baseUrl: string, send: Send): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" + ] + where + emptyDict = TypeScriptDict{ tsdSegments = mempty, tsdCapture = Nothing, tsdSend = Nothing } + + go paths = goFields emptyDict (DL.toList paths) + + goFields dict = \case + [] -> dict + path : paths -> goFields (pathToField dict path) paths + + dictNonEmpty dict = isJust (tsdSend dict) || isJust (tsdCapture dict) || HMS.size (tsdSegments dict) > 0 + + mergeDicts dict1 dict2 = TypeScriptDict + { tsdCapture = case (tsdCapture dict1, tsdCapture dict2) of + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> x <$ guard (dictNonEmpty x) + (Nothing, Just x) -> x <$ guard (dictNonEmpty x) + (Just x, Just y) -> let z = mergeDicts x y in z <$ guard (dictNonEmpty z) + , tsdSegments = HMS.filter dictNonEmpty (HMS.unionWith mergeDicts (tsdSegments dict1) (tsdSegments dict2)) + , tsdSend = case (tsdSend dict1, tsdSend dict2) of + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> Just x + (Nothing, Just x) -> Just x + (Just{}, Just{}) -> error "Conflicting sends" + } + + pathToField dict0 = \case + PathsCapture paths -> mergeDicts dict0 (emptyDict { tsdCapture = Just (go paths) }) + PathsEnd info -> if infoRespRaw info + then dict0 + else let + req = case (infoReqMultiPart info, infoReqJSON info) of + (True, Nothing) -> TSRMultipart + (False, Just j) -> TSRJson j + (True, Just{}) -> error "Got both multipart and json req body" + (False, Nothing) -> TSRNoBody + in mergeDicts dict0 emptyDict{ tsdSend = Just TypeScriptSend{ tssMethod = fromMaybe "GET" (infoMethod info), tssReq = req, tssResp = fromMaybe "void" (infoRespJSON info) } } + PathsMatch segs paths -> let + pathsDict = go paths + in foldl' (\dict seg -> mergeDicts dict emptyDict{ tsdSegments = HMS.singleton seg pathsDict }) dict0 segs + PathsNothing -> dict0 + + renderDictType dict = T.concat $ concat + [ ["{"] + , case tsdSend dict of + Nothing -> [] + Just TypeScriptSend{..} -> + [ "\"send\": (" <> + (case tssReq of + TSRJson j -> "req: " <> j + TSRMultipart -> "req: FormData" + TSRNoBody -> "") <> + ") => Promise<" <> tssResp <> ">" + ] + , case tsdCapture dict of + Nothing -> [] + Just ty -> ["\"param\": (p: string) => " <> renderDictType ty <> ", "] + , if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesTypes (tsdSegments dict)] else [] + , ["}"] + ] + + renderRoutesTypes segs = T.concat $ concat + [ ["{"] + , do + (seg, ty) <- HMS.toList segs + return (T.pack (show seg) <> ": " <> renderDictType ty <> ", ") + , ["}"] + ] + + renderDictExpr sendVar baseUrlVar segs dict = T.concat $ concat + [ ["{"] + , case tsdSend dict of + Nothing -> [] + Just TypeScriptSend{..} -> let + segToExpr = \case + TSSConst c -> T.pack (show c) + TSSVar v -> v + urlExpr = baseUrlVar <> " + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')" + in + [ "\"send\": (" <> + (case tssReq of + TSRJson j -> "req: " <> j + TSRMultipart -> "req: FormData" + TSRNoBody -> "") <> + "): Promise<" <> tssResp <> "> => { return " <> + (case tssReq of + TSRJson{} -> sendVar <> ".sendJson(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" + TSRMultipart{} -> sendVar <> ".sendForm(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" + TSRNoBody{} -> sendVar <> ".send(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ")") <> "; }," + ] + , case tsdCapture dict of + Nothing -> [] + Just ty -> let + v = "param" <> T.pack (show (length segs)) + in ["\"param\": (" <> v <> ": string): " <> renderDictType ty <> " => { return " <> renderDictExpr sendVar baseUrlVar (TSSVar v : segs) ty <> "; }, "] + , if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesExprs sendVar baseUrlVar segs (tsdSegments dict)] else [] + , ["}"] + ] + + renderRoutesExprs sendVar baseUrlVar segs newSegs = T.concat $ concat + [ ["{"] + , do + (seg, ty) <- HMS.toList newSegs + return (T.pack (show seg) <> ": " <> renderDictExpr sendVar baseUrlVar (TSSConst seg : segs) ty <> ", ") + , ["}"] + ] diff --git a/stack.yaml b/stack.yaml index 8cc4eda..b5c3609 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,6 +11,7 @@ packages: - 'solga-router' - 'solga-client' - 'solga-client-ghcjs' +- 'solga-typescript' # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) extra-deps: @@ -19,6 +20,8 @@ extra-deps: - jsaddle-dom-0.9.4.0 - jsaddle-0.9.7.0 - ref-tf-0.4.0.2 +- git: https://github.com/bitonic/aeson-typescript.git + commit: 9dd14a8172f3cd715b07a3d9ec8cd1e049020215 # Override default flag values for local packages and extra-deps flags: {} From 5bf3ec33a24c267782b09cb3e1af4d084ee46108 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 23:21:09 +0200 Subject: [PATCH 40/45] routes => route in TypeScript --- solga-typescript/src/Solga/TypeScript.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs index a057505..c69920f 100644 --- a/solga-typescript/src/Solga/TypeScript.hs +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -214,12 +214,7 @@ typeScript p name = case generateTypeScript p of Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types) Aeson.getTypeScriptDeclarations typ , "" - , "interface Send {" - , " send(url: string, method: string): Promise," - , " sendJson(url: string, method: string, req: A): Promise," - , " sendForm(url: string, method: string, req: FormData): Promise," - , "}" - , "function " <> name <> "(baseUrl: string, send: Send): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" + , "export function " <> name <> "(baseUrl: string, send: {send(url: string, method: string): Promise, sendJson(url: string, method: string, req: A): Promise, sendForm(url: string, method: string, req: FormData): Promise}): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" ] where emptyDict = TypeScriptDict{ tsdSegments = mempty, tsdCapture = Nothing, tsdSend = Nothing } @@ -277,7 +272,7 @@ typeScript p name = case generateTypeScript p of , case tsdCapture dict of Nothing -> [] Just ty -> ["\"param\": (p: string) => " <> renderDictType ty <> ", "] - , if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesTypes (tsdSegments dict)] else [] + , if HMS.size (tsdSegments dict) > 0 then ["\"route\": " <> renderRoutesTypes (tsdSegments dict)] else [] , ["}"] ] @@ -315,7 +310,7 @@ typeScript p name = case generateTypeScript p of Just ty -> let v = "param" <> T.pack (show (length segs)) in ["\"param\": (" <> v <> ": string): " <> renderDictType ty <> " => { return " <> renderDictExpr sendVar baseUrlVar (TSSVar v : segs) ty <> "; }, "] - , if HMS.size (tsdSegments dict) > 0 then ["\"routes\": " <> renderRoutesExprs sendVar baseUrlVar segs (tsdSegments dict)] else [] + , if HMS.size (tsdSegments dict) > 0 then ["\"route\": " <> renderRoutesExprs sendVar baseUrlVar segs (tsdSegments dict)] else [] , ["}"] ] From 512188814fe2cb6d90f7c9a7274bfa6e88cfef55 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 23:21:24 +0200 Subject: [PATCH 41/45] export TypeScript types --- solga-typescript/src/Solga/TypeScript.hs | 8 +++++--- stack.yaml | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs index c69920f..adc7f2c 100644 --- a/solga-typescript/src/Solga/TypeScript.hs +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -210,9 +210,11 @@ typeScript p name = case generateTypeScript p of Right (paths, types) -> let dict = go paths in T.unlines - [ T.pack $ Aeson.formatTSDeclarations $ do - Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types) - Aeson.getTypeScriptDeclarations typ + [ T.pack $ Aeson.formatTSDeclarations' + Aeson.defaultFormattingOptions{ Aeson.exportTypes = True } + (do + Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types) + Aeson.getTypeScriptDeclarations typ) , "" , "export function " <> name <> "(baseUrl: string, send: {send(url: string, method: string): Promise, sendJson(url: string, method: string, req: A): Promise, sendForm(url: string, method: string, req: FormData): Promise}): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" ] diff --git a/stack.yaml b/stack.yaml index b5c3609..6f2e759 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,7 +21,7 @@ extra-deps: - jsaddle-0.9.7.0 - ref-tf-0.4.0.2 - git: https://github.com/bitonic/aeson-typescript.git - commit: 9dd14a8172f3cd715b07a3d9ec8cd1e049020215 + commit: 13822f06e45b632446bf6e9b6e8368c060e159b5 # Override default flag values for local packages and extra-deps flags: {} From 4198a41394e227601f78081369bfa450db66edf0 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 8 Apr 2020 23:42:12 +0200 Subject: [PATCH 42/45] allow to provide additional TypeScript types --- solga-typescript/src/Solga/TypeScript.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs index adc7f2c..ca577c4 100644 --- a/solga-typescript/src/Solga/TypeScript.hs +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -204,8 +204,14 @@ data TypeScriptSeg = TSSConst T.Text | TSSVar T.Text -typeScript :: (TypeScriptRoute a) => Proxy a -> T.Text -> T.Text -typeScript p name = case generateTypeScript p of +typeScript :: + (TypeScriptRoute a) + => Proxy a + -> [Aeson.TSType] + -- ^ Additional types that we want to add + -> T.Text + -> T.Text +typeScript p additionalTypes name = case generateTypeScript p of Left err -> error err Right (paths, types) -> let dict = go paths @@ -213,7 +219,7 @@ typeScript p name = case generateTypeScript p of [ T.pack $ Aeson.formatTSDeclarations' Aeson.defaultFormattingOptions{ Aeson.exportTypes = True } (do - Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure types) + Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure (S.union types (S.fromList additionalTypes))) Aeson.getTypeScriptDeclarations typ) , "" , "export function " <> name <> "(baseUrl: string, send: {send(url: string, method: string): Promise, sendJson(url: string, method: string, req: A): Promise, sendForm(url: string, method: string, req: FormData): Promise}): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" From ac0ff609ba2606e1627f9ce9fc2ff03788cd96a7 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Wed, 22 Apr 2020 19:15:26 +0200 Subject: [PATCH 43/45] Fix bad instance for `Hidden` --- solga-router/src/Solga/Router.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/solga-router/src/Solga/Router.hs b/solga-router/src/Solga/Router.hs index 584c4dd..c6cc9be 100644 --- a/solga-router/src/Solga/Router.hs +++ b/solga-router/src/Solga/Router.hs @@ -109,9 +109,7 @@ instance Router next => Router (End next) where _ -> Nothing instance Router next => Router (Hidden next) where - tryRoute req = case Wai.pathInfo req of - [] -> tryRouteNext hiddenNext req - _ -> Nothing + tryRoute = tryRouteNext hiddenNext instance (KnownSymbol seg, Router next) => Router (Seg seg next) where tryRoute req = case Wai.pathInfo req of From 9ae00ea8cd5156b12a9cbf3db4ca712782cf6f92 Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Tue, 26 Jan 2021 15:38:34 +0100 Subject: [PATCH 44/45] solga-typescript: Specify how to send data at the end... ...this allows, for example, to plumb in `AbortController`s more easily. --- solga-typescript/src/Solga/TypeScript.hs | 40 +++++++++++++++--------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs index ca577c4..a5f6b0b 100644 --- a/solga-typescript/src/Solga/TypeScript.hs +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -204,6 +204,16 @@ data TypeScriptSeg = TSSConst T.Text | TSSVar T.Text + +sendFunctions :: T.Text +sendFunctions = + " export interface SendFunctions { \ + \ baseUrl: string; \ + \ send(url: string, method: string): Promise, \ + \ sendJson(url: string, method: string, req: A): Promise, \ + \ sendForm(url: string, method: string, req: FormData): Promise \ + \ }" + typeScript :: (TypeScriptRoute a) => Proxy a @@ -222,7 +232,9 @@ typeScript p additionalTypes name = case generateTypeScript p of Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure (S.union types (S.fromList additionalTypes))) Aeson.getTypeScriptDeclarations typ) , "" - , "export function " <> name <> "(baseUrl: string, send: {send(url: string, method: string): Promise, sendJson(url: string, method: string, req: A): Promise, sendForm(url: string, method: string, req: FormData): Promise}): " <> renderDictType dict <> " { return " <> renderDictExpr "send" "baseUrl" [] dict <> "; }" + , sendFunctions + , "" + , "export const " <> name <> ": " <> renderDictType dict <> " = " <> renderDictExpr [] dict <> ";" ] where emptyDict = TypeScriptDict{ tsdSegments = mempty, tsdCapture = Nothing, tsdSend = Nothing } @@ -270,7 +282,7 @@ typeScript p additionalTypes name = case generateTypeScript p of , case tsdSend dict of Nothing -> [] Just TypeScriptSend{..} -> - [ "\"send\": (" <> + [ "\"s\": (_: SendFunctions, " <> (case tssReq of TSRJson j -> "req: " <> j TSRMultipart -> "req: FormData" @@ -279,8 +291,8 @@ typeScript p additionalTypes name = case generateTypeScript p of ] , case tsdCapture dict of Nothing -> [] - Just ty -> ["\"param\": (p: string) => " <> renderDictType ty <> ", "] - , if HMS.size (tsdSegments dict) > 0 then ["\"route\": " <> renderRoutesTypes (tsdSegments dict)] else [] + Just ty -> ["\"p\": (_: string) => " <> renderDictType ty <> ", "] + , if HMS.size (tsdSegments dict) > 0 then ["\"r\": " <> renderRoutesTypes (tsdSegments dict)] else [] , ["}"] ] @@ -292,7 +304,7 @@ typeScript p additionalTypes name = case generateTypeScript p of , ["}"] ] - renderDictExpr sendVar baseUrlVar segs dict = T.concat $ concat + renderDictExpr segs dict = T.concat $ concat [ ["{"] , case tsdSend dict of Nothing -> [] @@ -300,32 +312,32 @@ typeScript p additionalTypes name = case generateTypeScript p of segToExpr = \case TSSConst c -> T.pack (show c) TSSVar v -> v - urlExpr = baseUrlVar <> " + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')" + urlExpr = "sf.baseUrl + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')" in - [ "\"send\": (" <> + [ "\"s\": (sf: SendFunctions, " <> (case tssReq of TSRJson j -> "req: " <> j TSRMultipart -> "req: FormData" TSRNoBody -> "") <> "): Promise<" <> tssResp <> "> => { return " <> (case tssReq of - TSRJson{} -> sendVar <> ".sendJson(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" - TSRMultipart{} -> sendVar <> ".sendForm(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" - TSRNoBody{} -> sendVar <> ".send(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ")") <> "; }," + TSRJson{} -> "sf.sendJson(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" + TSRMultipart{} -> "sf.sendForm(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" + TSRNoBody{} -> "sf.send(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ")") <> "; }," ] , case tsdCapture dict of Nothing -> [] Just ty -> let v = "param" <> T.pack (show (length segs)) - in ["\"param\": (" <> v <> ": string): " <> renderDictType ty <> " => { return " <> renderDictExpr sendVar baseUrlVar (TSSVar v : segs) ty <> "; }, "] - , if HMS.size (tsdSegments dict) > 0 then ["\"route\": " <> renderRoutesExprs sendVar baseUrlVar segs (tsdSegments dict)] else [] + in ["\"p\": (" <> v <> ": string): " <> renderDictType ty <> " => { return " <> renderDictExpr (TSSVar v : segs) ty <> "; }, "] + , if HMS.size (tsdSegments dict) > 0 then ["\"r\": " <> renderRoutesExprs segs (tsdSegments dict)] else [] , ["}"] ] - renderRoutesExprs sendVar baseUrlVar segs newSegs = T.concat $ concat + renderRoutesExprs segs newSegs = T.concat $ concat [ ["{"] , do (seg, ty) <- HMS.toList newSegs - return (T.pack (show seg) <> ": " <> renderDictExpr sendVar baseUrlVar (TSSConst seg : segs) ty <> ", ") + return (T.pack (show seg) <> ": " <> renderDictExpr (TSSConst seg : segs) ty <> ", ") , ["}"] ] From 5ac687377f0c31897d0f2b0fc2ed21a2fa08c5bd Mon Sep 17 00:00:00 2001 From: Francesco Mazzoli Date: Fri, 19 Mar 2021 18:01:11 +0100 Subject: [PATCH 45/45] typescript: Allow to push headers when requesting --- solga-typescript/solga-typescript.cabal | 3 +- solga-typescript/src/Solga/TypeScript.hs | 82 +++++++++++++++++------- 2 files changed, 60 insertions(+), 25 deletions(-) diff --git a/solga-typescript/solga-typescript.cabal b/solga-typescript/solga-typescript.cabal index bc06be3..988339d 100644 --- a/solga-typescript/solga-typescript.cabal +++ b/solga-typescript/solga-typescript.cabal @@ -23,7 +23,8 @@ library text, unordered-containers, containers, - dlist + dlist, + case-insensitive hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/solga-typescript/src/Solga/TypeScript.hs b/solga-typescript/src/Solga/TypeScript.hs index a5f6b0b..3f09b82 100644 --- a/solga-typescript/src/Solga/TypeScript.hs +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -12,7 +12,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} module Solga.TypeScript - ( Info(..) + ( HeaderInfo(..) + , Info(..) , Paths(..) , TypeScriptRoute(..) , typeScript @@ -33,6 +34,7 @@ import Data.List (foldl') import Data.Monoid ((<>)) import Control.Monad (guard) import qualified Data.Set as S +import qualified Data.CaseInsensitive as CI {- export class TypeScriptRoute { @@ -59,9 +61,14 @@ deriveTypeScript (defaultOptions {fieldLabelModifier = drop 3, constructorTagMod -- The strategy is to build a single TypeScript type to represent all the possible -- requests that we can do. +data HeaderInfo = HeaderInfo + { hiOptional :: Bool } + deriving (Eq, Show) + data Info = Info { infoReqJSON :: Maybe T.Text , infoReqMultiPart :: Bool + , infoReqHeaders :: HMS.HashMap (CI.CI T.Text) HeaderInfo , infoRespJSON :: Maybe T.Text , infoRespRaw :: Bool , infoMethod :: Maybe T.Text @@ -78,6 +85,7 @@ generateTypeScript :: forall a. (TypeScriptRoute a) => Proxy a -> Either String generateTypeScript _ = typeScriptRoute (Proxy @a) Info { infoReqJSON = Nothing , infoReqMultiPart = False + , infoReqHeaders = mempty , infoRespJSON = Nothing , infoRespRaw = False , infoMethod = Nothing @@ -191,6 +199,7 @@ data TypeScriptReq data TypeScriptSend = TypeScriptSend { tssMethod :: T.Text , tssReq :: TypeScriptReq + , tssHeaders :: HMS.HashMap (CI.CI T.Text) HeaderInfo , tssResp :: T.Text } @@ -209,9 +218,9 @@ sendFunctions :: T.Text sendFunctions = " export interface SendFunctions { \ \ baseUrl: string; \ - \ send(url: string, method: string): Promise, \ - \ sendJson(url: string, method: string, req: A): Promise, \ - \ sendForm(url: string, method: string, req: FormData): Promise \ + \ send(url: string, method: string, headers: {[k: string]: string | undefined}): Promise, \ + \ sendJson(url: string, method: string, headers: {[k: string]: string | undefined}, req: A): Promise, \ + \ sendForm(url: string, method: string, headers: {[k: string]: string | undefined}, req: FormData): Promise \ \ }" typeScript :: @@ -271,7 +280,14 @@ typeScript p additionalTypes name = case generateTypeScript p of (False, Just j) -> TSRJson j (True, Just{}) -> error "Got both multipart and json req body" (False, Nothing) -> TSRNoBody - in mergeDicts dict0 emptyDict{ tsdSend = Just TypeScriptSend{ tssMethod = fromMaybe "GET" (infoMethod info), tssReq = req, tssResp = fromMaybe "void" (infoRespJSON info) } } + in mergeDicts dict0 emptyDict + { tsdSend = Just TypeScriptSend + { tssMethod = fromMaybe "GET" (infoMethod info) + , tssReq = req + , tssResp = fromMaybe "void" (infoRespJSON info) + , tssHeaders = infoReqHeaders info + } + } PathsMatch segs paths -> let pathsDict = go paths in foldl' (\dict seg -> mergeDicts dict emptyDict{ tsdSegments = HMS.singleton seg pathsDict }) dict0 segs @@ -281,14 +297,18 @@ typeScript p additionalTypes name = case generateTypeScript p of [ ["{"] , case tsdSend dict of Nothing -> [] - Just TypeScriptSend{..} -> - [ "\"s\": (_: SendFunctions, " <> - (case tssReq of - TSRJson j -> "req: " <> j - TSRMultipart -> "req: FormData" - TSRNoBody -> "") <> - ") => Promise<" <> tssResp <> ">" - ] + Just TypeScriptSend{..} -> let + args = T.intercalate ", " $ concat + [ [ "_sf: SendFunctions" ] + , if HMS.size tssHeaders == 0 + then [] + else [ "_hs: {" <> T.intercalate "," [T.pack (show (CI.original k)) <> if hiOptional v then "?: string" else ": string" | (k, v) <- HMS.toList tssHeaders ] <> "}" ] + , case tssReq of + TSRJson j -> [ "req: " <> j ] + TSRMultipart -> [ "req: FormData" ] + TSRNoBody -> [] + ] + in [ "\"s\": (" <> args <> ") => Promise<" <> tssResp <> ">" ] , case tsdCapture dict of Nothing -> [] Just ty -> ["\"p\": (_: string) => " <> renderDictType ty <> ", "] @@ -313,18 +333,32 @@ typeScript p additionalTypes name = case generateTypeScript p of TSSConst c -> T.pack (show c) TSSVar v -> v urlExpr = "sf.baseUrl + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')" - in - [ "\"s\": (sf: SendFunctions, " <> - (case tssReq of - TSRJson j -> "req: " <> j - TSRMultipart -> "req: FormData" - TSRNoBody -> "") <> - "): Promise<" <> tssResp <> "> => { return " <> - (case tssReq of - TSRJson{} -> "sf.sendJson(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" - TSRMultipart{} -> "sf.sendForm(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ", req)" - TSRNoBody{} -> "sf.send(" <> urlExpr <> ", " <> T.pack (show tssMethod) <> ")") <> "; }," + args = T.intercalate "," $ concat + [ [ "sf: SendFunctions" ] + , if HMS.size tssHeaders == 0 + then [] + else [ "headers: {" <> T.intercalate "," [T.pack (show (CI.original k)) <> if hiOptional v then "?: string" else ": string" | (k, v) <- HMS.toList tssHeaders ] <> "}" ] + , case tssReq of + TSRJson j -> [ "req: " <> j ] + TSRMultipart -> [ "req: FormData" ] + TSRNoBody -> [] + ] + sendFunction = case tssReq of + TSRJson{} -> "sf.sendJson" + TSRMultipart{} -> "sf.sendForm" + TSRNoBody{} -> "sf.send" + sendArgs = T.intercalate "," $ concat + [ [ urlExpr, T.pack (show tssMethod) ] + , if HMS.size tssHeaders == 0 + then [ "{}" ] + else [ "headers" ] + , case tssReq of + TSRJson{} -> [ "req" ] + TSRMultipart{} -> [ "req" ] + TSRNoBody{} -> [] ] + in + [ "\"s\": (" <> args <> "): Promise<" <> tssResp <> "> => { return " <> sendFunction <> "(" <> sendArgs <> "); }," ] , case tsdCapture dict of Nothing -> [] Just ty -> let