diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5054e69f..33ac2732 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -1,36 +1,50 @@ -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign - ( HasForeign(..) - , HasForeignType(..) + ( ArgType(..) + , HeaderArg(..) + , QueryArg(..) + , Req(..) , Segment(..) , SegmentType(..) + , Url(..) + -- aliases + , Path + , ForeignType + , Arg , FunctionName - , QueryArg(..) - , HeaderArg(..) - , ArgType(..) - , Req + -- lenses + , reqUrl + , reqMethod + , reqHeaders + , reqBody + , reqReturnType + , reqFuncName + , path + , queryStr + , argName + , argType + -- prisms + , _HeaderArg + , _ReplaceHeaderArg + , _Static + , _Cap + , _Normal + , _Flag + , _List + -- rest of it + , HasForeign(..) + , HasForeignType(..) + , HasNoForeignType + , GenerateList(..) + , NoTypes , captureArg - , defReq + , isCapture , concatCase , snakeCase , camelCase - -- lenses - , argType - , argName - , isCapture - , funcName - , path - , reqUrl - , reqBody - , reqHeaders - , reqMethod - , reqReturnType - , segment - , queryStr + , defReq , listFromAPI - , GenerateList(..) - , NoTypes -- re-exports , module Servant.API ) where diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index bb2e4b1e..369d5b76 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -19,17 +19,19 @@ -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens (makeLenses, makePrisms, (%~), (&), (.~), (<>~)) +import qualified Data.Char as C import Data.Proxy import Data.Text -import Data.Text.Encoding (decodeUtf8) -import GHC.Exts (Constraint) +import Data.Text.Encoding (decodeUtf8) +import GHC.Exts (Constraint) import GHC.TypeLits -import qualified Network.HTTP.Types as HTTP -import Prelude hiding (concat) +import qualified Network.HTTP.Types as HTTP +import Prelude hiding (concat) import Servant.API +type FunctionName = [Text] + -- | Function name builder that simply concat each part together concatCase :: FunctionName -> Text concatCase = concat @@ -49,36 +51,50 @@ camelCase = camelCase' . Prelude.map (replace "-" "") capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name type ForeignType = Text + type Arg = (Text, ForeignType) -newtype Segment = Segment { _segment :: SegmentType } +data SegmentType + = Static Text + -- ^ a static path segment. like "/foo" + | Cap Arg + -- ^ a capture. like "/:userid" deriving (Eq, Show) -data SegmentType = Static Text -- ^ a static path segment. like "/foo" - | Cap Arg -- ^ a capture. like "/:userid" +makePrisms ''SegmentType + +newtype Segment = Segment { unSegment :: SegmentType } deriving (Eq, Show) +makePrisms ''Segment + type Path = [Segment] -data ArgType = - Normal +data ArgType + = Normal | Flag | List deriving (Eq, Show) +makePrisms ''ArgType + data QueryArg = QueryArg { _argName :: Arg , _argType :: ArgType } deriving (Eq, Show) -data HeaderArg = HeaderArg - { headerArg :: Arg - } - | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text - } deriving (Eq, Show) +makeLenses ''QueryArg +data HeaderArg = HeaderArg + { headerArg :: Arg } + | ReplaceHeaderArg + { headerArg :: Arg + , headerPattern :: Text + } deriving (Eq, Show) + +makeLenses ''HeaderArg + +makePrisms ''HeaderArg data Url = Url { _path :: Path @@ -88,7 +104,7 @@ data Url = Url defUrl :: Url defUrl = Url [] [] -type FunctionName = [Text] +makeLenses ''Url data Req = Req { _reqUrl :: Url @@ -96,12 +112,9 @@ data Req = Req , _reqHeaders :: [HeaderArg] , _reqBody :: Maybe ForeignType , _reqReturnType :: ForeignType - , _funcName :: FunctionName + , _reqFuncName :: FunctionName } deriving (Eq, Show) -makeLenses ''QueryArg -makeLenses ''Segment -makeLenses ''Url makeLenses ''Req isCapture :: Segment -> Bool @@ -155,66 +168,66 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where -- > -- class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType + typeFor :: Proxy lang -> Proxy a -> ForeignType data NoTypes -instance HasForeignType NoTypes a where - typeFor _ _ = empty +instance HasForeignType NoTypes ftype where + typeFor _ _ = empty + +type HasNoForeignType = HasForeignType NoTypes class HasForeign lang (layout :: *) where type Foreign layout :: * foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout instance (HasForeign lang a, HasForeign lang b) - => HasForeign lang (a :<|> b) where + => HasForeign lang (a :<|> b) where type Foreign (a :<|> b) = Foreign a :<|> Foreign b foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy a) req :<|> foreignFor lang (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Capture sym a :> sublayout) where +instance (KnownSymbol sym, HasForeignType lang ftype, HasForeign lang sublayout) + => HasForeign lang (Capture sym ftype :> sublayout) where type Foreign (Capture sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.path <>~ [Segment (Cap arg)] - & funcName %~ (++ ["by", str]) - + & reqFuncName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy ftype)) instance (Elem JSON list, HasForeignType lang a, ReflectMethod method) - => HasForeign lang (Verb method status list a) where + => HasForeign lang (Verb method status list a) where type Foreign (Verb method status list a) = Req foreignFor lang Proxy req = - req & funcName %~ (methodLC :) + req & reqFuncName %~ (methodLC :) & reqMethod .~ method & reqReturnType .~ retType where - retType = typeFor lang (Proxy :: Proxy a) - method = reflectMethod (Proxy :: Proxy method) - methodLC = toLower $ decodeUtf8 method + retType = typeFor lang (Proxy :: Proxy a) + method = reflectMethod (Proxy :: Proxy method) + methodLC = toLower $ decodeUtf8 method instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Header sym a :> sublayout) where + => HasForeign lang (Header sym a :> sublayout) where type Foreign (Header sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang subP $ req & reqHeaders <>~ [HeaderArg arg] - where - hname = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (hname, typeFor lang (Proxy :: Proxy a)) - subP = Proxy :: Proxy sublayout + hname = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (hname, typeFor lang (Proxy :: Proxy a)) + subP = Proxy :: Proxy sublayout instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (QueryParam sym a :> sublayout) where + => HasForeign lang (QueryParam sym a :> sublayout) where type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -222,38 +235,37 @@ instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) req & reqUrl.queryStr <>~ [QueryArg arg Normal] where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy a)) -instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) - => HasForeign lang (QueryParams sym a :> sublayout) where +instance + (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) + => HasForeign lang (QueryParams sym a :> sublayout) where type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg List] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy [a])) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy [a])) -instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout) - => HasForeign lang (QueryFlag sym :> sublayout) where +instance + (KnownSymbol sym, HasForeignType lang Bool, HasForeign lang sublayout) + => HasForeign lang (QueryFlag sym :> sublayout) where type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = (str, typeFor lang (Proxy :: Proxy Bool)) instance HasForeign lang Raw where type Foreign Raw = HTTP.Method -> Req foreignFor _ Proxy req method = - req & funcName %~ ((toLower $ decodeUtf8 method) :) + req & reqFuncName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) @@ -271,19 +283,21 @@ instance (KnownSymbol path, HasForeign lang sublayout) foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ req & reqUrl.path <>~ [Segment (Static str)] - & funcName %~ (++ [str]) - + & reqFuncName %~ (++ [str]) where - str = Data.Text.map (\c -> if c == '.' then '_' else c) - . pack . symbolVal $ (Proxy :: Proxy path) + str = + Data.Text.map (\c -> if c == '.' then '_' else c) + . pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (RemoteHost :> sublayout) where type Foreign (RemoteHost :> sublayout) = Foreign sublayout foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (IsSecure :> sublayout) where type Foreign (IsSecure :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -302,7 +316,8 @@ instance HasForeign lang sublayout => foreignFor lang Proxy = foreignFor lang (Proxy :: Proxy sublayout) -instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where +instance HasForeign lang sublayout + => HasForeign lang (HttpVersion :> sublayout) where type Foreign (HttpVersion :> sublayout) = Foreign sublayout foreignFor lang Proxy req = @@ -317,10 +332,15 @@ class GenerateList reqs where instance GenerateList Req where generateList r = [r] -instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> rest) where +instance (GenerateList start, GenerateList rest) + => GenerateList (start :<|> rest) where generateList (start :<|> rest) = (generateList start) ++ (generateList rest) -- | Generate the necessary data for codegen as a list, each 'Req' -- describing one endpoint from your API type. -listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] +listFromAPI + :: (HasForeign lang api, GenerateList (Foreign api)) + => Proxy lang + -> Proxy api + -> [Req] listFromAPI lang p = generateList (foreignFor lang p defReq) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index 06e722cc..0e279994 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -15,7 +15,6 @@ module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign -import Servant.Foreign.Internal import Test.Hspec @@ -35,15 +34,19 @@ camelCaseSpec = describe "camelCase" $ do data LangX instance HasForeignType LangX () where - typeFor _ _ = "voidX" + typeFor _ _ = "voidX" + instance HasForeignType LangX Int where - typeFor _ _ = "intX" + typeFor _ _ = "intX" + instance HasForeignType LangX Bool where - typeFor _ _ = "boolX" + typeFor _ _ = "boolX" + instance OVERLAPPING_ HasForeignType LangX String where - typeFor _ _ = "stringX" + typeFor _ _ = "stringX" + instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where - typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) + typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) type TestApi = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int @@ -56,58 +59,57 @@ testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do - it "generates 4 endpoints for TestApi" $ do - length testApi `shouldBe` 4 + it "generates 4 endpoints for TestApi" $ do + length testApi `shouldBe` 4 - let [getReq, postReq, putReq, deleteReq] = testApi + let [getReq, postReq, putReq, deleteReq] = testApi - it "collects all info for get request" $ do - shouldBe getReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("flag", "boolX") Flag ] - , _reqMethod = "GET" - , _reqHeaders = [HeaderArg ("header", "listX of stringX")] - , _reqBody = Nothing - , _reqReturnType = "intX" - , _funcName = ["get", "test"] - } + it "collects all info for get request" $ do + shouldBe getReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg ("flag", "boolX") Flag ] + , _reqMethod = "GET" + , _reqHeaders = [HeaderArg ("header", "listX of stringX")] + , _reqBody = Nothing + , _reqReturnType = "intX" + , _reqFuncName = ["get", "test"] + } - it "collects all info for post request" $ do - shouldBe postReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("param", "intX") Normal ] - , _reqMethod = "POST" - , _reqHeaders = [] - , _reqBody = Just "listX of stringX" - , _reqReturnType = "voidX" - , _funcName = ["post", "test"] - } + it "collects all info for post request" $ do + shouldBe postReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg ("param", "intX") Normal ] + , _reqMethod = "POST" + , _reqHeaders = [] + , _reqBody = Just "listX of stringX" + , _reqReturnType = "voidX" + , _reqFuncName = ["post", "test"] + } - it "collects all info for put request" $ do - shouldBe putReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - -- Shoud this be |intX| or |listX of intX| ? - [ QueryArg ("params", "listX of intX") List ] - , _reqMethod = "PUT" - , _reqHeaders = [] - , _reqBody = Just "stringX" - , _reqReturnType = "voidX" - , _funcName = ["put", "test"] - } - - it "collects all info for delete request" $ do - shouldBe deleteReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" - , Segment $ Cap ("id", "intX") ] - [] - , _reqMethod = "DELETE" - , _reqHeaders = [] - , _reqBody = Nothing - , _reqReturnType = "voidX" - , _funcName = ["delete", "test", "by", "id"] - } + it "collects all info for put request" $ do + shouldBe putReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + -- Shoud this be |intX| or |listX of intX| ? + [ QueryArg ("params", "listX of intX") List ] + , _reqMethod = "PUT" + , _reqHeaders = [] + , _reqBody = Just "stringX" + , _reqReturnType = "voidX" + , _reqFuncName = ["put", "test"] + } + it "collects all info for delete request" $ do + shouldBe deleteReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap ("id", "intX") ] + [] + , _reqMethod = "DELETE" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = "voidX" + , _reqFuncName = ["delete", "test", "by", "id"] + } diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 8530b03f..4d647225 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -128,7 +128,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> fsep = if hasService then ":" else " =" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 25e92df3..c8540efe 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -116,7 +116,7 @@ generateAxiosJSWith aopts opts req = "\n" <> where hasNoModule = moduleName opts == "" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = T.toLower . decodeUtf8 $ req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 481536ad..61c33e0f 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -51,12 +51,19 @@ type JavaScriptGenerator = [Req] -> Text -- customize the output data CommonGeneratorOptions = CommonGeneratorOptions { - functionNameBuilder :: FunctionName -> Text -- ^ function generating function names - , requestBody :: Text -- ^ name used when a user want to send the request body (to let you redefine it) - , successCallback :: Text -- ^ name of the callback parameter when the request was successful - , errorCallback :: Text -- ^ name of the callback parameter when the request reported an error - , moduleName :: Text -- ^ namespace on which we define the foreign function (empty mean local var) - , urlPrefix :: Text -- ^ a prefix we should add to the Url in the codegen + functionNameBuilder :: FunctionName -> Text + -- ^ function generating function names + , requestBody :: Text + -- ^ name used when a user want to send the request body + -- (to let you redefine it) + , successCallback :: Text + -- ^ name of the callback parameter when the request was successful + , errorCallback :: Text + -- ^ name of the callback parameter when the request reported an error + , moduleName :: Text + -- ^ namespace on which we define the foreign function (empty mean local var) + , urlPrefix :: Text + -- ^ a prefix we should add to the Url in the codegen } -- | Default options. diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 71147006..dfd3ddc0 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -81,7 +81,7 @@ generateJQueryJSWith opts req = "\n" <> namespace = if (moduleName opts) == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index f623e2a6..386a0d2e 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -93,7 +93,7 @@ generateVanillaJSWith opts req = "\n" <> namespace = if moduleName opts == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url'