rest-gen 0.15.0.2 → 0.16

raw patch · 9 files changed

+385/−217 lines, 9 filesdep +semigroupsdep ~rest-corePVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups

Dependency ranges changed: rest-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−1
• files/Javascript/base.js +32/−20
• rest-gen.cabal +6/−4
• src/Rest/Gen/Base/ActionInfo.hs +206/−112
• src/Rest/Gen/Docs.hs +9/−7
• src/Rest/Gen/Haskell.hs +81/−51
• src/Rest/Gen/JavaScript.hs +12/−8
• src/Rest/Gen/Ruby.hs +14/−9
• tests/Runner.hs +12/−5

@@ -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 

@@ -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;   } }

@@ -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.*

@@ -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/<identifier>-  , postAction   :: Bool         -- Works on identified resources? e.g. uri/<uri>/action+  { ident        :: Maybe Ident -- Requires extra identifier in url? e.g. page/<identifier>+  , postAction   :: Bool        -- Works on identified resources? e.g. uri/<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

@@ -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 _    = ""

@@ -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 = []+    }

@@ -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")

@@ -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")

@@ -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