servant-named (empty) → 0.1.0.0

raw patch · 7 files changed

+273/−0 lines, 7 filesdep +basedep +hspecdep +hspec-waisetup-changed

Dependencies added: base, hspec, hspec-wai, http-types, servant, servant-named, servant-server

Files

LICENSE +29/−0
README.md +19/−0
Setup.hs +2/−0
servant-named.cabal +43/−0
src/Servant/API/Named.hs +75/−0
src/Servant/API/Named/Internal.hs +104/−0
test/Spec.hs +1/−0

+ LICENSE view

@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2017, Ben Weitzman+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 the copyright holder nor the names of its+  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 HOLDER 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.

+ README.md view

@@ -0,0 +1,19 @@+# servant-named++This package aims to address an issue with the amazing [servant](https://hackage.haskell.org/package/servant) library, wherein it can be hard to manage two complex lists of API endpoints (one of types, and one of handlers), making sure to keep them in the same order.++To address this, we introduce the concept of named endpoints. When using named endpoints, it's no longer necessary to keep endpoint types and handlers in the same order. When serving the servant application, the types and handlers are automatically matched up according to their names. Here's a little example:++```haskell+handler :: Server API+handler = fromNamed $ Named @"getUser"  := return+                ::<|> Named @"getUsers" := return [1,2,3]+                ::<|> Nil++type API = FromNamed ( Named "getUsers" := "user" :> Get '[JSON] [Int]+                 ::<|> Named "getUser"  := "user" :> Capture "id" Int :> Get '[JSON] Int+                 ::<|> Nil+                 )+```                 ++The endpoints are defined in opposite orders, but this still typechecks and works as expected!

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ servant-named.cabal view

@@ -0,0 +1,43 @@+name:                servant-named+version:             0.1.0.0+synopsis:            Add named endpoints to servant+description:         Please see README.md+homepage:            https://github.com/bemweitzman/servant-named#readme+license:             BSD3+license-file:        LICENSE+author:              Ben WEitzman+maintainer:          benweitzman@gmail.com+copyright:           2017 Ben Weitzman+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Servant.API.Named+  other-modules:       Servant.API.Named.Internal+  build-depends:       base >= 4.9 && < 5+                     , servant >= 0.7.1 && < 1+  default-language:    Haskell2010++test-suite servant-named-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , servant-named++                     , servant++                     , hspec+                     , hspec-wai+                     , http-types+                     , servant-server++  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/benweitzman/servant-named

+ src/Servant/API/Named.hs view

@@ -0,0 +1,75 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}++module Servant.API.Named (+  Named(..),+  NameList(..),+  (::=)(..),+  Nil,+  (:=),+  (::<|>),+  FromNamed,+  fromNamed+  ) where+++import Servant.API.Named.Internal++import Data.Kind (Type)++import GHC.TypeLits (Symbol, CmpSymbol)+++type Nil = '[]++infix 8 :=+++-- | Notational convenience to make value and type level defns match up+type family n := a where+   (Named n) := a = '(n, a)++infixr 7 ::<|>++-- | Notational convenience to make value and type level defns match up+type family x ::<|> y where+   x ::<|> y = x ': y+++type family Insert (x :: (Symbol, Type)) (xs :: [(Symbol, Type)]) :: [(Symbol, Type)] where+  Insert x '[] = '[x]+  Insert '(xName, x) ( '(yName, y) ': ys) = If ((CmpSymbol xName yName) == 'LT)+                                               ( '(xName, x) ': '(yName, y) ': ys )+                                               ( '(yName, y) ': Insert '(xName, x) ys )+++type family Sort (xs :: [(Symbol, Type)]) :: [(Symbol, Type)] where+  Sort '[] = '[]+  Sort (x ': xs) = Insert x (Sort xs)+++sInsert :: Named name -> a -> NameList xs -> NameList (Insert '(name, a) xs)+sInsert pName val Nil = pName := val ::<|> Nil+sInsert xName xVal xs@(yName := yVal ::<|> rest) = sIf (sCompare xName yName) (xName := xVal ::<|> xs) (yName := yVal ::<|> (sInsert xName xVal rest))+++sSort :: NameList xs -> NameList (Sort xs)+sSort Nil = Nil+sSort (name := val ::<|> rest) = sInsert name val (sSort rest)+++type family FromNamed xs where+  FromNamed xs = FromNamedSorted (Sort xs)++fromNamed :: NameList xs -> FromNamed xs+fromNamed xs = fromNamedSorted (sSort xs)

+ src/Servant/API/Named/Internal.hs view

@@ -0,0 +1,104 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Servant.API.Named.Internal where++import Data.Kind (Type)++import Data.List (intersperse)++import Data.Proxy (Proxy(..))++import GHC.TypeLits (Symbol, CmpSymbol, KnownSymbol, symbolVal+                    ,TypeError, ErrorMessage(Text))++import Unsafe.Coerce (unsafeCoerce)++import Servant.API ((:<|>)(..))++++-- | Symbol singleton+data Named (s :: Symbol) = KnownSymbol s => Named++instance Show (Named s) where+  show Named = "Named @" ++ show (symbolVal (Proxy @s))++-- | Boolean singleton+data SBool :: Bool -> Type where+  STrue :: SBool 'True+  SFalse :: SBool 'False++deriving instance Show (SBool k)++type family (x :: k) == (y :: k) :: Bool where+  a == a = 'True+  a == b = 'False++type family If (cond :: Bool) (yes :: k) (no :: k) :: k where+  If 'True yes no = yes+  If 'False yes no = no+++sIf :: SBool cond -> f a -> f b -> f (If cond a b)+sIf STrue a _ = a+sIf SFalse _ b = b+++-- | Singleton version of `compare`. Requires unsafeCoerce+sCompare :: forall (a :: Symbol) (b :: Symbol) . Named a -> Named b -> SBool (CmpSymbol a b == 'LT)+sCompare Named Named = case symbolVal (Proxy @a) `compare` symbolVal (Proxy @b) of+  LT -> unsafeCoerce STrue+  EQ -> unsafeCoerce SFalse+  GT -> unsafeCoerce SFalse++++data name ::= a = Named name := a+++infixr 7 ::<|>++-- | Hetereogenous list with name tag+data NameList :: [(Symbol, Type)] -> Type where+  Nil :: NameList '[]+  (::<|>) :: (name ::= a) -> NameList xs -> NameList ( '(name, a) ': xs)+++class ShowList x where+  toStringList :: x -> [String]++instance ShowList (NameList '[]) where+  toStringList Nil = []++instance (ShowList (NameList as), Show a) => ShowList (NameList ( '(name, a) ': as)) where+  toStringList (name := a ::<|> rest) = ("(" ++ show name ++ ", " ++ show a ++ ")") : toStringList rest+++instance ShowList (NameList a) => Show (NameList a) where+  show = (++ "]") . ('[' :) . concat . intersperse  "," . toStringList++++type family FromNamedSorted xs where+  FromNamedSorted '[] = TypeError ( 'Text "You can't have an empty API")+  FromNamedSorted '[ ' (_, a) ] = a+  FromNamedSorted ( '(_, a) ': rest ) = a :<|> FromNamedSorted rest++-- | Convert a sorted list of handlers in to a tuple built with :<|>.+-- requires unsafeCoerce+fromNamedSorted :: NameList xs -> FromNamedSorted xs+fromNamedSorted Nil = error "This is impossible and will generate a type error"+fromNamedSorted (_ := a ::<|> Nil) = a+fromNamedSorted (_ := a ::<|> rest) = unsafeCoerce $ a :<|> fromNamedSorted rest

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}