diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,24 @@ # Changelog +#### 0.16 + +You don't have to regenerate clients for this release, but it is strongly recommended! + +* Accept headers are now sent based on both the output and errors of an endpoint, previously none of the clients would handle an end point with different inputs and outputs properly. + +* JavaScript/node.js: Error objects now contain a JSON `response` property if the error response is valid JSON. + +#### 0.15.0.3 + +* Bump `rest-types` and `rest-core` + #### 0.15.0.2 * Allow `json-schema 0.7.*` #### 0.15.0.1 -* JavaScript/node.js: Fixed error handling for `ECONNREFUSED` and other "top level" errors. +* JavaScript/node.js: Fixed error handling for `ECONNREFUSED` and other "top level" errors ## 0.15 diff --git a/files/Javascript/base.js b/files/Javascript/base.js --- a/files/Javascript/base.js +++ b/files/Javascript/base.js @@ -37,21 +37,23 @@ $apinamespace$.defaultAjaxOptions = {}; $apinamespace$.defaultHeaders = {}; -function jQueryRequest (method, url, params, success, error, contentType, dataType, data, callOpts) +function jQueryRequest (method, url, params, success, error, contentType, acceptHeader, data, callOpts) { var q = window.Q || function (a) { return a }; + var headers = $dollar$.extend(true, {}, $apinamespace$.defaultHeaders); + $apinamespace$.addObject(headers, { Accept : acceptHeader }); + var callData = - { type: method - , url: url + (params ? '?' + $dollar$.param(params) : '') - , cache: false - , success: success || function () {} - , error: error || function () {} - , contentType: contentType - , dataType: dataType - , xhrFields: { withCredentials: true } - , data: data || [] - , headers: $apinamespace$.defaultHeaders + { type : method + , url : url + (params ? '?' + $dollar$.param(params) : '') + , cache : false + , success : success || function () {} + , error : error || function () {} + , contentType : contentType + , headers : headers + , xhrFields : { withCredentials: true } + , data : data || [] }; $apinamespace$.addObject(callData, $apinamespace$.defaultAjaxOptions); @@ -60,7 +62,7 @@ return q($dollar$.ajax(callData)); } -function nodeRequest (method, url, params, onSuccess, onError, contentType, dataType, data, callOpts) +function nodeRequest (method, url, params, onSuccess, onError, contentType, acceptHeader, data, callOpts) { var allParams = {}; $apinamespace$.addObject(allParams, params); @@ -69,12 +71,9 @@ // Avoid cached API responses. allParams._ = Date.now(); - var headers = { "Content-type": contentType }; - - if (dataType === 'json') - headers.Accept = 'text/json'; - else if (dataType === 'xml') - headers.Accept = 'text/xml'; + var headers = { "Content-type" : contentType + , "Accept" : acceptHeader + }; $apinamespace$.addObject(headers, $apinamespace$.defaultHeaders); @@ -111,6 +110,8 @@ error.responseBody = body; } + error.response = parse(body); + if (onError) onError(error); @@ -121,8 +122,19 @@ function parse (response) { - if (dataType === 'json') - return JSON.parse(response); + if (acceptHeader.split(";").indexOf('text/json') >= 0) + { + var r = response; + try + { + r = JSON.parse(response); + } + catch (e) + { + return r; + } + return r; + } else return response; } } diff --git a/rest-gen.cabal b/rest-gen.cabal --- a/rest-gen.cabal +++ b/rest-gen.cabal @@ -1,5 +1,5 @@ name: rest-gen -version: 0.15.0.2 +version: 0.16 description: Documentation and client generation from rest definition. synopsis: Documentation and client generation from rest definition. maintainer: code@silk.co @@ -63,12 +63,13 @@ , json-schema >= 0.6 && < 0.8 , pretty >= 1.0 && < 1.2 , process >= 1.0 && < 1.3 - , rest-core >= 0.31 && < 0.33 + , rest-core >= 0.31 && < 0.34 , safe >= 0.2 && < 0.4 + , semigroups == 0.15.* , scientific >= 0.3.2 && < 0.4 , split >= 0.1 && < 0.3 , tagged >= 0.2 && < 0.8 - , text >= 0.11 && < 1.2 + , text >= 0.11 && < 1.3 , uniplate >= 1.6.12 && < 1.7 , unordered-containers == 0.2.* , vector == 0.10.* @@ -81,8 +82,9 @@ build-depends: base >= 4.5 && < 4.8 , HUnit == 1.2.* + , fclabels >= 1.0.4 && < 2.1 , haskell-src-exts >= 1.15.0 && < 1.16.0 - , rest-core >= 0.31 && < 0.33 + , rest-core >= 0.31 && < 0.34 , rest-gen , test-framework == 0.8.* , test-framework-hunit == 0.3.* diff --git a/src/Rest/Gen/Base/ActionInfo.hs b/src/Rest/Gen/Base/ActionInfo.hs --- a/src/Rest/Gen/Base/ActionInfo.hs +++ b/src/Rest/Gen/Base/ActionInfo.hs @@ -1,19 +1,40 @@ {-# LANGUAGE - CPP - , GADTs + GADTs + , LambdaCase + , NoMonomorphismRestriction , ScopedTypeVariables + , TemplateHaskell #-} module Rest.Gen.Base.ActionInfo ( Accessor , ActionInfo (..) , ActionType (..) , ActionTarget (..) - , DataDescription (..) , DataType (..) , ResourceId , accessLink , accessors , chooseType + + , DataDesc (..) + , dataType + , haskellType + , haskellModules + + , DataMeta (..) + , dataTypeDesc + , dataSchema + , dataExample + + , DataDescription (..) + , desc + , meta + + , ResponseType (..) + , responseAcceptType + , dataTypesToAcceptHeader + , chooseResponseType + , isAccessor , listGetterActionInfo , mkActionDescription @@ -30,28 +51,30 @@ import Control.Category import Control.Monad import Data.Foldable (foldMap) +import Data.Label.Derive import Data.List +import Data.List.NonEmpty (NonEmpty) import Data.Maybe +import Data.Ord import Data.Proxy import Data.Typeable --- TODO Remove CPP -#if __GLASGOW_HASKELL__ < 704 -import Data.List.Split -#endif -import qualified Data.JSON.Schema as J -import qualified Data.Label.Total as L +import Safe +import qualified Data.Foldable as F +import qualified Data.JSON.Schema as J +import qualified Data.Label.Total as L +import qualified Data.List.NonEmpty as NList import qualified Language.Haskell.Exts.Parser as H import qualified Language.Haskell.Exts.Syntax as H import Rest.Dictionary (Error (..), Input (..), Output (..), Param (..)) import Rest.Driver.Routing (mkListHandler, mkMultiHandler) +import Rest.Gen.Types import Rest.Handler import Rest.Info import Rest.Resource hiding (description) import Rest.Schema import qualified Rest.Dictionary as Dict import qualified Rest.Resource as Rest -import Rest.Gen.Types import Rest.Gen.Base.ActionInfo.Ident (Ident (Ident)) import Rest.Gen.Base.Link @@ -73,12 +96,40 @@ data ActionTarget = Self | Any deriving (Show, Eq) +data DataType = String | XML | JSON | File | Other deriving (Show, Eq) + +-- | Core information about the type of the input/output +data DataDesc = DataDesc + { _dataType :: DataType + , _haskellType :: H.Type + , _haskellModules :: [H.ModuleName] + } deriving (Show, Eq) + +mkLabel ''DataDesc + +-- | Documentation information about the input/output +data DataMeta = DataMeta + { _dataTypeDesc :: String -- ^ The name of the DataType, or a custom value if dataType is Other + , _dataSchema :: Maybe String -- ^ Just if dataType is XML + , _dataExample :: Maybe String -- ^ Just if dataType is XML or JSON + } deriving (Show, Eq) + +mkLabel ''DataMeta + +-- | Combines the core and documentation information for input/output +data DataDescription = DataDescription + { _desc :: DataDesc + , _meta :: DataMeta + } deriving (Show, Eq) + +mkLabel ''DataDescription + data ActionInfo = ActionInfo - { ident :: Maybe Ident -- Requires extra identifier in url? e.g. page/ - , postAction :: Bool -- Works on identified resources? e.g. uri//action + { ident :: Maybe Ident -- Requires extra identifier in url? e.g. page/ + , postAction :: Bool -- Works on identified resources? e.g. uri//action , actionType :: ActionType , actionTarget :: ActionTarget - , resDir :: String -- Resource directory + , resDir :: String -- Resource directory , method :: RequestMethod , inputs :: [DataDescription] , outputs :: [DataDescription] @@ -91,25 +142,113 @@ isAccessor :: ActionInfo -> Bool isAccessor ai = actionType ai == Retrieve && actionTarget ai == Self -data DataType = String | XML | JSON | File | Other deriving (Show, Eq) +defaultDescription :: DataType -> String -> H.Type -> DataDescription +defaultDescription typ typeDesc htype = + DataDescription + { _desc = DataDesc + { _dataType = typ + , _haskellType = htype + , _haskellModules = [] + } + , _meta = DataMeta + { _dataTypeDesc = typeDesc + , _dataSchema = Nothing + , _dataExample = Nothing + } + } --- | Description of input/output data -data DataDescription = DataDescription - { dataType :: DataType - , dataTypeDesc :: String - , dataSchema :: String - , dataExample :: String - , haskellType :: Maybe H.Type - , haskellModules :: [H.ModuleName] - } deriving (Show, Eq) +chooseType :: NonEmpty DataDescription -> DataDescription +chooseType ls = fromMaybe (NList.head ls) $ F.find ((JSON ==) . L.get (dataType . desc)) ls -defaultDescription :: DataDescription -defaultDescription = DataDescription Other "" "" "" Nothing [] +data ResponseType = ResponseType + { errorType :: Maybe DataDesc + , outputType :: Maybe DataDesc + } deriving Show -chooseType :: [DataDescription] -> Maybe DataDescription -chooseType [] = Nothing -chooseType ls@(x : _) = Just $ fromMaybe x $ find ((JSON ==) . dataType) ls +responseAcceptType :: ResponseType -> [DataType] -- TODO make non empty list Maybe (NonEmpty DataType) +responseAcceptType (ResponseType e o) = typs + where + typs :: [DataType] + typs = nub $ f e ++ f o + where + f :: Maybe DataDesc -> [DataType] + f = maybeToList . fmap (L.get dataType) +-- | First argument is the default accept header to use if there is no +-- output or errors, must be XML or JSON. +dataTypesToAcceptHeader :: DataType -> [DataType] -> String +dataTypesToAcceptHeader def = \case + [] -> dataTypeToAcceptHeader def + xs -> intercalate "," . map dataTypeToAcceptHeader . (xs ++) $ + if null (intersect xs [XML,JSON]) + then [def] + else [] + +dataTypeToAcceptHeader :: DataType -> String +dataTypeToAcceptHeader = \case + String -> "text/plain" + XML -> "text/xml" + JSON -> "text/json" + File -> "application/octet-stream" + Other -> "text/plain" + +chooseResponseType :: ActionInfo -> ResponseType +chooseResponseType ai = case (NList.nonEmpty $ outputs ai, NList.nonEmpty $ errors ai) of + -- No outputs or errors defined + (Nothing, Nothing) -> + ResponseType + { errorType = Nothing + , outputType = Nothing + } + -- Only an error type + (Nothing, Just e ) -> + ResponseType + { errorType = Just . L.get desc $ chooseType e + , outputType = Nothing + } + -- Only an output type + (Just o , Nothing) -> + ResponseType + { errorType = Nothing + , outputType = Just . L.get desc $ chooseType o + } + -- Output and error + (Just o , Just e ) -> intersection o e + + where + + intersection :: NonEmpty DataDescription -> NonEmpty DataDescription -> ResponseType + intersection o e = + -- Try to find a response type that can be used for both output and error. + case intersect (f o) (f e) of + -- If the response types are disjoint we need to specify both. + [] -> + ResponseType + { errorType = Just . L.get desc $ chooseType e + , outputType = Just . L.get desc $ chooseType o + } + xs -> + ResponseType + { errorType = matching xs e + , outputType = matching xs o + } + where + f = map (L.get (dataType . desc)) . NList.toList + matching :: [DataType] -> NonEmpty DataDescription -> Maybe DataDesc + matching dts = fmap (L.get desc) . headMay + -- Prioritize formats + . sortBy (comparing cmp) + -- Pick only the data types in the intersection of outputs and errors + . filter ((`elem` dts) . (L.get (dataType . desc))) + . NList.toList + -- When we have an intersection with multiple possible + -- types, we prefer JSON over XML, and XML over the rest. + cmp :: DataDescription -> Int + cmp dt = case L.get (dataType . desc) dt of + JSON -> 0 + XML -> 1 + _ -> 2 + -------------------- -- * Traverse a resource's Schema and Handlers to create a [ActionInfo]. @@ -286,83 +425,54 @@ -- | Extract input description from handlers handlerInputs :: Handler m -> [DataDescription] handlerInputs (GenHandler dict _ _) = map (handlerInput Proxy) (L.get (Dict.dicts . Dict.inputs) dict) - where handlerInput :: Proxy a -> Input a -> DataDescription - handlerInput d ReadI = defaultDescription { dataTypeDesc = describe d } - handlerInput _ StringI = defaultDescription { dataType = String - , dataTypeDesc = "String" - } - handlerInput d XmlI = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , dataSchema = X.showSchema . X.getXmlSchema $ d - , dataExample = X.showExample . X.getXmlSchema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } - handlerInput _ XmlTextI = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , haskellType = Just haskellStringType - } - handlerInput _ RawXmlI = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , haskellType = Just haskellStringType - } - handlerInput d JsonI = defaultDescription { dataType = JSON - , dataTypeDesc = "JSON" - , dataExample = J.showExample . J.schema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } - handlerInput _ FileI = defaultDescription { dataType = File - , dataTypeDesc = "File" - } + where + handlerInput :: Proxy a -> Input a -> DataDescription + handlerInput d c = case c of + ReadI -> L.set (haskellModules . desc) (modString d) + $ defaultDescription Other (describe d) (toHaskellType d) + StringI -> defaultDescription String "String" haskellStringType + XmlI -> L.set (haskellModules . desc) (modString d) + . L.set (dataSchema . meta) (Just . X.showSchema . X.getXmlSchema $ d) + . L.set (dataExample . meta) (Just . X.showExample . X.getXmlSchema $ d) + $ defaultDescription XML "XML" (toHaskellType d) + XmlTextI -> defaultDescription XML "XML" haskellStringType + RawXmlI -> defaultDescription XML "XML" haskellStringType + JsonI -> L.set (haskellModules . desc) (modString d) + . L.set (dataExample . meta) (Just . J.showExample . J.schema $ d) + $ defaultDescription JSON "JSON" (toHaskellType d) + FileI -> defaultDescription File "File" haskellByteStringType -- | Extract output description from handlers handlerOutputs :: Handler m -> [DataDescription] handlerOutputs (GenHandler dict _ _) = map (handlerOutput Proxy) (L.get (Dict.dicts . Dict.outputs) dict) - where handlerOutput :: Proxy a -> Output a -> DataDescription - handlerOutput _ StringO = defaultDescription { dataType = String - , dataTypeDesc = "String" - } - handlerOutput d XmlO = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , dataSchema = X.showSchema . X.getXmlSchema $ d - , dataExample = X.showExample . X.getXmlSchema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } - handlerOutput _ RawXmlO = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , haskellType = Just haskellStringType - } - handlerOutput d JsonO = defaultDescription { dataType = JSON - , dataTypeDesc = "JSON" - , dataExample = J.showExample . J.schema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } - handlerOutput _ FileO = defaultDescription { dataType = File - , dataTypeDesc = "File" - } + where + handlerOutput :: Proxy a -> Output a -> DataDescription + handlerOutput d c = case c of + StringO -> defaultDescription String "String" haskellStringType + XmlO -> L.set (haskellModules . desc) (modString d) + . L.set (dataSchema . meta) (Just . X.showSchema . X.getXmlSchema $ d) + . L.set (dataExample . meta) (Just . X.showExample . X.getXmlSchema $ d) + $ defaultDescription XML "XML" (toHaskellType d) + RawXmlO -> defaultDescription XML "XML" haskellStringType + JsonO -> L.set (haskellModules . desc) (modString d) + . L.set (dataExample . meta) (Just . J.showExample . J.schema $ d) + $ defaultDescription JSON "JSON" (toHaskellType d) + FileO -> defaultDescription File "File" haskellByteStringType -- | Extract input description from handlers handlerErrors :: Handler m -> [DataDescription] handlerErrors (GenHandler dict _ _) = map (handleError Proxy) (L.get (Dict.dicts . Dict.errors) dict) - where handleError :: Proxy a -> Error a -> DataDescription - handleError d XmlE = defaultDescription { dataType = XML - , dataTypeDesc = "XML" - , dataSchema = X.showSchema . X.getXmlSchema $ d - , dataExample = X.showExample . X.getXmlSchema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } - handleError d JsonE = defaultDescription { dataType = JSON - , dataTypeDesc = "JSON" - , dataExample = J.showExample . J.schema $ d - , haskellType = Just $ toHaskellType d - , haskellModules = modString d - } + where + handleError :: Proxy a -> Error a -> DataDescription + handleError d c = case c of + XmlE -> L.set (dataSchema . meta) (Just . X.showSchema . X.getXmlSchema $ d) + . L.set (dataExample . meta) (Just . X.showExample . X.getXmlSchema $ d) + . L.set (haskellModules . desc) (modString d) + $ defaultDescription XML "XML" (toHaskellType d) + JsonE -> L.set (dataExample . meta) (Just . J.showExample . J.schema $ d) + . L.set (haskellModules . desc) (modString d) + $ defaultDescription JSON "JSON" (toHaskellType d) -#if __GLASGOW_HASKELL__ >= 704 typeString :: forall a. Typeable a => Proxy a -> String typeString _ = typeString' . typeOf $ (undefined :: a) where typeString' tr = @@ -386,22 +496,6 @@ case H.parseType (typeString ty) of H.ParseOk parsedType -> parsedType H.ParseFailed _loc msg -> error msg -#else -typeString :: Typeable a => a -> String -typeString = show . typeOf - -modString :: Typeable a => a -> [ModuleName] -modString = map ModuleName . filter (/= "") . modString' . typeOf - where modString' tr = - let (tyCon, subs) = splitTyConApp tr - in (intercalate "." . init . splitOn "." . tyConString $ tyCon) : concatMap modString' subs - -toHaskellType :: Typeable a => a -> H.Type -toHaskellType ty = - case H.parseType (typeString ty) of - H.ParseOk parsedType -> parsedType - H.ParseFailed _loc msg -> error msg -#endif idIdent :: Id id -> Ident idIdent (Id idnt _) = actionIdent idnt diff --git a/src/Rest/Gen/Docs.hs b/src/Rest/Gen/Docs.hs --- a/src/Rest/Gen/Docs.hs +++ b/src/Rest/Gen/Docs.hs @@ -20,10 +20,11 @@ , writeDocs ) where -import Prelude hiding (div, head, id, span) +import Prelude hiding (div, head, id, id, span, (.)) import qualified Prelude as P -import Control.Monad hiding (forM_) +import Control.Category ((.)) +import Data.Foldable (forM_) import Data.Function (on) import Data.Hashable (hash) import Data.List hiding (head, span) @@ -32,10 +33,11 @@ import System.FilePath import System.Log.Logger import Text.Blaze.Html -import Text.Blaze.Html5 hiding (map) +import Text.Blaze.Html5 hiding (map, meta) import Text.Blaze.Html5.Attributes hiding (method, span, title) import Text.Blaze.Html.Renderer.String import Text.StringTemplate +import qualified Data.Label.Total as L import Rest.Api (Router, Version) import Rest.Gen.Base @@ -164,10 +166,10 @@ dataDescriptions s [] = toHtml s dataDescriptions _ descs = table ! cls "data-description" $ - do tr $ flip mapM_ descs $ \desc -> td $ toHtml $ dataTypeDesc desc - tr $ flip mapM_ descs $ \desc -> td $ - do when (dataSchema desc /= "") $ mkCode (typeLang (dataType desc)) "Schema" $ dataSchema desc - when (dataExample desc /= "") $ mkCode (typeLang (dataType desc)) "Example" $ dataExample desc + do tr $ forM_ descs $ \dsc -> td $ toHtml . L.get (dataTypeDesc . meta) $ dsc + tr $ forM_ descs $ \dsc -> td $ + do forM_ (L.get (dataSchema . meta) dsc) $ mkCode (typeLang (L.get (dataType . desc) dsc)) "Schema" + forM_ (L.get (dataExample . meta) dsc) $ mkCode (typeLang (L.get (dataType . desc) dsc)) "Example" where typeLang XML = "xml" typeLang JSON = "js" typeLang _ = "" diff --git a/src/Rest/Gen/Haskell.hs b/src/Rest/Gen/Haskell.hs --- a/src/Rest/Gen/Haskell.hs +++ b/src/Rest/Gen/Haskell.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DoAndIfThenElse + , LambdaCase , PatternGuards , TemplateHaskell #-} @@ -21,6 +22,8 @@ import System.Directory import System.FilePath import qualified Data.Generics.Uniplate.Data as U +import qualified Data.Label.Total as L +import qualified Data.List.NonEmpty as NList import qualified Distribution.ModuleName as Cabal import qualified Distribution.Package as Cabal import qualified Distribution.PackageDescription as Cabal @@ -155,7 +158,7 @@ mkFunction ver res (ApiAction _ lnk ai) = ([H.TypeSig noLoc [funName] fType, H.FunBind [H.Match noLoc funName fParams Nothing rhs noBinds]], - errorInfoModules errorI ++ infoModules output ++ maybe [] infoModules mInp) + responseModules errorI ++ responseModules output ++ maybe [] inputModules mInp) where funName = mkHsName ai fParams = map H.PVar $ lPars @@ -163,7 +166,8 @@ ++ maybe [] (const [input]) mInp ++ (if null (params ai) then [] else [pList]) (lUrl, lPars) = linkToURL res lnk - mInp = fmap inputInfo . chooseType . inputs $ ai + mInp :: Maybe InputInfo + mInp = fmap (inputInfo . L.get desc . chooseType) . NList.nonEmpty . inputs $ ai fType = H.TyForall Nothing [H.ClassA (H.UnQual cls) [m]] $ fTypify tyParts where cls = H.Ident "ApiStateC" m = H.TyVar $ H.Ident "m" @@ -181,14 +185,14 @@ ++ [H.TyApp m (H.TyApp (H.TyApp (H.TyCon $ H.UnQual (H.Ident "ApiResponse")) - (maybe haskellUnitType id (errorInfoType errorI))) - (maybe haskellUnitType id (infoType output)))] + (responseHaskellType errorI)) + (responseHaskellType output))] qualIdent (H.Ident s) | s == res = H.TyCon $ H.UnQual tyIdent | otherwise = H.TyCon $ H.Qual (H.ModuleName $ modName s) tyIdent qualIdent H.Symbol{} = error "Rest.Gen.Haskell.mkFunction.qualIdent - not expecting a Symbol" - inp | Just i <- mInp, - Just i' <- infoType i = [i'] + inp | Just i <- mInp + , i' <- inputHaskellType i = [i'] | otherwise = [] input = H.Ident "input" pList = H.Ident "pList" @@ -196,8 +200,8 @@ where binds = H.BDecls [rHeadersBind, requestBind] rHeadersBind = H.PatBind noLoc (H.PVar rHeaders) Nothing - (H.UnGuardedRhs $ H.List [H.Tuple H.Boxed [use hAccept, H.Lit $ H.String $ infoContentType output], - H.Tuple H.Boxed [use hContentType, H.Lit $ H.String $ maybe "text/plain" infoContentType mInp]]) + (H.UnGuardedRhs $ H.List [H.Tuple H.Boxed [use hAccept , H.Lit $ H.String $ dataTypesToAcceptHeader JSON $ responseAcceptType responseType], + H.Tuple H.Boxed [use hContentType, H.Lit $ H.String $ maybe "text/plain" inputContentType mInp]]) noBinds rHeaders = H.Ident "rHeaders" @@ -218,22 +222,21 @@ (if null (params ai) then (H.List []) else (use pList))) (use rHeaders))) noBinds appLast e - | Just i <- mInp = H.App e (H.App (use $ H.Ident $ infoFunc i) (use input)) + | Just i <- mInp = H.App e (H.App (use $ H.Ident $ inputFunc i) (use input)) | otherwise = H.App e (H.Lit $ H.String "") makeReq = H.Ident "makeReq" request = H.Ident "request" expr = H.App (H.App (H.App (use doRequest) - (use $ H.Ident $ errorInfoFunc errorI)) - (use $ H.Ident $ infoFunc output)) (use request) + (use $ H.Ident $ responseFunc errorI)) + (use $ H.Ident $ responseFunc output)) (use request) (ve, url) = ("v" ++ show ver, lUrl) - errorI = headDef (ErrorInfo [] (Just haskellUnitType) defaultErrorConversion) - . map errorInfo - . mapMaybe (\v -> find ((v ==) . dataType) $ errors ai) - $ maybeToList (dataType <$> chooseType (outputs ai)) ++ [XML, JSON] - output = maybe (Info [] (Just haskellUnitType) "text/plain" "(const ())") outputInfo . chooseType . outputs $ ai - defaultErrorConversion = if fmap dataType (chooseType (outputs ai)) == Just JSON then "fromJSON" else "fromXML" + errorI :: ResponseInfo + errorI = errorInfo responseType + output :: ResponseInfo + output = outputInfo responseType + responseType = chooseResponseType ai linkToURL :: String -> Link -> (H.Exp, [H.Name]) linkToURL res lnk = first H.List $ urlParts res lnk ([], []) @@ -333,42 +336,69 @@ modName :: String -> String modName = concatMap upFirst . cleanName -data Info = Info - { infoModules :: [H.ModuleName] - , infoType :: Maybe H.Type - , infoContentType :: String - , infoFunc :: String +data InputInfo = InputInfo + { inputModules :: [H.ModuleName] + , inputHaskellType :: H.Type + , inputContentType :: String + , inputFunc :: String } deriving (Eq, Show) -inputInfo :: DataDescription -> Info -inputInfo ds = - case dataType ds of - String -> Info [] (Just haskellStringType) "text/plain" "fromString" - XML -> Info (haskellModules ds) (haskellType ds) "text/xml" "toXML" - JSON -> Info (haskellModules ds) (haskellType ds) "text/json" "toJSON" - File -> Info [] (Just haskellByteStringType) "application/octet-stream" "id" - Other -> Info [] (Just haskellByteStringType) "text/plain" "id" - -outputInfo :: DataDescription -> Info -outputInfo ds = - case dataType ds of - String -> Info [] (Just haskellStringType) "text/plain" "toString" - XML -> Info (haskellModules ds) (haskellType ds) "text/xml" "fromXML" - JSON -> Info (haskellModules ds) (haskellType ds) "text/json" "fromJSON" - File -> Info [] (Just haskellByteStringType) "*" "id" - Other -> Info [] (Just haskellByteStringType)"text/plain" "id" +inputInfo :: DataDesc -> InputInfo +inputInfo dsc = + case L.get dataType dsc of + String -> InputInfo [] (haskellStringType) "text/plain" "fromString" + -- TODO fromJusts + XML -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/xml" "toXML" + JSON -> InputInfo (L.get haskellModules dsc) (L.get haskellType dsc) "text/json" "toJSON" + File -> InputInfo [] haskellByteStringType "application/octet-stream" "id" + Other -> InputInfo [] haskellByteStringType "text/plain" "id" -data ErrorInfo = ErrorInfo - { errorInfoModules :: [H.ModuleName] - , errorInfoType :: (Maybe H.Type) - , errorInfoFunc :: String +data ResponseInfo = ResponseInfo + { responseModules :: [H.ModuleName] + , responseHaskellType :: H.Type + , responseFunc :: String } deriving (Eq, Show) -errorInfo :: DataDescription -> ErrorInfo -errorInfo ds = - case dataType ds of - String -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML" - XML -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML" - JSON -> ErrorInfo (haskellModules ds) (haskellType ds) "fromJSON" - File -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML" - Other -> ErrorInfo (haskellModules ds) (haskellType ds) "fromXML" +outputInfo :: ResponseType -> ResponseInfo +outputInfo r = + case outputType r of + Nothing -> ResponseInfo [] haskellUnitType "(const ())" + Just t -> case L.get dataType t of + String -> ResponseInfo [] haskellStringType "toString" + XML -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromXML" + JSON -> ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromJSON" + File -> ResponseInfo [] haskellByteStringType "id" + Other -> ResponseInfo [] haskellByteStringType "id" + +errorInfo :: ResponseType -> ResponseInfo +errorInfo r = + case errorType r of + -- Rest only has XML and JSON instances for errors, so we need to + -- include at least one of these in the accept header. We don't + -- want to make assumptions about the response type if there is no + -- accept header so in that case we force it to be JSON. + Nothing -> fromJustNote ("rest-gen bug: toResponseInfo' was called with a data type other than XML or JSON, responseType: " ++ show r) + . toResponseInfo' . defaultErrorDataDesc . maybe XML (\x -> case x of { XML -> XML; _ -> JSON }) + . fmap (L.get dataType) . outputType + $ r + Just t -> toResponseInfo [t] + where + toResponseInfo :: [DataDesc] -> ResponseInfo + toResponseInfo xs + = fromMaybe (error $ "Unsupported error formats: " ++ show xs ++ ", this is a bug in rest-gen.") + . headMay + . mapMaybe toResponseInfo' + $ xs + toResponseInfo' :: DataDesc -> Maybe ResponseInfo + toResponseInfo' t = case L.get dataType t of + XML -> Just $ ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromXML" + JSON -> Just $ ResponseInfo (L.get haskellModules t) (L.get haskellType t) "fromJSON" + _ -> Nothing + +defaultErrorDataDesc :: DataType -> DataDesc +defaultErrorDataDesc dt = + DataDesc + { _dataType = dt + , _haskellType = haskellUnitType + , _haskellModules = [] + } diff --git a/src/Rest/Gen/JavaScript.hs b/src/Rest/Gen/JavaScript.hs --- a/src/Rest/Gen/JavaScript.hs +++ b/src/Rest/Gen/JavaScript.hs @@ -1,14 +1,18 @@ {-# LANGUAGE ScopedTypeVariables #-} module Rest.Gen.JavaScript (mkJsApi) where -import Code.Build -import Code.Build.JavaScript +import Prelude hiding ((.)) +import Control.Category ((.)) import Control.Monad import Data.Maybe import Text.StringTemplate +import qualified Data.Label.Total as L +import qualified Data.List.NonEmpty as NList import qualified Language.Haskell.Exts.Syntax as H +import Code.Build +import Code.Build.JavaScript import Rest.Api (Router, Version) import Rest.Gen.Base import Rest.Gen.Types @@ -89,8 +93,8 @@ let fParams = maybeToList mIdent ++ maybeToList (fmap fst3 mInp) ++ ["success", "error", "params", "callOpts"] - mInp = fmap mkType . chooseType $ inputs ai - mOut = fmap mkType . chooseType $ outputs ai + mInp = fmap (mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . inputs $ ai + mOut = dataTypesToAcceptHeader JSON . responseAcceptType . chooseResponseType $ ai urlPart = (if isAccessor ai then const "" else id) $ (if resDir ai == "" then "" else resDir ai ++ "/") ++ maybe "" (\i -> "' + encodeURIComponent(" ++ i ++ ") + '/") mIdent @@ -103,7 +107,7 @@ , code "success" , code "error" , string $ maybe "text/plain" snd3 mInp - , string $ maybe "text" fst3 mOut + , string $ mOut , maybe (code "undefined") (\(p, _, f) -> f (code p)) mInp , code "callOpts" ] @@ -130,9 +134,9 @@ jsId [] = "" jsId (x : xs) = x ++ concatMap upFirst xs -mkType :: DataDescription -> (String, String, Code -> Code) -mkType ds = - case dataType ds of +mkType :: DataType -> (String, String, Code -> Code) +mkType dt = + case dt of String -> ("text", "text/plain", id) XML -> ("xml" , "text/xml", id) JSON -> ("json", "text/json", call "JSON.stringify") diff --git a/src/Rest/Gen/Ruby.hs b/src/Rest/Gen/Ruby.hs --- a/src/Rest/Gen/Ruby.hs +++ b/src/Rest/Gen/Ruby.hs @@ -1,16 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} module Rest.Gen.Ruby (mkRbApi) where +import Prelude hiding ((.)) + +import Control.Category ((.)) import Data.Char import Data.List import Data.List.Split (splitOn) import Data.Maybe +import qualified Data.Label.Total as L +import qualified Data.List.NonEmpty as NList +import qualified Language.Haskell.Exts.Syntax as H import Code.Build import Code.Build.Ruby - -import qualified Language.Haskell.Exts.Syntax as H - import Rest.Api (Router, Version) import Rest.Gen.Base import Rest.Gen.Types @@ -77,7 +80,8 @@ let fParams = maybeToList mIdent urlPart = (if resDir ai == "" then "" else resDir ai ++ "/") ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent - datType = maybe ":data" ((':':) . fst3 . mkType) $ chooseType $ outputs ai + datType = maybe ":data" ((':':) . fst3 . mkType . L.get (dataType . desc) . chooseType) + . NList.nonEmpty . outputs $ ai mIdent = fmap (rbName . cleanName . description) $ ident ai in function (rbName $ mkFuncParts node) fParams $ ret $ new (className rid) ["@url + '" ++ urlPart ++ "'", "@api", datType] @@ -87,8 +91,9 @@ let fParams = maybeToList mIdent ++ maybeToList (fmap fst3 mInp) ++ ["params = {}", "headers = {}"] - mInp = fmap mkType . chooseType $ inputs ai - mOut = fmap mkType . chooseType $ outputs ai + mInp = fmap (mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . inputs $ ai + -- TODO Other clients call responseAcceptType here + mOut = fmap (mkType . L.get (dataType . desc) . chooseType) . NList.nonEmpty . outputs $ ai urlPart = (if resDir ai == "" then "" else resDir ai ++ "/") ++ maybe "" (\i -> "' + " ++ i ++ " + '/") mIdent mIdent = fmap (rbName . cleanName . description) $ ident ai @@ -139,9 +144,9 @@ accessorName :: ResourceId -> String accessorName = concatMap upFirst . ("Access":) . concatMap cleanName -mkType :: DataDescription -> (String, String, Code -> Code) -mkType ds = - case dataType ds of +mkType :: DataType -> (String, String, Code -> Code) +mkType dt = + case dt of String -> ("data", "text/plain", id) XML -> ("xml" , "text/xml", (<+> ".to_s")) JSON -> ("json", "text/json", call "mkJson") diff --git a/tests/Runner.hs b/tests/Runner.hs --- a/tests/Runner.hs +++ b/tests/Runner.hs @@ -1,18 +1,24 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE + OverloadedStrings + , ScopedTypeVariables + #-} +import Prelude hiding ((.)) + +import Control.Category ((.)) import Data.String import Test.Framework (defaultMain) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertEqual) - +import qualified Data.Label.Total as L import qualified Language.Haskell.Exts.Parser as H import qualified Language.Haskell.Exts.Syntax as H import Rest.Api +import Rest.Dictionary (xmlJsonO) import Rest.Gen.Base.ActionInfo import Rest.Gen.Base.ApiTree -import Rest.Dictionary (xmlJsonO) import Rest.Handler import Rest.Resource import Rest.Schema @@ -73,8 +79,9 @@ testListingType :: Assertion testListingType = assertEqual "Listing should have List type" - (Just "Rest.Types.Container.List (())") - (haskellType . head . outputs . itemInfo . head . resItems $ api) + "Rest.Types.Container.List (())" + -- (L.get haskellType . outputs . itemInfo . head . resItems $ api) + (L.get (haskellType . desc) . head . outputs . itemInfo . head . resItems $ api) where api = apiTree (route resource) resource :: Resource IO IO Void () Void