diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Will Fancher (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Will Fancher nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-router.cabal b/servant-router.cabal new file mode 100644 --- /dev/null +++ b/servant-router.cabal @@ -0,0 +1,43 @@ +name: servant-router +version: 0.7.1 +synopsis: Servant router for non-server applications. +description: Write Servant APIs to be routed without a server. +homepage: https://github.com/ElvishJerricco/servant-router +license: BSD3 +license-file: LICENSE +author: Will Fancher +maintainer: willfancher38@gmail.com +copyright: 2016 Will Fancher +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Servant.Router + build-depends: base >= 4.8 && < 5 + , servant == 0.7.* + , text == 1.2.* + , http-api-data == 0.2.* + , http-types == 0.9.* + , network-uri == 2.6.* + , bytestring == 0.10.* + , mtl == 2.2.* + default-language: Haskell2010 + ghc-options: -Wall + +test-suite servant-router-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , servant-router + , servant + , mtl + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/ElvishJerricco/servant-router diff --git a/src/Servant/Router.hs b/src/Servant/Router.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Router.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Router where + +import Control.Monad.Except +import qualified Data.ByteString.Char8 as BS +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import GHC.TypeLits +import Network.HTTP.Types +import Network.URI +import Servant.API +import Web.HttpApiData + +-- | Router terminator. +-- The 'HasRouter' instance for 'View' finalizes the router. +-- +-- Example: +-- +-- > type MyApi = "books" :> Capture "bookId" Int :> View +data View + +-- | 'Location' is used to split the path and query of a URI into components. +data Location = Location + { locPath :: [Text] + , locQuery :: Query + } deriving (Show, Eq, Ord) + +-- | When routing, the router may fail to match a location. +-- Either this is an unrecoverable failure, +-- such as failing to parse a query parameter, +-- or it is recoverable by trying another path. +data RoutingError = Fail | FailFatal deriving (Show, Eq, Ord) + +-- | A 'Router' contains the information necessary to execute a handler. +data Router m a where + RChoice :: Router m a -> Router m a -> Router m a + RCapture :: FromHttpApiData x => (x -> Router m a) -> Router m a + RQueryParam :: (FromHttpApiData x, KnownSymbol sym) + => Proxy sym -> (Maybe x -> Router m a) -> Router m a + RQueryParams :: (FromHttpApiData x, KnownSymbol sym) + => Proxy sym -> ([x] -> Router m a) -> Router m a + RQueryFlag :: KnownSymbol sym + => Proxy sym -> (Bool -> Router m a) -> Router m a + RPath :: KnownSymbol sym => Proxy sym -> Router m a -> Router m a + RPage :: m a -> Router m a + +-- | This is similar to the @HasServer@ class from @servant-server@. +-- It is the class responsible for making API combinators routable. +-- 'RuoteT' is used to build up the handler types. +-- 'Router' is returned, to be interpretted by 'routeLoc'. +class HasRouter layout where + type RouteT layout (m :: * -> *) a :: * + route :: Proxy layout -> Proxy m -> Proxy a -> RouteT layout m a -> Router m a + +instance (HasRouter x, HasRouter y) => HasRouter (x :<|> y) where + type RouteT (x :<|> y) m a = RouteT x m a :<|> RouteT y m a + route + _ + (m :: Proxy m) + (a :: Proxy a) + ((x :: RouteT x m a) :<|> (y :: RouteT y m a)) + = RChoice (route (Proxy :: Proxy x) m a x) (route (Proxy :: Proxy y) m a y) + +instance (HasRouter sublayout, FromHttpApiData x) + => HasRouter (Capture sym x :> sublayout) where + type RouteT (Capture sym x :> sublayout) m a = x -> RouteT sublayout m a + route _ m a f = RCapture (route (Proxy :: Proxy sublayout) m a . f) + +instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter (QueryParam sym x :> sublayout) where + type RouteT (QueryParam sym x :> sublayout) m a + = Maybe x -> RouteT sublayout m a + route _ m a f = RQueryParam + (Proxy :: Proxy sym) + (route (Proxy :: Proxy sublayout) m a . f) + +instance (HasRouter sublayout, FromHttpApiData x, KnownSymbol sym) + => HasRouter (QueryParams sym x :> sublayout) where + type RouteT (QueryParams sym x :> sublayout) m a = [x] -> RouteT sublayout m a + route _ m a f = RQueryParams + (Proxy :: Proxy sym) + (route (Proxy :: Proxy sublayout) m a . f) + +instance (HasRouter sublayout, KnownSymbol sym) + => HasRouter (QueryFlag sym :> sublayout) where + type RouteT (QueryFlag sym :> sublayout) m a = Bool -> RouteT sublayout m a + route _ m a f = RQueryFlag + (Proxy :: Proxy sym) + (route (Proxy :: Proxy sublayout) m a . f) + +instance (HasRouter sublayout, KnownSymbol path) + => HasRouter (path :> sublayout) where + type RouteT (path :> sublayout) m a = RouteT sublayout m a + route _ m a page = RPath + (Proxy :: Proxy path) + (route (Proxy :: Proxy sublayout) m a page) + +instance HasRouter View where + type RouteT View m a = m a + route _ _ _ = RPage + +-- | Use a handler to route a location, represented as a 'String'. +-- All handlers must, in the end, return @m a@. +-- 'routeLoc' will choose a route and return its result. +runRoute :: forall layout m a. (HasRouter layout, MonadError RoutingError m) + => String -> Proxy layout -> RouteT layout m a -> m a +runRoute loc' layout page = case uriToLocation <$> parseURI loc' of + Nothing -> throwError FailFatal + Just uri -> let + routing = route layout (Proxy :: Proxy m) (Proxy :: Proxy a) page + in routeLoc uri routing + +-- | Use a computed 'Router' to route a 'Location'. +routeLoc :: MonadError RoutingError m => Location -> Router m a -> m a +routeLoc loc r = case r of + RChoice a b -> catchError (routeLoc loc a) $ \e -> case e of + Fail -> routeLoc loc b + FailFatal -> throwError e + RCapture f -> case locPath loc of + [] -> throwError Fail + capture:paths -> maybe + (throwError FailFatal) + (routeLoc loc { locPath = paths }) + (f <$> parseUrlPieceMaybe capture) + RQueryParam sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of + Nothing -> routeLoc loc $ f Nothing + Just Nothing -> throwError FailFatal + Just (Just text) -> case parseQueryParamMaybe (decodeUtf8 text) of + Nothing -> throwError FailFatal + Just x -> routeLoc loc $ f (Just x) + RQueryParams sym f -> maybe (throwError FailFatal) (routeLoc loc . f) $ do + ps <- sequence $ snd <$> filter + (\(k, _) -> k == BS.pack (symbolVal sym)) (locQuery loc) + sequence $ (parseQueryParamMaybe . decodeUtf8) <$> ps + RQueryFlag sym f -> case lookup (BS.pack $ symbolVal sym) (locQuery loc) of + Nothing -> routeLoc loc $ f False + Just Nothing -> routeLoc loc $ f True + Just (Just _) -> throwError FailFatal + RPath sym a -> case locPath loc of + [] -> throwError Fail + p:paths -> if p == T.pack (symbolVal sym) + then routeLoc (loc { locPath = paths }) a + else throwError Fail + RPage a -> a + +-- | Convert a 'URI' to a 'Location'. +uriToLocation :: URI -> Location +uriToLocation uri = Location + { locPath = decodePathSegments $ BS.pack (uriPath uri) + , locQuery = parseQuery $ BS.pack (uriQuery uri) + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +import Control.Monad.Except +import Data.Proxy +import Data.Traversable +import Servant.API +import Servant.Router + +type TestApi = "root" :> Capture "cap" Int :> QueryParam "param" String :> View + :<|> "other" :> Capture "othercap" String :> View +testApi :: Proxy TestApi +testApi = Proxy + +testUris :: [String] +testUris = + [ "https://test.com/root/4?param=hi" + , "https://test.com/other/hi/" + , "https://test.com/fail" + , "https://test.com/root/fail" + ] + +main :: IO () +main = do + let root :: Int -> Maybe String -> ExceptT RoutingError IO () + root i s = liftIO $ print (i, s) + other :: String -> ExceptT RoutingError IO () + other s = liftIO $ print s + void $ for testUris $ \uri -> do + result <- runExceptT $ runRoute uri testApi (root :<|> other) + print result