packages feed

servant-router (empty) → 0.7.1

raw patch · 5 files changed

+267/−0 lines, 5 filesdep +basedep +bytestringdep +http-api-datasetup-changed

Dependencies added: base, bytestring, http-api-data, http-types, mtl, network-uri, servant, servant-router, text

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-router.cabal view
@@ -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
+ src/Servant/Router.hs view
@@ -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)+  }
+ test/Spec.hs view
@@ -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