diff --git a/.travis.yml b/.travis.yml index fad01fd..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 \ No newline at end of file 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..10057bf --- /dev/null +++ b/solga-client-ghcjs/solga-client-ghcjs.cabal @@ -0,0 +1,42 @@ +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, + dlist, + ghcjs-dom, + safe-exceptions, + transformers + if !impl(ghcjs) + build-depends: + aeson, + http-types, + text, + bytestring, + jsaddle, + jsaddle-dom, + exceptions, + binary + else + build-depends: + ghcjs-base, + jsval-json, + ghcjs-dom-jsffi + 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..baef158 --- /dev/null +++ b/solga-client-ghcjs/src/Solga/Client/GHCJS.hs @@ -0,0 +1,311 @@ +{-# 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 #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyCase #-} +module Solga.Client.GHCJS + ( Client(..) + , SomeRequestData(..) + , choose + , RawRequest(..) + , ToSegment(..) + , WithData(..) + , GetResponse(..) + , Request(..) + , Response(..) + , Header + , XHRError(..) + , HiddenRequestData + ) where + +import Data.Kind +import Data.Proxy +import GHC.Generics +import GHC.TypeLits (symbolVal, KnownSymbol, Symbol) +import Data.Monoid ((<>)) +import qualified Data.DList as DList +import Data.DList (DList) +import Data.String (fromString) +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 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) + +#if defined(ghcjs_HOST_OS) +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 +import Data.Text (Text) +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 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) + +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 + , reqHeaders :: [Header] + , 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) + } + +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 -> Request -> RequestData r a -> DOM.JSM a + default + performRequest :: forall (proxy :: * -> *) a. + (RequestData r ~ SomeRequestData r) + => proxy r -> Request -> RequestData r a -> DOM.JSM 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 -> DOM.JSM 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 + +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} + +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 -> Text + +instance ToSegment Text where + toSegment = id + +data WithData a next b = WithData + { wdData :: a + , wdNext :: 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 method next) = RequestData next + performRequest _p req perf = performRequest + (Proxy @next) req{reqMethod = T.pack (symbolVal (Proxy @method))} perf + +data Response a = Response + { responseStatus :: Word + , responseBody :: a + } deriving (Functor, Foldable, Traversable) + +data XHRError = + XHRAborted + | XHRError + deriving (Eq, Show) + +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) + liftIO $ js_encodeURI $ + reqBaseUrl <> + 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 + ] + +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)) + 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 + -- 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 (IO (Either String a)) + performRequest _p req (GetResponse f) = do + 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 + 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 + +#else + +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.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 + type RequestData (ReqBodyJSON a next) = WithData a (RequestData next) + performRequest _p Request{..} (WithData x perf) = do + 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 (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 + +instance (Client next) => Client (ReqBodyMultipart a next) where + type + RequestData (ReqBodyMultipart a next) = + WithData DOM.FormData (RequestData next) + performRequest _p Request{..} (WithData fd perf) = + performRequest (Proxy @next) Request{reqBody = Just fd, ..} perf 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..b481bc2 --- /dev/null +++ b/solga-client/src/Solga/Client.hs @@ -0,0 +1,189 @@ +{-# 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 #-} +{-# LANGUAGE EmptyCase #-} +module Solga.Client + ( Client(..) + , SomeRequestData(..) + , choose + , RawRequest(..) + , ToSegment(..) + , WithData(..) + , GetResponse(..) + , HiddenRequestData + ) 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 + +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) == '/' + 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 method 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) => 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 + (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 a next) where + type + 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 + 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..f3a6dfc --- /dev/null +++ b/solga-client/test/Test.hs @@ -0,0 +1,138 @@ +{-# 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 (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" $ do + 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') + +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/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..a817a4c --- /dev/null +++ b/solga-core/solga-core.cabal @@ -0,0 +1,29 @@ +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, + 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 new file mode 100644 index 0000000..4a47226 --- /dev/null +++ b/solga-core/src/Solga/Core.hs @@ -0,0 +1,173 @@ +{-# 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 CPP #-} +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 + , (:<|>)(..) + , RedirectOnTrailingSlash(..) + , WithReferer(..) + , Hidden(..) + -- * FromSegment + , FromSegment(..) + ) where + +import GHC.TypeLits +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, +-- 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 = (ByteString, MultiPartFileInfo) + +data MultiPartFileInfo = MultiPartFileInfo + { mpfiName :: ByteString + , mpfiContentType :: ByteString + , mpfiContent :: FilePath + } + +-- | A parsed "multipart/form-data" request. +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 a next = ReqBodyMultipart + { reqMultiPartParse :: MultiPartData -> 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) + +-- | 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 + +#if defined(ghcjs_HOST_OS) +instance FromSegment JSString where + fromSegment = Just . textToJSString +#endif + +newtype RedirectOnTrailingSlash next = RedirectOnTrailingSlash {unRedirectOnTrailingSlash :: next} + +newtype WithReferer next = WithReferer { withRefererNext :: Maybe ByteString -> next } + +-- | To hide from client libraries +newtype Hidden next = Hidden {hiddenNext :: next} + 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..6087be5 --- /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.2.1.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..c6cc9be --- /dev/null +++ b/solga-router/src/Solga/Router.hs @@ -0,0 +1,329 @@ +{-# 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 + , unauthorized + , forbidden + , notFound + , internalServerError + -- * Router implementation + , 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 as BS +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. +serve :: Router r => r -> Wai.Application +serve router req cont = + serveThrow router req cont + `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. +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 Router next => Router (Hidden next) where + tryRoute = tryRouteNext hiddenNext + +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 + +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.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) + +instance Router next => Router (WithIO next) where + tryRoute = tryRouteNextIO withIONext + +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 + let fileInfos = do + (parName, Wai.FileInfo{..}) <- fileInfos0 + return + ( parName + , MultiPartFileInfo + { mpfiName = fileName + , mpfiContentType = fileContentType + , mpfiContent = fileContent + } + ) + 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 + +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 + +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. +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 (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 + +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) + +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) +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 @401 Unauthorized@ error with a given message. +unauthorized :: Text.Text -> SolgaError +unauthorized msg = SolgaError + { errorStatus = HTTP.unauthorized401 + , 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 + { 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-router/test/Test.hs similarity index 92% rename from solga/test/Test.hs rename to solga-router/test/Test.hs index 4ed30aa..a674f0b 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 @@ -35,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 @@ -44,7 +44,6 @@ testAPI :: TestAPI testAPI = TestAPI { basic = brief (return "basic") , echoJSON = brief return - , internalError = brief (return $ error "quality programming") , echoCapture = brief return } @@ -78,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" $ @@ -93,8 +87,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 @@ -133,4 +125,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 ) 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..fd10f7d 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 @@ -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 @@ -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 ] } 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..988339d --- /dev/null +++ b/solga-typescript/solga-typescript.cabal @@ -0,0 +1,30 @@ +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, + 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 new file mode 100644 index 0000000..3f09b82 --- /dev/null +++ b/solga-typescript/src/Solga/TypeScript.hs @@ -0,0 +1,377 @@ +{-# 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 + ( HeaderInfo(..) + , 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 +import qualified Data.CaseInsensitive as CI + +{- +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 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 + } 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 + , infoReqHeaders = mempty + , 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 + , tssHeaders :: HMS.HashMap (CI.CI T.Text) HeaderInfo + , 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 + + +sendFunctions :: T.Text +sendFunctions = + " export interface SendFunctions { \ + \ baseUrl: string; \ + \ 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 :: + (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 + in T.unlines + [ T.pack $ Aeson.formatTSDeclarations' + Aeson.defaultFormattingOptions{ Aeson.exportTypes = True } + (do + Aeson.TSType typ <- S.toList (Aeson.getTransitiveClosure (S.union types (S.fromList additionalTypes))) + Aeson.getTypeScriptDeclarations typ) + , "" + , sendFunctions + , "" + , "export const " <> name <> ": " <> renderDictType dict <> " = " <> renderDictExpr [] 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) + , tssHeaders = infoReqHeaders 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{..} -> 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 <> ", "] + , if HMS.size (tsdSegments dict) > 0 then ["\"r\": " <> renderRoutesTypes (tsdSegments dict)] else [] + , ["}"] + ] + + renderRoutesTypes segs = T.concat $ concat + [ ["{"] + , do + (seg, ty) <- HMS.toList segs + return (T.pack (show seg) <> ": " <> renderDictType ty <> ", ") + , ["}"] + ] + + renderDictExpr 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 = "sf.baseUrl + [" <> T.intercalate ", " (map segToExpr (reverse segs)) <> "].join('/')" + 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 + v = "param" <> T.pack (show (length segs)) + 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 segs newSegs = T.concat $ concat + [ ["{"] + , do + (seg, ty) <- HMS.toList newSegs + return (T.pack (show seg) <> ": " <> renderDictExpr (TSSConst seg : segs) ty <> ", ") + , ["}"] + ] 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 43f212a..8ced0a3 100644 --- a/solga/src/Solga.hs +++ b/solga/src/Solga.hs @@ -1,374 +1,8 @@ -{-# 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 +import Solga.Core +import Solga.Router ---------------------------------------------------- - --- | 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 :: 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 - } diff --git a/stack-ghcjs.yaml b/stack-ghcjs.yaml new file mode 100644 index 0000000..aaf1641 --- /dev/null +++ b/stack-ghcjs.yaml @@ -0,0 +1,23 @@ +packages: +- 'solga-core' +- 'solga-client-ghcjs' +- location: + git: https://github.com/bitonic/jsval-json.git + commit: 5e24033a30afd832ed064be5c51621cf433baada + extra-dep: true +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 +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 diff --git a/stack.yaml b/stack.yaml index 69ac7ac..6f2e759 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,16 +1,27 @@ # 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-14.22 # Local packages, usually specified by relative directory name packages: - 'solga' - 'solga-swagger' +- 'solga-core' +- '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: -- safe-exceptions-0.1.1.0 +- 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 +- git: https://github.com/bitonic/aeson-typescript.git + commit: 13822f06e45b632446bf6e9b6e8368c060e159b5 # Override default flag values for local packages and extra-deps flags: {}