eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Add safeLink'

Browse source 
Resolves #952
This commit is contained in:
Oleg Grenrus 2018-06-01 12:50:46 +03:00
parent a66aa8a981
commit 46663f29b0
2 changed files with 124 additions and 76 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

198
servant/src/Servant/Utils/Links.hs
View file

@ -19,8 +19,6 @@
-- >>> import Servant.Utils.Links -- >>> import Servant.Utils.Links
-- >>> import Data.Proxy -- >>> import Data.Proxy
-- >>> -- >>>
-- >>>
-- >>>
-- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Hello = "hello" :> Get '[JSON] Int
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
-- >>> type API = Hello :<|> Bye -- >>> type API = Hello :<|> Bye
@ -63,10 +61,24 @@
-- >>> :set -XConstraintKinds -- >>> :set -XConstraintKinds
-- >>> :{ -- >>> :{
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
-- >>> => Proxy endpoint -> MkLink endpoint -- >>> => Proxy endpoint -> MkLink endpoint Link
-- >>> apiLink = safeLink api -- >>> apiLink = safeLink api
-- >>> :} -- >>> :}
-- --
-- `safeLink'` allows to make specialise the output:
--
-- >>> safeLink' toUrlPiece api without
-- "bye"
--
-- >>> :{
-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
-- >>> => Proxy endpoint -> MkLink endpoint Text
-- >>> apiTextLink = safeLink' toUrlPiece api
-- >>> :}
--
-- >>> apiTextLink without
-- "bye"
--
-- Attempting to construct a link to an endpoint that does not exist in api -- Attempting to construct a link to an endpoint that does not exist in api
-- will result in a type error like this: -- will result in a type error like this:
-- --
@ -86,7 +98,9 @@ module Servant.Utils.Links (
-- --
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
safeLink safeLink
, safeLink'
, allLinks , allLinks
, allLinks'
, URI(..) , URI(..)
-- * Adding custom types -- * Adding custom types
, HasLink(..) , HasLink(..)
@ -109,8 +123,6 @@ import Data.Singletons.Bool
(SBool (..), SBoolI (..)) (SBool (..), SBoolI (..))
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import Data.Type.Bool
(If)
import Data.Type.Bool import Data.Type.Bool
(If) (If)
import GHC.TypeLits import GHC.TypeLits
@ -278,8 +290,18 @@ safeLink
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint) :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
=> Proxy api -- ^ The whole API that this endpoint is a part of => Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to -> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint -> MkLink endpoint Link
safeLink _ endpoint = toLink endpoint (Link mempty mempty) safeLink = safeLink' id
-- | More general 'safeLink'.
--
safeLink'
:: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
=> (Link -> a)
-> Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint a
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
-- | Create all links in an API. -- | Create all links in an API.
-- --
@ -295,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty)
-- --
-- Note: nested APIs don't work well with this approach -- Note: nested APIs don't work well with this approach
-- --
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) -- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: * -- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
-- = Char -> (Int -> Link) :<|> (Double -> Link) -- = Char -> (Int -> Link) :<|> (Double -> Link)
--
allLinks allLinks
:: forall api. HasLink api :: forall api. HasLink api
=> Proxy api => Proxy api
-> MkLink api -> MkLink api Link
allLinks api = toLink api (Link mempty mempty) allLinks = allLinks' id
-- | More general 'allLinks'. See `safeLink'`.
allLinks'
:: forall api a. HasLink api
=> (Link -> a)
-> Proxy api
-> MkLink api a
allLinks' toA api = toLink toA api (Link mempty mempty)
-- | Construct a toLink for an endpoint. -- | Construct a toLink for an endpoint.
class HasLink endpoint where class HasLink endpoint where
type MkLink endpoint type MkLink endpoint (a :: *)
toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to toLink
-> Link :: (Link -> a)
-> MkLink endpoint -> Proxy endpoint -- ^ The API endpoint you would like to point to
-> Link
-> MkLink endpoint a
-- Naked symbol instance -- Naked symbol instance
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
type MkLink (sym :> sub) = MkLink sub type MkLink (sym :> sub) a = MkLink sub a
toLink _ = toLink toA _ =
toLink (Proxy :: Proxy sub) . addSegment (escaped seg) toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
where where
seg = symbolVal (Proxy :: Proxy sym) seg = symbolVal (Proxy :: Proxy sym)
-- QueryParam instances -- QueryParam instances
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods)) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
=> HasLink (QueryParam' mods sym v :> sub) where => HasLink (QueryParam' mods sym v :> sub)
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub where
toLink _ l mv = type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l mv =
toLink toA (Proxy :: Proxy sub) $
case sbool :: SBool (FoldRequired mods) of case sbool :: SBool (FoldRequired mods) of
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
@ -334,105 +366,121 @@ instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mo
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
=> HasLink (QueryParams sym v :> sub) where => HasLink (QueryParams sym v :> sub)
type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub where
toLink _ l = type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) . toLink toA _ l =
toLink toA (Proxy :: Proxy sub) .
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, HasLink sub) instance (KnownSymbol sym, HasLink sub)
=> HasLink (QueryFlag sym :> sub) where => HasLink (QueryFlag sym :> sub)
type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub where
toLink _ l False = type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
toLink (Proxy :: Proxy sub) l toLink toA _ l False =
toLink _ l True = toLink toA (Proxy :: Proxy sub) l
toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l toLink toA _ l True =
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
-- :<|> instance - Generate all links at once -- :<|> instance - Generate all links at once
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
type MkLink (a :<|> b) = MkLink a :<|> MkLink b type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
-- Misc instances -- Misc instances
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (Capture' mods sym v :> sub) where => HasLink (Capture' mods sym v :> sub)
type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub where
toLink _ l v = type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l v =
toLink toA (Proxy :: Proxy sub) $
addSegment (escaped . Text.unpack $ toUrlPiece v) l addSegment (escaped . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where => HasLink (CaptureAll sym v :> sub)
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub where
toLink _ l vs = type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header' mods sym a :> sub) where instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
type MkLink (Header' mods sym a :> sub) = MkLink sub type MkLink (Header' mods sym a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Vault :> sub) where instance HasLink sub => HasLink (Vault :> sub) where
type MkLink (Vault :> sub) = MkLink sub type MkLink (Vault :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Description s :> sub) where instance HasLink sub => HasLink (Description s :> sub) where
type MkLink (Description s :> sub) = MkLink sub type MkLink (Description s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Summary s :> sub) where instance HasLink sub => HasLink (Summary s :> sub) where
type MkLink (Summary s :> sub) = MkLink sub type MkLink (Summary s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (HttpVersion :> sub) where instance HasLink sub => HasLink (HttpVersion :> sub) where
type MkLink (HttpVersion:> sub) = MkLink sub type MkLink (HttpVersion:> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (IsSecure :> sub) where instance HasLink sub => HasLink (IsSecure :> sub) where
type MkLink (IsSecure :> sub) = MkLink sub type MkLink (IsSecure :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (WithNamedContext name context sub) where instance HasLink sub => HasLink (WithNamedContext name context sub) where
type MkLink (WithNamedContext name context sub) = MkLink sub type MkLink (WithNamedContext name context sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where instance HasLink sub => HasLink (RemoteHost :> sub) where
type MkLink (RemoteHost :> sub) = MkLink sub type MkLink (RemoteHost :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
type MkLink (BasicAuth realm a :> sub) = MkLink sub type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink EmptyAPI where instance HasLink EmptyAPI where
type MkLink EmptyAPI = EmptyAPI type MkLink EmptyAPI a = EmptyAPI
toLink _ _ = EmptyAPI toLink _ _ _ = EmptyAPI
-- Verb (terminal) instances -- Verb (terminal) instances
instance HasLink (Verb m s ct a) where instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = Link type MkLink (Verb m s ct a) r = r
toLink _ = id toLink toA _ = toA
instance HasLink Raw where instance HasLink Raw where
type MkLink Raw = Link type MkLink Raw a = a
toLink _ = id toLink toA _ = toA
instance HasLink (Stream m fr ct a) where instance HasLink (Stream m fr ct a) where
type MkLink (Stream m fr ct a) = Link type MkLink (Stream m fr ct a) r = r
toLink _ = id toLink toA _ = toA
-- AuthProtext instances -- AuthProtext instances
instance HasLink sub => HasLink (AuthProtect tag :> sub) where instance HasLink sub => HasLink (AuthProtect tag :> sub) where
type MkLink (AuthProtect tag :> sub) = MkLink sub type MkLink (AuthProtect tag :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
-- | Helper for implemneting 'toLink' for combinators not affecting link
-- structure.
simpleToLink
:: forall sub a combinator.
(HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
=> Proxy sub
-> (Link -> a)
-> Proxy (combinator :> sub)
-> Link
-> MkLink (combinator :> sub) a
simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API

2
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -41,7 +41,7 @@ type LinkableApi =
apiLink :: (IsElem endpoint TestApi, HasLink endpoint) apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint => Proxy endpoint -> MkLink endpoint Link
apiLink = safeLink (Proxy :: Proxy TestApi) apiLink = safeLink (Proxy :: Proxy TestApi)
-- | Convert a link to a URI and ensure that this maps to the given string -- | Convert a link to a URI and ensure that this maps to the given string