diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for servant-namedargs + +## 0.1.0.0 -- 2019-01-23 + +* First version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Cullin Poresky + +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 Cullin Poresky 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +This library provides combinators to add named arguments to servant endpoints. These combinators are all isomorphic to existing servant combinators, and so a type family `Transform` is also provided for converting namedargs combinators to and from default servant combinators. Following the pattern of servant itself, this library *only* adds the combinators and instances for link generation: for the instances to actually use them with servant-client and servant-server, look at servant-client-namedargs and servant-server-namedargs. diff --git a/servant-namedargs.cabal b/servant-namedargs.cabal new file mode 100644 --- /dev/null +++ b/servant-namedargs.cabal @@ -0,0 +1,35 @@ +name: servant-namedargs +version: 0.1.0.0 +synopsis: Combinators for servant providing named parameters +-- description: +license: BSD3 +license-file: LICENSE +author: Cullin Poresky +maintainer: cporeskydev@gmail.com +-- copyright: +category: Web +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +cabal-version: >=1.10 + +library + exposed-modules: Servant.API.NamedArgs + -- other-modules: + -- other-extensions: + build-depends: base >= 4.11 && < 4.12 + , servant >= 0.14.1 && < 0.16 + , named >= 0.2 && < 0.3 + , text >= 1.2 && < 1.3 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: test/LinkEquivalency.hs + build-depends: base + , servant + , named + , servant-namedargs + , hspec >= 2.7 && < 2.8 + , QuickCheck >= 2.12.6.1 && < 2.13 + default-language: Haskell2010 diff --git a/src/Servant/API/NamedArgs.hs b/src/Servant/API/NamedArgs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/NamedArgs.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | This module provides combinators to represent named arguments +-- to endpoints. Note that only link generation instances are provided +-- here: +-- you will most likely want one or both of "Servant.Client.NamedArgs" and +-- "Servant.Server.NamedArgs" +module Servant.API.NamedArgs where + +import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) +import Data.Functor.Identity (Identity) +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import Named ((:!), (:?), arg, argF, Name(..), (!), NamedF(..), pattern Arg + , argDef) +import Servant.API ((:>), (:<|>)(..), Capture', If, QueryFlag, QueryParam' + , QueryParams, SBoolI(..), SBool(..), HasLink(..) + , ToHttpApiData(..), CaptureAll(..), AddHeader(..), Headers(..) + , Header'(..)) +import Servant.API.Modifiers (FoldRequired, Optional, Required, Strict, FoldLenient) +import Servant.API.Generic (GenericMode(..), AsApi, ToServant) +import Servant.Links (Param(..), Link(..), linkQueryParams) +import Type.Reflection (Typeable) +import GHC.Generics + +-- | Isomorphism of 'Servant.API.Capture'' +data NamedCapture' (mods :: [*]) (sym :: Symbol) (a :: *) + deriving Typeable + +-- | Isomorphism of 'Servant.API.Capture' +type NamedCapture = NamedCapture' '[] + +-- | Becomes a named required argument +instance (ToHttpApiData v, HasLink sub, KnownSymbol name) + => HasLink (NamedCapture' mods name v :> sub) where + type MkLink (NamedCapture' mods name v :> sub) a = (name :! v) -> MkLink sub a + + toLink toA _ l (arg (Name @name) -> capture) + = (toLink toA (Proxy @(Capture' mods name v :> sub)) l) capture + +-- | Isomorphism of 'Servant.API.CaptureAll' +data NamedCaptureAll (sym :: Symbol) (a :: *) + deriving Typeable + +-- | Becomes a named optional argument, taking a list and defaulting to an +-- empty list +instance (ToHttpApiData v, HasLink sub, KnownSymbol name) + => HasLink (NamedCaptureAll name v :> sub) where + type MkLink (NamedCaptureAll name v :> sub) a = (name :? [v]) -> MkLink sub a + + toLink toA _ l (argDef (Name @name) [] -> capture) + = (toLink toA (Proxy @(CaptureAll name v :> sub)) l) capture + +-- | Isomorphism of 'Servant.API.QueryParam'' +data NamedParam (mods :: [*]) (sym :: Symbol) (a :: *) + deriving Typeable + +-- | Shorthand for a required param, isomorphic to +-- 'QueryParam'' \'['Required', 'Strict'] from Servant +type RequiredNamedParam = NamedParam '[Required, Strict] + +-- | Shorthand for an optional param, isomorphic to +-- 'QueryParam'' \'['Optional', 'Strict'] from Servant +type OptionalNamedParam = NamedParam '[Optional, Strict] + +-- | Becomes either a required or optional named argument depending on +-- whether it is set as 'Required' or 'Optional' (defaults to optional if +-- neither is specified) +instance (KnownSymbol name, HasLink sub, ToHttpApiData v, SBoolI (FoldRequired mods)) + => HasLink (NamedParam mods name v :> sub) where + + type MkLink (NamedParam mods name v :> sub) a + = RequiredNamedArgument mods name v -> MkLink sub a + + toLink toA _ l = + foldRequiredAdapter @mods @name @v (toLink toA (Proxy @(QueryParam' mods name v :> sub)) l) + +-- | Isomorphism of 'Servant.API.QueryParams' +data NamedParams (sym :: Symbol) (a :: *) + deriving Typeable + +-- | Becomes a required named argument, taking a list +instance (KnownSymbol name, HasLink sub, ToHttpApiData v) + => HasLink (NamedParams name v :> sub) where + + type MkLink (NamedParams name v :> sub) a = (name :! [v]) -> MkLink sub a + + toLink toA _ l (arg (Name @name) -> vs) + = (toLink toA (Proxy @(QueryParams name v :> sub)) l) vs + +-- | Isomorphism of 'Servant.API.QueryFlag' +data NamedFlag (sym :: Symbol) + deriving Typeable + +-- | Becomes an optional named argument, defaulting to False +instance (KnownSymbol name, HasLink sub) + => HasLink (NamedFlag name :> sub) where + + type MkLink (NamedFlag name :> sub) a = + (name :? Bool) -> MkLink sub a + + toLink toA _ l (argDef (Name @name) False -> v) = + (toLink toA (Proxy @(QueryFlag name :> sub)) l) v + +-- | Isomorphism of 'Header'' +data NamedHeader' (mods :: [*]) (sym :: Symbol) (a :: *) + deriving Typeable + +-- | Shorthand for a required Header; Isomorphism of 'Header' +type NamedHeader = NamedHeader' '[Optional, Strict] + +-- | Has no effect on the resulting link +instance (HasLink sub) => HasLink (NamedHeader' mods name a :> sub) where + type MkLink (NamedHeader' mods name a :> sub) r = MkLink sub r + toLink toA _ = toLink toA (Proxy :: Proxy sub) + +-- | Returns the type name :! a if given a list including 'Required' +-- and name :? a otherwise +type RequiredNamedArgument mods name a = If (FoldRequired mods) (name :! a) (name :? a) + +-- | Returns either a `NamedF Identity` or `NamedF Maybe` depending on if +-- required/optional, wrapping an `Either Text a` or an `a` depending on if +-- lenient/strict +type RequestNamedArgument mods name a + = If (FoldRequired mods) + (name :! If (FoldLenient mods) (Either Text a) a) + (name :? (If (FoldLenient mods) (Either Text a) a)) + +-- | Apply either the function 'f' which operates on 'a' +-- or 'g' which operates on 'Maybe' a depending on if the +-- mods include `Required` +foldRequiredNamedArgument + :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name) + => (a -> r) -- ^ Function to apply if the mods includes 'Required' + -> (Maybe a -> r) -- ^ Function to apply if the mods do not include 'Required' + -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g' + -> r +foldRequiredNamedArgument f g mx = + case (sbool :: SBool (FoldRequired mods), mx) of + (STrue, (arg (Name :: Name name) -> x)) -> f x + (SFalse, (argF (Name :: Name name) -> x)) -> g x + +-- | Adapt a function supposed to take a or 'Maybe' a to take name +-- ':!' +-- a or name ':?' a instead +foldRequiredAdapter + :: forall mods name a r. (SBoolI (FoldRequired mods), KnownSymbol name) + => (If (FoldRequired mods) a (Maybe a) -> r) -- ^ Version of functions without named arguments + -> RequiredNamedArgument mods name a -- ^ Argument to either 'f' or 'g' + -> r +foldRequiredAdapter f mv = + case (sbool :: SBool (FoldRequired mods), mv) of + (STrue, (arg (Name :: Name name) -> x)) -> f x + (SFalse, (argF (Name :: Name name) -> x)) -> f x + +-- | Unfold a value into a 'RequestNamedArgument'. +unfoldRequestNamedArgument + :: forall mods name m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) + => m (RequestNamedArgument mods name a) -- ^ error when argument is required + -> (Text -> m (RequestNamedArgument mods name a)) -- ^ error when argument is strictly parsed + -> Maybe (Either Text a) -- ^ value + -> m (RequestNamedArgument mods name a) +unfoldRequestNamedArgument errReq errSt mex = + case (sbool :: SBool (FoldRequired mods), mex, sbool :: SBool (FoldLenient mods)) of + (STrue, Nothing, _) -> errReq + (SFalse, Nothing, _) -> pure $ ArgF Nothing + (STrue, Just ex, STrue) -> pure $ Arg ex + (STrue, Just ex, SFalse) -> either errSt pure (Arg <$> ex) + (SFalse, Just ex, STrue) -> pure $ ArgF $ Just ex + (SFalse, Just ex, SFalse) -> either errSt (pure . ArgF . Just) ex + +-- | 'Transform' is used to transform back and forth between APIs +-- using the "Named" combinators and APIs not using the "Named" combinators +-- by applying the listed transformations to the api +type family Transform (t :: [Transformation]) (api :: k) :: k where + -- recurse on binary operators + Transform t (a :<|> b) = Transform t a :<|> Transform t b + Transform t (a :> b) = Transform t a :> Transform t b + -- naming rules + Transform (NameParams:_) (QueryParam' mods sym a) + = NamedParam mods sym a + Transform (NameMultiParams:_) (QueryParams sym a) + = NamedParams sym a + Transform (NameFlags:_) (QueryFlag sym) + = NamedFlag sym + Transform (NameCaptures:_) (Capture' mods sym a) + = NamedCapture' mods sym a + Transform (NameCaptureAlls:_) (CaptureAll sym a) + = NamedCaptureAll sym a + Transform (NameHeaders:_) (Header' mods sym a) + = NamedHeader' mods sym a + -- unnaming rules + Transform (UnnameParams:_) (NamedParam mods sym a) + = QueryParam' mods sym a + Transform (UnnameMultiParams:_) (NamedParams sym a) + = QueryParams sym a + Transform (UnnameFlags:_) (NamedFlag sym) + = QueryFlag sym + Transform (UnnameCaptures:_) (NamedCapture' mods sym a) + = Capture' mods sym a + Transform (UnnameCaptureAlls:_) (NamedCaptureAll sym a) + = CaptureAll sym a + Transform (UnnameHeaders:_) (NamedHeader' mods sym a) + = Header' mods sym a + -- if the current transformation doesn't match, try the next one + Transform (_:ts) a = Transform ts a + -- if none of them match, leave it unchanged + Transform '[] a = a + +-- | 'AsTransformed' can be used to transform back and forth while using +-- Servant's generic programming (see "Servant.API.Generic") +data AsTransformed (t :: [Transformation]) (m :: *) + +instance (GenericMode mode) => GenericMode (AsTransformed t mode) where + type AsTransformed t mode :- api = mode :- Transform t api + +-- | Possible transformations 'Transform' can apply +data Transformation = NameParams -- ^ Replace 'QueryParam''s with 'NamedParam''s + | NameMultiParams -- ^ Replace 'QueryParams's with 'NamedParams's + | NameCaptures -- ^ Replace 'Capture''s with 'NamedCapture''s + | NameCaptureAlls -- ^ Replace 'CaptureAll's with 'NamedCaptureAll's + | NameFlags -- ^ Replace 'QueryFlag's with 'NamedFlag's + | NameHeaders -- ^ Replace 'Header''s with 'NamedHeader''s + | UnnameParams -- ^ Replace 'NamedParam's with 'QueryParam''s + | UnnameMultiParams -- ^ Replace 'NamedParams's with 'QueryParams's + | UnnameCaptures -- ^ Replace 'NamedCapture''s with 'Capture's + | UnnameCaptureAlls -- ^ Replace 'NamedCaptureAll's with 'CaptureAll's + | UnnameFlags -- ^ Replace 'NamedFlag's with 'QueryFlag's + | UnnameHeaders -- ^ Replace 'NamedHeader''s with 'Header''s + deriving (Show, Read, Eq, Enum) diff --git a/test/LinkEquivalency.hs b/test/LinkEquivalency.hs new file mode 100644 --- /dev/null +++ b/test/LinkEquivalency.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE FlexibleContexts #-} + +import Test.Hspec +import Test.QuickCheck +import Servant.API +import Servant.API.NamedArgs +import Data.Proxy +import Data.Functor.Identity +import Named +import Named.Internal +import Data.Function ((&)) + +type All = [ NameCaptures + , NameCaptureAlls + , NameFlags + , NameParams + , NameMultiParams + ] + +type CaptureEndpoint = "capture" :> Capture "x" Int :> Get '[JSON] Int +type CaptureAllEndpoint = "captureAll" :> CaptureAll "xs" Int :> Get '[JSON] [Int] +type FlagEndpoint = "flag" :> QueryFlag "f" :> Get '[JSON] Bool +type ReqParamEndpoint = "requiredParam" :> QueryParam' [Required, Strict] "r" Int :> Get '[JSON] Int +type OpParamEndpoint = "optionalParam" :> QueryParam' [Optional, Strict] "o" Int :> Get '[JSON] Int +type ParamsEndpoint = "params" :> QueryParams "ps" Int :> Get '[JSON] [Int] +type ReqHeaderEndpoint = "requiredHeader" :> Header' [Required, Strict] "rh" Int :> Get '[JSON] Int +type OpHeaderEndpoint = "optionalHeader" :> Header' [Optional, Strict] "oh" Int :> Get '[JSON] Int + +type TestApi = CaptureEndpoint + :<|> CaptureAllEndpoint + :<|> FlagEndpoint + :<|> ReqParamEndpoint + :<|> OpParamEndpoint + :<|> ParamsEndpoint + :<|> ReqHeaderEndpoint + :<|> OpHeaderEndpoint + +cmpLinks + :: forall endpoint a n. ( IsElem endpoint TestApi + , IsElem (Transform All endpoint) (Transform All TestApi) + , HasLink endpoint + , HasLink (Transform All endpoint) + ) + => a + -> (a -> (MkLink endpoint Link) -> Link) + -> (a -> (MkLink (Transform All endpoint) Link) -> Link) + -> Bool +cmpLinks val uf nf = toUrlPiece (uf val unnamed) == toUrlPiece (nf val named) + where + unnamed = safeLink (Proxy @TestApi) (Proxy @endpoint) + named = safeLink (Proxy @(Transform All TestApi)) (Proxy @(Transform All endpoint)) + +withF :: forall l p f a fn fn'. (p ~ NamedF f a l, WithParam p fn fn') + => f a -> fn -> fn' +withF p fn = with (Param $ ArgF @_ @_ @l p) fn + +def :: a -> Maybe a -> a +def a Nothing = a +def _ (Just b) = b + +main :: IO () +main = hspec $ do + describe "Named and unnamed equivalency" $ do + it "Capture and NamedCapture are equivalent" $ do + property $ \x -> cmpLinks @CaptureEndpoint x ((&) . runIdentity) ((withF @"x")) + it "CaptureAll and NamedCaptureAll are equivalent" $ do + property $ \x -> cmpLinks @CaptureAllEndpoint x ((&) . def []) (withF @"xs") + it "QueryFlag and NamedFlag are equivalent" $ do + property $ \x -> cmpLinks @FlagEndpoint x ((&) . def False) (withF @"f") + it "Required QueryParam and NamedParam are equivalent" $ do + property $ \x -> cmpLinks @ReqParamEndpoint x ((&) . runIdentity) (withF @"r") + it "Optional QueryParam and NamedParam are equivalent" $ do + property $ \x -> cmpLinks @OpParamEndpoint x ((&)) (withF @"o") + it "Required QueryHeader and NamedHeader are equivalent" $ do + cmpLinks @ReqHeaderEndpoint Nothing (flip const) (flip const) + it "Optional QueryHeader and NamedHeader are equivalent" $ do + cmpLinks @OpHeaderEndpoint Nothing (flip const) (flip const)