named-servant-server 0.0.2 → 0.1.0
raw patch · 3 files changed
+58/−32 lines, 3 filesdep +textdep ~nameddep ~named-servantdep ~servant
Dependencies added: text
Dependency ranges changed: named, named-servant, servant, servant-server
Files
- named-servant-server.cabal +6/−5
- src/Servant/Server/Named.hs +32/−10
- src/Servant/Server/Record.hs +20/−17
named-servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: named-servant-server-version: 0.0.2+version: 0.1.0 maintainer: kristof@resonata.be copyright: Kristof Bastiaensen 2020 synopsis: server support for named-servant@@ -22,7 +22,8 @@ src build-depends: base >= 4.7 && < 5,- servant,- servant-server,- named-servant,- named+ servant >= 0.17 && < 0.18,+ servant-server >= 0.17 && < 0.18,+ named-servant == 0.0.3,+ named >= 0.3 && < 0.4,+ text
src/Servant/Server/Named.hs view
@@ -16,34 +16,56 @@ import Servant.Server import Servant.Named import Data.Proxy+import Servant.API.Modifiers import GHC.TypeLits+import qualified Data.Text as Text import Named -instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)- => HasServer (NamedQueryParams sym a :> api) context where+unarg :: NamedF f a name -> f a+unarg (ArgF a) = a +instance ( KnownSymbol sym+ , FromHttpApiData a+ , HasServer api context)+ => HasServer (NamedQueryParams sym a :> api) context where+ type ServerT (NamedQueryParams sym a :> api) m =- sym :! [a] -> ServerT api m+ sym :? [a] -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = route (Proxy :: Proxy (QueryParams sym a :> api)) context $- fmap (\f x -> f (Arg x)) subserver+ fmap (\f x -> f (ArgF $ Just x)) subserver -instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)+instance ( KnownSymbol sym+ , FromHttpApiData a+ , HasServer api context+ , SBoolI (FoldRequired mods)+ , SBoolI (FoldLenient mods)+ ) => HasServer (NamedQueryParam' mods sym a :> api) context where- type ServerT (NamedQueryParam' mods sym a :> api) m =- sym :! [a] -> ServerT api m+ If (FoldRequired mods)+ (If (FoldLenient mods) (sym :! Either Text.Text a) (sym :! a))+ (If (FoldLenient mods) (sym :? Either Text.Text a) (sym :? a))+ -> ServerT api m hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver =- route (Proxy :: Proxy (QueryParams sym a :> api)) context $- fmap (\f x -> f (Arg x)) subserver+ route (Proxy :: Proxy (QueryParam' mods sym a :> api)) context $+ fmap (\f x ->+ case sbool :: SBool (FoldRequired mods) of+ STrue -> case sbool :: SBool (FoldLenient mods) of+ STrue -> f (Arg x)+ SFalse -> f (Arg x)+ SFalse -> case sbool :: SBool (FoldLenient mods) of+ STrue -> f (ArgF x)+ SFalse -> f (ArgF x))+ subserver instance (KnownSymbol sym, HasServer api context) => HasServer (NamedQueryFlag sym :> api) context where@@ -56,4 +78,4 @@ route Proxy context subserver = route (Proxy :: Proxy (QueryFlag sym :> api)) context $- fmap (\f x -> f (Arg x)) subserver+ fmap (\f -> f . Arg) subserver
src/Servant/Server/Record.hs view
@@ -22,16 +22,18 @@ import Servant.Server.Internal import Servant.Record -class GHasServer a context api where- gRoute :: Proxy api -> Context context -> Delayed env (a -> Server api)+class GHasServer (a :: * -> *) context api where+ gRoute :: Proxy api -> Context context -> Delayed env (a () -> Server api) -> Router env- gHoistServerWithContext :: Proxy api -> Proxy context -> (forall x. m x -> n x)- -> (a -> ServerT api m) -> (a -> ServerT api n)+ gHoistServerWithContext :: Proxy api -> Proxy context+ -> (forall x. m x -> n x)+ -> (a () -> ServerT api m)+ -> (a () -> ServerT api n) data GParam a instance ( Generic a- , GHasServer (Rep a ()) context api+ , GHasServer (Rep a) context api ) => HasServer (RecordParam a :> api) context where type ServerT (RecordParam a :> api) m = a -> ServerT api m@@ -43,15 +45,16 @@ (from x :: Rep a ()) {-# INLINE hoistServerWithContext #-} -instance GHasServer a context api => HasServer (GParam a :> api) context where- type ServerT (GParam a :> api) m = a -> ServerT api m+instance GHasServer a context api =>+ HasServer (GParam (a ()) :> api) context where+ type ServerT (GParam (a ()) :> api) m = a () -> ServerT api m route _ = gRoute (Proxy :: Proxy api) {-# INLINE route #-} hoistServerWithContext _ = gHoistServerWithContext (Proxy :: Proxy api) {-# INLINE hoistServerWithContext #-} -instance GHasServer (c m2 ()) context api =>- GHasServer (D1 m3 (c m2) ()) context api where+instance GHasServer c context api =>+ GHasServer (D1 m3 c) context api where gRoute _ context env = gRoute (Proxy :: Proxy api) context $ (\f x -> f (M1 x)) <$> env {-# INLINE gRoute #-} @@ -59,8 +62,8 @@ gHoistServerWithContext (Proxy :: Proxy api) pc nt (s . M1) x {-# INLINE gHoistServerWithContext #-} -instance GHasServer (a ()) context (GParam (b ()) :> api) =>- GHasServer ((a :*: b)()) context api where+instance GHasServer a context (GParam (b ()) :> api) =>+ GHasServer ((a :*: b)) context api where gRoute _ context env = gRoute (Proxy :: Proxy (GParam (b ()) :> api)) context $ (\f x y -> f (x :*: y)) <$> env {-# INLINE gRoute #-} @@ -69,8 +72,8 @@ pc nt (\x' y' -> s (x' :*: y')) x y {-# INLINE gHoistServerWithContext #-} -instance GHasServer (a ()) context api =>- GHasServer (C1 n a ()) context api where+instance GHasServer a context api =>+ GHasServer (C1 n a) context api where gRoute _ context env = gRoute (Proxy :: Proxy api) context $ (\f x -> f (M1 x)) <$> env {-# INLINE gRoute #-} @@ -82,7 +85,7 @@ ( HasServer api context , KnownSymbol sym ) =>- GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool) ())+ GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 Bool)) context api where gRoute _ context env = route (Proxy :: Proxy (QueryFlag sym :> api))@@ -98,7 +101,7 @@ , FromHttpApiData a , KnownSymbol sym ) =>- GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a]) ())+ GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 [a])) context api where gRoute _ context env = route (Proxy :: Proxy (QueryParams sym a :> api))@@ -114,7 +117,7 @@ , FromHttpApiData a , KnownSymbol sym ) =>- GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a)) ())+ GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 (Maybe a))) context api where gRoute _ context env =@@ -131,7 +134,7 @@ , FromHttpApiData a , KnownSymbol sym ) =>- GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a) ())+ GHasServer (S1 ('MetaSel ('Just sym) d1 d2 d3) (Rec0 a)) context api where gRoute _ context env =