diff --git a/webapi-openapi/CHANGELOG.md b/webapi-openapi/CHANGELOG.md index 78afa7d..2e5492a 100644 --- a/webapi-openapi/CHANGELOG.md +++ b/webapi-openapi/CHANGELOG.md @@ -1,5 +1,38 @@ # Revision history for webapi-openapi +## Unreleased + +* The registry emits dhall-do-api's current names (`OperationId`, + `mkOperationId`, `WebApi.Contract hiding (OperationId)`) and an + `ErrorText` instance for every named error type. +* A modular layout, `openapi-model-generator --config FILE` (JSON; see + `WebApi.OpenAPI.Modular`): one package per API, split into public + sublibraries by consumer. `model-` per module (from the document's + `x-zb` object), the contract as the main library (`App`, `Routes.`, + `Contract`, `Contract.`), and `registry` (`Registry.Instances.`, + `Registry.Ops.`, `Registry`). Hand-written stanzas are appended from the + config's `cabalExtra`; `gen/warnings.txt` lists what could not be typed. +* In the modular layout: + * component names resolve once to PascalCase Haskell names, avoiding what + the generated modules import; + * an untyped or property-less schema is `Opaque` (its JSON, crossing to + Dhall as text), never a crash; + * optional arrays are `Maybe`, and `ToJSON` leaves absent fields out + rather than sending `null` (an update touches only what it names); + * `NoFieldSelectors`, and positional pattern variables in `ToJSON`; + * a route with several captures gets a named path record (`PP`) + instead of webapi's tuple, which dhall-do's bridge has no instances for; + * header parameters are a record whose fields are the header names in + snake case, with a ToHeader that sends each under its wire name and + leaves an absent optional header out; + * of several media types, JSON is kept; of several 2xx responses, the + lowest; form and multipart bodies are left out with a warning until a + plan can carry a file; + * array request bodies of generated types get a whole-value + `OverrideType` (until dhall-do-api has one for `Vector`). +* The legacy single-module layout (the flags) is unchanged; a golden test + (`test/golden/ns-currency`) pins its output. + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/webapi-openapi/openapi-model-generator/Main.hs b/webapi-openapi/openapi-model-generator/Main.hs index b8a197f..fc855df 100644 --- a/webapi-openapi/openapi-model-generator/Main.hs +++ b/webapi-openapi/openapi-model-generator/Main.hs @@ -7,11 +7,13 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Internal as HM import Options.Applicative ( (<**>), + (<|>), fullDesc, header, info, help, long, + metavar, optional, showDefault, value, @@ -22,6 +24,7 @@ import Options.Applicative Parser ) import System.Exit (die) import WebApi.OpenAPI (generateModels, NamingMap) +import WebApi.OpenAPI.Modular (generateModular) data CliArgs = CliArgs @@ -32,8 +35,17 @@ data CliArgs enumMode :: String } -cliParser :: Parser CliArgs +-- | The modular layout from a generator config, or the single-module +-- legacy layout from flags. +data Cmd = Modular FilePath | Legacy CliArgs + +cliParser :: Parser Cmd cliParser = + (Modular <$> strOption (long "config" <> metavar "FILE" <> help "generator config (JSON): the modular layout")) + <|> (Legacy <$> legacyParser) + +legacyParser :: Parser CliArgs +legacyParser = CliArgs <$> strOption (long "inputJsonFP") <*> strOption (long "outDirBaseFp") @@ -43,13 +55,17 @@ cliParser = main :: IO () main = do - CliArgs {..} <- execParser opts - namingMap <- maybe (pure HM.empty) loadNamingMap namingMapFP - sumEnums <- case enumMode of - "text" -> pure False - "sum" -> pure True - other -> die ("--enumMode must be text or sum, not " <> other) - generateModels inputJsonFP outDirBaseFp reqFilePathPrefix namingMap sumEnums + cmd <- execParser opts + case cmd of + Modular fp -> + either (\e -> die (fp <> ": bad generator config: " <> e)) generateModular . A.eitherDecode =<< BL.readFile fp + Legacy CliArgs {..} -> do + namingMap <- maybe (pure HM.empty) loadNamingMap namingMapFP + sumEnums <- case enumMode of + "text" -> pure False + "sum" -> pure True + other -> die ("--enumMode must be text or sum, not " <> other) + generateModels inputJsonFP outDirBaseFp reqFilePathPrefix namingMap sumEnums where opts = info (cliParser <**> helper) @@ -61,5 +77,3 @@ main = do loadNamingMap fp = either (\e -> die (fp <> ": bad naming map: " <> e)) pure . A.eitherDecode =<< BL.readFile fp - - \ No newline at end of file diff --git a/webapi-openapi/src/WebApi/OpenAPI.hs b/webapi-openapi/src/WebApi/OpenAPI.hs index 1747f74..670afae 100644 --- a/webapi-openapi/src/WebApi/OpenAPI.hs +++ b/webapi-openapi/src/WebApi/OpenAPI.hs @@ -26,7 +26,7 @@ import Data.OpenApi Definitions, Param(_paramName, _paramSchema, _paramIn, _paramRequired), Operation(_operationParameters, _operationRequestBody, _operationResponses, _operationSummary, _operationOperationId), - ParamLocation(ParamHeader, ParamCookie, ParamQuery), + ParamLocation(ParamHeader, ParamCookie, ParamQuery, ParamPath), Info(_infoTitle), RequestBody(_requestBodyContent), MediaTypeObject(_mediaTypeObjectSchema), @@ -70,7 +70,7 @@ import GHC.SourceGen tuple, as' ) -import Data.HashMap.Strict.InsOrd as HMO (toList,lookup, empty, fromList, delete) +import Data.HashMap.Strict.InsOrd as HMO (toList,lookup, empty, fromList, delete, null) import Data.Text as T ( unpack, Text, append, splitAt, toUpper, take, pack, dropEnd, concat, split, toLower, breakOnEnd, isPrefixOf) import Data.Text.IO as T (writeFile) import qualified Data.Text.Encoding as TE @@ -96,6 +96,7 @@ import System.FilePath.Posix ( (<.>), (), dropExtension, takeFileName, splitDirectories ) import System.Directory ( createDirectoryIfMissing ) import Data.Char (isAlphaNum) +import qualified Data.Char import Data.List as L (delete, nub) import qualified Data.List import qualified Crypto.Hash.SHA256 as SHA256 @@ -109,7 +110,7 @@ import Data.Maybe ( fromMaybe, catMaybes ) import Control.Monad(when, unless) import Control.Applicative ((<|>)) import Control.Exception (SomeException, catch) -import Debug.Trace(trace, traceM) +import Debug.Trace(traceM) data ModelGenState = ModelGenState { seenVars :: Set Text @@ -131,8 +132,81 @@ data ModelGenState = -- alone (two {refName,id} objects with different id -- enums must not alias — M10c-4 bug fix) , inlineShapes :: HashMap Text [([(Text, Text)], Text)] + -- the modular layout (a generator config): component + -- names resolved once to Haskell names, the module whose + -- declarations are being generated, and the behaviours + -- the legacy single-module output keeps as they were + , modular :: Bool + , compNames :: HashMap Text Text + , curModule :: Text + , inlinePrefix :: Text + , warnings :: [Text] + , connectionParams :: Set Text + -- ^ modular: query parameters the connection sets on + -- every request (a tenant's organization, a shop), left + -- out of each operation's own parameters } +-- | The state both passes start from; the legacy layout keeps every +-- behaviour its golden output pins. +initState :: Bool -> [Text] -> ModelGenState +initState sumEnums reserved = + ModelGenState { seenVars = S.fromList reserved + , imports = S.empty + , keywordsToAvoid = S.fromList haskellKeywords + , createdSums = HM.empty + , jsonInstances = S.empty + , inlineRecords = S.empty + , paramRecords = S.empty + , bodyTypes = S.empty + , resultTypes = S.empty + , enumsAsSums = sumEnums + , enumSums = HM.empty + , enumTypes = S.empty + , inlineShapes = HM.empty + , modular = False + , compNames = HM.empty + , curModule = "" + , inlinePrefix = "NsObj" + , warnings = [] + , connectionParams = S.empty + } + +haskellKeywords :: [Text] +haskellKeywords = [ "case","class","data","default","deriving","do","else" + , "foreign","if","import","in","infix","infixl","infixr" + , "instance","let","module","newtype","of","then","type" + , "where","forall" ] + +warn :: MonadState ModelGenState m => Text -> m () +warn w = modify (\st -> st { warnings = w : warnings st }) + +-- | The Haskell type a component reference names. Legacy: the component +-- name, capitalised and stripped. Modular: the name resolved up front for +-- every component (so a declaration and every reference to it agree), and +-- "Opaque" where a schema is missing. +refName :: ModelGenState -> Text -> Text +refName st x + | modular st = case HM.lookup x (compNames st) of + Just n -> n + Nothing | x == "Untyped" -> "Opaque" + | otherwise -> pascalName x + | otherwise = removeUnsupportedSymbols (upperFirstChar x) + +-- | The name a component's own declaration takes. +componentDeclName :: MonadState ModelGenState m => Text -> m Text +componentDeclName dName = do + st <- get + if modular st then pure (refName st dName) else mkUnseenVar (upperFirstChar dName) + +-- | kebab-case, snake_case and dotted names as one PascalCase identifier. +pascalName :: Text -> Text +pascalName t = + case T.concat (upperFirstChar <$> filter (not . TQ.null) (TQ.split (\c -> not (isAlphaNum c)) t)) of + n | TQ.null n -> "T" + | Data.Char.isDigit (TQ.head n) -> T.append "T" n + | otherwise -> n + data PkgConfig = PkgConfig { authorName :: Text , email :: Text @@ -172,12 +246,19 @@ data OpMeta = , omUuid :: Maybe Text -- ^ curated uuid pin only , omSummary :: Maybe Text , omDefaults :: Maybe (HM.HashMap Text (HM.HashMap Text Text)) + , omPathParam :: Maybe HsType' + -- ^ modular: a named record for a route with several + -- captures (webapi's default is a tuple, which dhall-do's + -- bridge has no instances for, and which names nothing) + , omConnParams :: [Text] + -- ^ modular: the connection parameters the operation takes, + -- which the connection supplies instead of the operation } resolveOpMeta :: NamingMap -> FilePath -> Text -> Operation -> OpMeta resolveOpMeta namingMap path method oper = OpMeta { omKey = key, omName = name, omUuid = uuid, omSummary = summ - , omDefaults = neDefaults =<< curated } + , omDefaults = neDefaults =<< curated, omPathParam = Nothing, omConnParams = [] } where key = method <> " " <> T.pack path curated = HM.lookup key namingMap name = (neName <$> curated) <|> (sanitizeOpName <$> _operationOperationId oper) @@ -206,8 +287,17 @@ type OpSlot = ( Maybe HsType', Maybe HsType', Maybe HsType', Maybe HsType' , Maybe HsType', Maybe HsType', Maybe HsType', OpMeta ) -newtype ChildType = ChildType HsDecl' -newtype Instance = Instance HsDecl' +-- | A generated declaration, with the name it declares: the modular +-- layout routes each to its module by that name, and emits the registry's +-- bridge instances only for data types, never for synonyms. +data DeclKind = DataDecl | SynDecl deriving (Eq, Show) +data ChildType = ChildType { ctName :: Text, ctKind :: DeclKind, ctDecl :: HsDecl' } +-- | A generated instance, with the type it is for (it lives beside it). +data Instance = Instance { instFor :: Text, instDecl :: HsDecl' } + +dataCT, synCT :: Text -> HsDecl' -> ChildType +dataCT n = ChildType n DataDecl +synCT n = ChildType n SynDecl data DataTypeInfo = DataTypeInfo { @@ -239,17 +329,17 @@ generateModels fp destFp reqPrefix namingMap sumEnums = do appName = removeUnsupportedSymbols (upperFirstChar oApiName) (modelList, modelSt) = runState (mapM (\(x,y) -> createModelData (_schemaType y) compSchemas (x,y)) (HMO.toList compSchemas)) - (ModelGenState S.empty S.empty (S.fromList keywords) HM.empty (S.fromList seenVariables) S.empty S.empty S.empty S.empty sumEnums HM.empty S.empty HM.empty) + ((initState sumEnums seenVariables) { seenVars = S.empty, jsonInstances = S.fromList seenVariables }) hsModuleModel = module' (Just modName) Nothing impsModel (concatMap (\(cts, insts) -> rmChildTypeLayer cts ++ rmInstanceLayer insts) modelList) -- the contract pass continues the models pass's state: name and -- instance dedup must be global or the two modules would emit -- duplicate decls/instances (and GHC would refuse the package) ((routeInfo,typeSynList,instances), synSt) = - (\(rs, st) -> ((\(a,b,c) -> (Prelude.concat a,Prelude.concat b,Prelude.concat c)) (unzip3 rs), st)) + (\(rs, st) -> ((\(a,b,c) -> (Prelude.concat a,Prelude.concat b,Prelude.concat c)) (unzip3 [ (w, x ++ y, z) | (w, x, y, z) <- rs ]), st)) (runState (mapM (createTypeSynData namingMap appName compSchemas compParams compReqBodies compResponses compHeaders) (filter (T.isPrefixOf (T.pack reqPrefix) . T.pack . fst) (HMO.toList . _openApiPaths $ oApi))) - (ModelGenState (seenVars modelSt) S.empty (S.fromList keywords) (createdSums modelSt) (jsonInstances modelSt) (inlineRecords modelSt) S.empty S.empty S.empty sumEnums (enumSums modelSt) (enumTypes modelSt) (inlineShapes modelSt))) + (modelSt { imports = S.empty, paramRecords = S.empty, bodyTypes = S.empty, resultTypes = S.empty })) -- M10: resolved op names are identities (the FQN and the type-level -- OperationId) — they must be catalog-unique after sanitizing, and a @@ -296,10 +386,6 @@ generateModels fp destFp reqPrefix namingMap sumEnums = do es = [TypeOperators,KindSignatures,DataKinds,DuplicateRecordFields,DeriveGeneric,OverloadedStrings] es2 = [DataKinds,TypeOperators,TypeSynonymInstances,FlexibleInstances,MultiParamTypeClasses,TypeFamilies, OverloadedStrings,DeriveGeneric,DuplicateRecordFields] - keywords = [ "case","class","data","default","deriving","do","else" - , "foreign","if","import","in","infix","infixl","infixr" - , "instance","let","module","newtype","of","then","type" - , "where","forall" ] seenVariables = ["Untyped"] pkgName = T.unpack . flip T.append "-models" . T.pack . dropExtension . takeFileName $ fp pkgHome = destFp pkgName @@ -311,8 +397,8 @@ generateModels fp destFp reqPrefix namingMap sumEnums = do [tyFamInst "Apis" [var $ textToRdrNameStr a] (listPromotedTy (oneRoute <$> b))]] oneRoute (tName,methList) = var "Route" @@ listPromotedTy (var . textToRdrNameStr <$> methList) @@ var (textToRdrNameStr tName) untypedDef = data' "Untyped" [] [prefixCon "Maybe" [field (var "Text")]] [] - rmChildTypeLayer = fmap (\(ChildType x) -> x) - rmInstanceLayer = fmap (\(Instance x) -> x) + rmChildTypeLayer = fmap ctDecl + rmInstanceLayer = fmap instDecl mkApiContractInstances :: Text -> @@ -323,7 +409,8 @@ mkApiContractInstances oApiName (typName,instanceInfo) = where mkOneInstance (methName,(headInfo,queryInfo,cookieInfo,reqBodyInfo,apiOutInfo,apiErrInfo,headerOutInfo,om)) = instance' (var "ApiContract" @@ var (textToRdrNameStr oApiName) @@ var (textToRdrNameStr methName) @@ var (textToRdrNameStr typName)) (opIdSyn methName om : - Prelude.concat (mkTypeSyns methName <$> [("HeaderIn",headInfo) + Prelude.concat (mkTypeSyns methName <$> [("PathParam",omPathParam om) + ,("HeaderIn",headInfo) ,("QueryParam",queryInfo) ,("CookieIn",cookieInfo) ,("RequestBody",reqBodyInfo) @@ -357,7 +444,7 @@ createTypeSynData :: Definitions Response -> Definitions Header -> (FilePath,PathItem) -> - m ([(Text, [(Text, OpSlot)])],[ChildType],[Instance]) + m ([(Text, [(Text, OpSlot)])],[ChildType],[ChildType],[Instance]) createTypeSynData namingMap appName compSchemas compsParam compReqBodies compResponses compHeaders (fp,PathItem _ _ piGet piPut piPost piDelete piOptions piHead piPatch piTrace _ piParams) = do let paramsMap = refParamsToParams compsParam piParams commonParams = @@ -378,7 +465,8 @@ createTypeSynData namingMap appName compSchemas compsParam compReqBodies compRes return [((a,S.toList diff),c)] (apiConInsData,ct3,ci3) <- unzip3 <$> mapM (createApiContractInsData namingMap fp compSchemas compsParam compReqBodies compResponses compHeaders paramsMap) opList return ((fmap . fmap) (applyApiContractInfo (unions apiConInsData)) <$> commonTypSyn ++ typSyns - , Prelude.concat ct1 ++ Prelude.concat ct2 ++ Prelude.concat ct3 + , Prelude.concat ct1 ++ Prelude.concat ct2 -- the route synonyms + , Prelude.concat ct3 -- the contract's own types , Prelude.concat ci3) where pairLisToSet = S.fromList . fmap fst applyApiContractInfo apiInfoMap a = @@ -410,8 +498,12 @@ createApiContractInsData :: (Text,Operation) -> m (HashMap Text OpSlot,[ChildType],[Instance]) createApiContractInsData namingMap fp compSchemas compsParam compsReqBodies compResponses compHeaders commonParamMap (opName,operationData) = do + ModelGenState { connectionParams = connParams } <- get let opParamsMap = refParamsToParams compsParam (_operationParameters operationData) - overrideParams = HM.toList $ opParamsMap `union` commonParamMap + allParams = HM.toList $ opParamsMap `union` commonParamMap + isConn (n, (_, prm)) = _paramIn prm == ParamQuery && n `S.member` connParams + overrideParams = filter (not . isConn) allParams + connTaken = Data.List.sort [ n | x@(n, _) <- allParams, isConn x ] opReqBody = _operationRequestBody operationData opResponses = _responsesResponses . _operationResponses $ operationData responseList = fmap (refValToVal compResponses) <$> HMO.toList opResponses @@ -420,20 +512,34 @@ createApiContractInsData namingMap fp compSchemas compsParam compsReqBodies comp (responseToHeader <$> ( case defaultResponse of Nothing -> responseList (Just x) -> (0,refValToVal compResponses x):responseList)) + -- modular: several captures make a named path record, in path order + ModelGenState { modular = isModularOp } <- get + let captures = [ c | Right c <- parseFilePath fp ] + byName = HM.fromList overrideParams + pathParams = [ (c, p') | c <- captures, Just p' <- [HM.lookup c byName] ] + (pathTyp,ct0,ci0) <- if isModularOp && Prelude.length captures >= 2 && Prelude.length pathParams == Prelude.length captures + then mkParamRecord ParamPath pathParams + else return (Nothing,[],[]) (headtypTuple,ct1,ci1) <- createType ParamHeader overrideParams (querytypTuple,ct2,ci2) <- createType ParamQuery overrideParams (cookietypTuple,ct3,ci3') <- createType ParamCookie overrideParams (reqBody,ct4,ci4) <- createReqBody compSchemas compsReqBodies opReqBody + ModelGenState { modular = isModular } <- get + apiOutResp <- case catMaybes [HMO.lookup x opResponses | x <- [200..299]] of + (x : _ : _) | isModular -> do + warn (opName <> " " <> T.pack fp <> ": several 2xx responses; the lowest is ApiOut") + pure (Just x) + _ -> pure (findResponseApiOut opResponses) (apiOutType,ct5,ci5) <- createApiOut compSchemas compResponses - (findResponseApiOut opResponses) + apiOutResp defaultResponse (apiErrType,ct6,ci6) <- createApiErr compSchemas compResponses defaultResponse (HMO.toList(findResponseApiErr opResponses)) (headerOutType,ct7) <- createHeaderOut compSchemas headerOutSchemas - return ( HM.singleton opName (headtypTuple,querytypTuple,cookietypTuple,reqBody,apiOutType,apiErrType,headerOutType,opMeta) - , ct1 ++ ct2 ++ ct3 ++ ct4 ++ ct5 ++ ct6 ++ ct7 - , ci1 ++ ci2 ++ ci3' ++ ci4 ++ ci5 ++ ci6 + return ( HM.singleton opName (headtypTuple,querytypTuple,cookietypTuple,reqBody,apiOutType,apiErrType,headerOutType,opMeta { omPathParam = pathTyp, omConnParams = connTaken }) + , ct0 ++ ct1 ++ ct2 ++ ct3 ++ ct4 ++ ct5 ++ ct6 ++ ct7 + , ci0 ++ ci1 ++ ci2 ++ ci3' ++ ci4 ++ ci5 ++ ci6 ) where opMeta = resolveOpMeta namingMap fp opName operationData -- param records are named after the op when it has a name — @@ -448,15 +554,21 @@ createApiContractInsData namingMap fp compSchemas compsParam compsReqBodies comp -- vocabulary. Recorded as a spike finding. createType ParamHeader b = do let hs = fst <$> mFilter ParamHeader b - when (not (Prelude.null hs)) $ - traceM ("[openapi] " <> T.unpack opName <> ": dropping header params " <> show hs) - return (Nothing,[],[]) + ModelGenState { modular = isModular } <- get + if isModular && not (Prelude.null hs) + then mkHeaderRecord (mFilter ParamHeader b) + else do + when (not (Prelude.null hs)) $ + traceM ("[openapi] " <> T.unpack opName <> ": dropping header params " <> show hs) + return (Nothing,[],[]) createType a b = mkParamRecord a (mFilter a b) partLabel ParamQuery = "Q" partLabel ParamCookie = "C" + partLabel ParamPath = "P" partLabel _ = "X" promotedPart ParamQuery = "'QueryParam" promotedPart ParamCookie = "'Cookie" + promotedPart ParamPath = "'PathParam" promotedPart _ = "'QueryParam" -- a named record per (operation, part): nominal Generic records -- are what both webapi's param codecs and the Dhall bridge walk @@ -470,14 +582,46 @@ createApiContractInsData namingMap fp compSchemas compsParam compsReqBodies comp False Nothing compSchemas) ps let (schemaList,childTypes) = unzip $ (\(DataTypeInfo a b c _) -> ((a,b),c) ) <$> dataTypeInfoList wireUnsafe = [x | (x,_) <- schemaList, removeUnsupportedSymbols x /= x] + ModelGenState { modular = isModular } <- get when (not (Prelude.null wireUnsafe)) $ - traceM ("[openapi] " <> T.unpack opName <> ": param wire names change under sanitizing: " <> show wireUnsafe) + if isModular + then warn (fromMaybe opName (omName opMeta) <> ": parameter names change under sanitizing: " <> TQ.intercalate ", " wireUnsafe) + else traceM ("[openapi] " <> T.unpack opName <> ": param wire names change under sanitizing: " <> show wireUnsafe) ModelGenState { keywordsToAvoid } <- get let mkFld (x,y) = (textToOccNameStr (avoidKeywords (removeUnsupportedSymbols (lowerFirstChar x)) keywordsToAvoid), field y) - decl = ChildType $ data' (textToOccNameStr vName) [] [recordCon (textToOccNameStr vName) (mkFld <$> schemaList)] stdDeriving - pInsts = [ Instance $ instance' (var "ToParam" @@ var (fromString (promotedPart loc)) @@ var (textToRdrNameStr vName)) [] - , Instance $ instance' (var "FromParam" @@ var (fromString (promotedPart loc)) @@ var (textToRdrNameStr vName)) [] ] + decl = dataCT vName $ data' (textToOccNameStr vName) [] [recordCon (textToOccNameStr vName) (mkFld <$> schemaList)] stdDeriving + -- a path record is only ever encoded (a client's); webapi + -- decodes paths in its router, with no FromParam 'PathParam + pInsts = Instance vName (instance' (var "ToParam" @@ var (fromString (promotedPart loc)) @@ var (textToRdrNameStr vName)) []) + : [ Instance vName $ instance' (var "FromParam" @@ var (fromString (promotedPart loc)) @@ var (textToRdrNameStr vName)) [] + | loc /= ParamPath ] return (Just (var (textToRdrNameStr vName)), decl : Prelude.concat childTypes, pInsts) + -- modular: header parameters as a record whose fields are the + -- header names in snake case (X-Upsert -> x_upsert), and a + -- ToHeader that sends each under its wire name, an absent + -- optional header left out (webapi's generic ToHeader would send + -- the field names themselves) + mkHeaderRecord ps = do + vName <- mkUnseenVar (T.concat [upperFirstChar pBase, "HP"]) + modify (\st -> st { paramRecords = S.insert vName (paramRecords st) }) + let fieldOf wire = T.toLower (TQ.replace "-" "_" wire) + dataTypeInfoList <- mapM (\(pname,(_,param)) -> + parseRecordFields (fieldOf pname, maySchemaToSchema (_paramSchema param)) + (fromMaybe False (_paramRequired param)) + False Nothing compSchemas) ps + let (schemaList,childTypes) = unzip $ (\(DataTypeInfo a b c _) -> ((a,b),c) ) <$> dataTypeInfoList + ModelGenState { keywordsToAvoid } <- get + let mkFld (x,y) = (textToOccNameStr (avoidKeywords x keywordsToAvoid), field y) + decl = dataCT vName $ data' (textToOccNameStr vName) [] [recordCon (textToOccNameStr vName) (mkFld <$> schemaList)] stdDeriving + hvars = [ ("v" <> show i, pname, fromMaybe False (_paramRequired param)) | (i, (pname, (_, param))) <- zip [1 :: Int ..] ps ] + pairE wire x = tuple [var "mk" @@ string (T.unpack wire), var "encodeParam" @@ var x] + entry (v, wire, isReq') + | isReq' = var "Just" @@ pairE wire (fromString v) + | otherwise = var "fmap" @@ lambda [bvar "x"] (pairE wire "x") @@ var (fromString v) + inst = Instance vName $ instance' (var "ToHeader" @@ var (textToRdrNameStr vName)) + [funBind "toHeader" (match [conP (textToRdrNameStr vName) ((\(v,_,_) -> bvar (fromString v)) <$> hvars)] + (var "catMaybes" @@ list (entry <$> hvars)))] + return (Just (var (textToRdrNameStr vName)), decl : Prelude.concat childTypes, [inst]) responseToHeader (_,res) = fmap (_headerSchema . refValToVal compHeaders) <$> (HMO.toList . _responseHeaders $ res) findResponseApiOut hMap = case catMaybes [HMO.lookup x hMap | x <- [200..299]] of [] -> Nothing @@ -518,10 +662,13 @@ createApiOut compSchemas hMap (Just res) defRes = do Nothing -> createApiOut compSchemas hMap Nothing Nothing x -> createApiOut compSchemas hMap x Nothing else do - let (cType,maySchema) = mediaTypeObjToSchema mediaTypList + ModelGenState { modular = isModular } <- get + (cType,maySchema) <- if isModular + then fromMaybe (JSON, Nothing) <$> pickMedia "a response" mediaTypList + else pure (mediaTypeObjToSchema mediaTypList) case maySchema of Just (Ref (Reference x)) -> - modify (\st -> st { resultTypes = S.insert (removeUnsupportedSymbols (upperFirstChar x)) (resultTypes st) }) + modify (\st -> st { resultTypes = S.insert (refName st x) (resultTypes st) }) _ -> return () DataTypeInfo {typ,child_types,child_instances} <- mayBeSchemaToHsType ("ApiOutType",maySchema) True (Just cType) compSchemas return (Just typ,child_types, child_instances) @@ -543,7 +690,11 @@ createApiErr compSchemas hMap defRes resList = do if Prelude.null (Prelude.concat mediaTypList) then createApiErr compSchemas hMap Nothing [] else do - let (cType,neMediaTypList) = unzip $ second maySchemaToSchema . mediaTypeObjToSchema <$> filter (not . Prelude.null) mediaTypList + ModelGenState { modular = isModular } <- get + picked <- if isModular + then catMaybes <$> mapM (pickMedia "an error response") (filter (not . Prelude.null) mediaTypList) + else pure (mediaTypeObjToSchema <$> filter (not . Prelude.null) mediaTypList) + let (cType,neMediaTypList) = unzip $ second maySchemaToSchema <$> picked ctype' = case nub cType of [a] -> a _ -> error "Conflicting ApiErr Type" @@ -581,10 +732,24 @@ createReqBody :: createReqBody _ _ Nothing = return (Nothing,[],[]) createReqBody compSchemas compReqBodies (Just refReqBody) = do let reqBody = refValToVal compReqBodies refReqBody - let (typName,maySchema) = mediaTypeObjToSchema . HMO.toList . _requestBodyContent $ reqBody + ModelGenState { modular = isModular } <- get + picked <- if isModular + then pickMedia "a request body" (HMO.toList (_requestBodyContent reqBody)) + else pure (Just (mediaTypeObjToSchema . HMO.toList . _requestBodyContent $ reqBody)) + case picked of + Just (JSON, _) -> reqBodyOf picked + Just (other, _) | isModular -> do + -- form and multipart bodies wait for FormParam/FileParam emission + warn ("a " <> T.pack (show other) <> " request body is not generated yet; left out") + return (Nothing, [], []) + _ | isModular -> return (Nothing, [], []) + | otherwise -> reqBodyOf picked + where + reqBodyOf picked = do + let (typName,maySchema) = fromMaybe (error "no request body media type") picked case maySchema of Just (Ref (Reference x)) -> - modify (\st -> st { bodyTypes = S.insert (removeUnsupportedSymbols (upperFirstChar x)) (bodyTypes st) }) + modify (\st -> st { bodyTypes = S.insert (refName st x) (bodyTypes st) }) _ -> return () DataTypeInfo {typ,child_types,child_instances} <- mayBeSchemaToHsType ("requestBody",maySchema) True (Just typName) compSchemas let finalType = if typName == JSON @@ -592,6 +757,23 @@ createReqBody compSchemas compReqBodies (Just refReqBody) = do else listPromotedTy [var "Content" @@ listPromotedTy [var $ textToRdrNameStr (T.pack . show $ typName)] @@ typ] return (Just finalType,child_types, child_instances) +-- | The modular layout's choice among an operation's media types: JSON +-- when there is one (a vendor that also offers PDF or an image keeps its +-- JSON contract), else the one it knows; what it drops is a warning. +pickMedia :: MonadState ModelGenState m => Text -> [(MediaType, MediaTypeObject)] -> m (Maybe (ContentTypesOApi, Maybe (Referenced Schema))) +pickMedia ctx mts = do + let known = [ (ct, _mediaTypeObjectSchema o, mt) | (mt, o) <- mts, Just ct <- [HM.lookup mt mediaTypeMap] ] + isJsonish mt = TQ.isSuffixOf "json" (T.pack (show mt)) + jsonish = [ (JSON, _mediaTypeObjectSchema o, mt) | (mt, o) <- mts, isJsonish mt ] + chosen = case [ k | k@(JSON, _, _) <- known ] ++ jsonish ++ known of + (c : _) -> Just c + [] -> Nothing + dropped = [ T.pack (show mt) | (mt, _) <- mts, Just mt /= fmap (\(_, _, m) -> m) chosen ] + unless (Prelude.null dropped) $ + warn (ctx <> ": media types " <> TQ.intercalate ", " dropped <> " left out" + <> maybe " (no media type it knows; left out)" (\(_, _, m) -> "; kept " <> T.pack (show m)) chosen) + pure ((\(c, sch, _) -> (c, sch)) <$> chosen) + mediaTypeObjToSchema :: [(MediaType, MediaTypeObject)] -> (ContentTypesOApi, Maybe (Referenced Schema)) mediaTypeObjToSchema [(mediaTyp,mediaTypObj)] = case HM.lookup mediaTyp mediaTypeMap of @@ -631,11 +813,11 @@ createTypSynonym appName compSchemas(oName,params) = do let rpathE = case typInfo of [x] -> x _ -> foldr1 (`op` ":/") typInfo - return ((varName, [oName]), ChildType ( + return ((varName, [oName]), synCT varName ( type' (textToOccNameStr varName) [] (op (var (textToRdrNameStr appName)) "://" rpathE)) - : ChildType (type' (textToOccNameStr (T.append varName "Path")) [] rpathE) + : synCT (T.append varName "Path") (type' (textToOccNameStr (T.append varName "Path")) [] rpathE) : Prelude.concat childTypes) parseTypeSynInfo :: @@ -805,13 +987,13 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route , "import qualified Data.UUID.Types as UUID" , "import GHC.Stack (HasCallStack)" , "" - , "import WebApi.Contract" + , "import WebApi.Contract hiding (OperationId)" , "import WebApi.Client.Session (AppIsElem, getSuccessOut)" , "" , "import Data.Vector (Vector)" , "" , "import Dhall.Do.Api.Bridge" - , "import Dhall.Do.Api.Id (DLActionId, FQN (..), mkDLActionId)" + , "import Dhall.Do.Api.Id (OperationId, FQN (..), mkOperationId)" , "import Dhall.Do.Api.WebApi.Concrete.Binding" , "" , "import " <> T.pack modName @@ -823,8 +1005,8 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route , "_unusedVectorAnchor :: Maybe (Vector ()) " , "_unusedVectorAnchor = Nothing" , "" - , "opIdOf :: HasCallStack => Text -> DLActionId" - , "opIdOf t = mkDLActionId (fromMaybe (error (\"bad uuid literal: \" <> T.unpack t)) (UUID.fromText t))" + , "opIdOf :: HasCallStack => Text -> OperationId" + , "opIdOf t = mkOperationId (fromMaybe (error (\"bad uuid literal: \" <> T.unpack t)) (UUID.fromText t))" , "" , "mkFqn :: Text -> FQN" , "mkFqn n = FQN { qualifier = \"" <> nsQualifier <> "\" :| [], name = n }" @@ -845,6 +1027,12 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route , enumTypes modelSt, enumTypes synSt ] requestSide = SetQ.union (paramRecords synSt) (bodyTypes synSt) + -- every named ApiErr type; () and Text carry ErrorText already + errorTypes = S.fromList + [ t | (_, methodInfos) <- routeInfo + , (_, (_h,_q,_c,_b,_o,Just errT,_ho,_om)) <- methodInfos + , let t = renderHsType errT + , t `Prelude.notElem` ["()", "Text"] ] resultSide = resultTypes synSt -- OverrideType/HsSelect have no generic sum story (Override.hs / -- Select.hs carry no :+: instance) — suppress their emission for @@ -862,6 +1050,9 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route ] <> [ "instance OverrideType " <> n | n `S.member` requestSide, not (n `S.member` sumLike) ] <> [ "instance HsSelect " <> n | n `S.member` resultSide, not (n `S.member` sumLike) ] + -- a run's failure line renders the error body (dhall-do-api's + -- ErrorText; the class default goes through ToJSON) + <> [ "instance ErrorText " <> n | n `S.member` errorTypes ] <> [ "" ] ops = [ (synName, methName, outT, om) @@ -871,25 +1062,41 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route ] registrationLines = - [ " " <> (if i == 0 then " " else ". ") - <> "addConcreteOp (opIdOf \"" <> opUuid synName methName om <> "\") (mkFqn \"" <> finalOpName synName methName om <> "\") (ConcreteOp ((concreteBinding (Right . getSuccessOut)) { cbSummary = Just \"" <> escape (fromMaybe (finalOpName synName methName om) (omSummary om)) <> "\"" <> defaultsField om <> " } :: ConcreteBinding apps " <> methName <> " " <> appName <> " " <> synName <> "Path (" <> TQ.replace "\n" " " outT <> ")))" - | (i, (synName, methName, outT, om)) <- zip [0 :: Int ..] ops + [ " " <> (if i == 0 then " " else ". ") <> registrationExpr appName op' + | (i, op') <- zip [0 :: Int ..] ops ] - -- curated defaults ride in on the binding's typed request (design D1): - -- one setter per part over emptyRequest, one setField per curated - -- field over unsetRecord — every name GHC-checked against the record - defaultsField om = case omDefaults om of - Nothing -> "" - Just parts -> - ", cbRequest = " - <> foldr - (\(part, flds) inner -> - partSetter part <> " (" - <> TQ.concat [ "setField @\"" <> fld <> "\" (Const (" <> expr <> ")) " | (fld, expr) <- HMQ.toList flds ] - <> "unsetRecord) (" <> inner <> ")") - "emptyRequest" - (HMQ.toList parts) + +-- | One operation's registration: its id (curated, or the sha of its final +-- name), FQN, summary and curated request defaults, ascribed its binding +-- type. Shared by the legacy and modular registries. +registrationExpr :: Text -> (Text, Text, Text, OpMeta) -> Text +registrationExpr appName (synName, methName, outT, om) = + registrationExprWith appName "Right . getSuccessOut" outT "" (synName, methName, om) + +-- | A registration with its own result reader and result type (the +-- modular layout unwraps a response envelope) and further binding fields +-- (its classes), each rendered @, cbField = …@. +registrationExprWith :: Text -> Text -> Text -> Text -> (Text, Text, OpMeta) -> Text +registrationExprWith appName reader resultT extraFields (synName, methName, om) = + "addConcreteOp (opIdOf \"" <> registryOpUuid appName synName methName om <> "\") (mkFqn \"" <> finalOpName synName methName om <> "\") (ConcreteOp ((concreteBinding (" <> reader <> ")) { cbSummary = Just \"" <> registryEscape (fromMaybe (finalOpName synName methName om) (omSummary om)) <> "\"" <> registryDefaultsField om <> extraFields <> " } :: ConcreteBinding apps " <> methName <> " " <> appName <> " " <> synName <> "Path (" <> TQ.replace "\n" " " resultT <> ")))" + +-- curated defaults ride in on the binding's typed request (design D1): +-- one setter per part over emptyRequest, one setField per curated +-- field over unsetRecord — every name GHC-checked against the record +registryDefaultsField :: OpMeta -> Text +registryDefaultsField om = case omDefaults om of + Nothing -> "" + Just parts -> + ", cbRequest = " + <> foldr + (\(part, flds) inner -> + partSetter part <> " (" + <> TQ.concat [ "setField @\"" <> fld <> "\" (Const (" <> expr <> ")) " | (fld, expr) <- HMQ.toList flds ] + <> "unsetRecord) (" <> inner <> ")") + "emptyRequest" + (HMQ.toList parts) + where partSetter = \case "query" -> "setQuery" "form" -> "setForm" @@ -899,19 +1106,27 @@ concreteRegistryText appName modName typeSynName schemaNames modelSt synSt route "file" -> "setFile" other -> error ("naming map: unknown request part " <> T.unpack other) - -- a curated uuid pins the action id (published corpora reference - -- it); otherwise the deterministic sha of the final name - opUuid synName methName om = - fromMaybe (asUuid ("dhall-do-connector|" <> appName <> "|" <> finalOpName synName methName om)) (omUuid om) +-- a curated uuid pins the action id (published corpora reference +-- it); otherwise the deterministic sha of the final name +registryOpUuid :: Text -> Text -> Text -> OpMeta -> Text +registryOpUuid appName synName methName om = + fromMaybe (uuidFromSeed ("dhall-do-connector|" <> appName <> "|" <> finalOpName synName methName om)) (omUuid om) - -- a deterministic 32-hex identity for the seed, laid out as a UUID - asUuid seed = - let hexed = T.pack (concatMap byteHex (BSS.unpack (SHA256.hash (TE.encodeUtf8 seed)))) - h a b = TQ.take b (TQ.drop a hexed) - in TQ.intercalate "-" [h 0 8, h 8 4, h 12 4, h 16 4, h 20 12] - byteHex b = let d k = "0123456789abcdef" !! fromIntegral k in [d (b `div` 16), d (b `mod` 16)] +-- a deterministic 32-hex identity for the seed, laid out as a UUID +uuidFromSeed :: Text -> Text +uuidFromSeed seed = + let hexed = T.pack (concatMap byteHex (BSS.unpack (SHA256.hash (TE.encodeUtf8 seed)))) + h a b = TQ.take b (TQ.drop a hexed) + in TQ.intercalate "-" [h 0 8, h 8 4, h 12 4, h 16 4, h 20 12] + where byteHex b = let d k = "0123456789abcdef" !! fromIntegral k in [d (b `div` 16), d (b `mod` 16)] - escape = TQ.replace "\"" "'" . TQ.replace "\\" "/" +registryEscape :: Text -> Text +registryEscape = TQ.replace "\"" "'" . TQ.replace "\\" "/" + +-- | A declaration as source text (the modular layout writes module +-- headers itself and renders each declaration). +renderDecl :: HsDecl' -> Text +renderDecl d = T.pack (renderWithContext defaultSDocContext (ppr d)) -- Written directly rather than shelled out to @cabal init@: init's -- @--overwrite@ moves an existing src/ aside, clobbering the modules @@ -960,9 +1175,11 @@ ppExtension e = "{-# LANGUAGE " <> show e <> " #-}\n" createModelData :: (MonadState ModelGenState m) => Maybe OpenApiType -> Definitions Schema -> (Text,Schema) -> m ([ChildType],[Instance]) +createModelData (Just OpenApiObject) _ (dName,dSchema) + | HMO.null (_schemaProperties dSchema) = opaqueComponent dName "an object with no properties" createModelData (Just OpenApiObject) compSchemas (dName,dSchema) = do let reqParams = _schemaRequired dSchema - unseenVar <- mkUnseenVar (upperFirstChar dName) + unseenVar <- componentDeclName dName dataTypeInfoList <- mapM (\(x,y) -> parseRecordFields (x,y) (x `elem` reqParams) True (Just JSON) compSchemas) (HMO.toList . _schemaProperties $ dSchema) let (rFields,childTypes,childInsts) = unzip3 $ (\(DataTypeInfo a b c d) -> ((a,b),c,d)) <$> dataTypeInfoList ModelGenState { keywordsToAvoid } <- get @@ -977,56 +1194,104 @@ createModelData (Just OpenApiObject) compSchemas (dName,dSchema) = do tj <- createToJsonInstancesRecord unseenVar dSchema return [fj, tj] return ( Prelude.concat childTypes ++ - [ChildType $ data' (textToOccNameStr unseenVar) [] [recordCon (textToOccNameStr unseenVar) frFields] stdDeriving] + [dataCT unseenVar $ data' (textToOccNameStr unseenVar) [] [recordCon (textToOccNameStr unseenVar) frFields] stdDeriving] , Prelude.concat childInsts ++ ownInsts ) createModelData Nothing compSchemas (dName,dSchema) = case _schemaOneOf dSchema of - Nothing -> error "Unexpected Schema type" - Just [] -> error "Bad OneOf Specification" - Just [_x] -> error "Bad OneOf Specification" - Just x -> do + Just x@(_ : _ : _) -> do DataTypeInfo {child_types, child_instances} <- mkSumType dName True x True True (Just JSON) compSchemas return (child_types, child_instances) + Just [_] -> legacyOr (error "Bad OneOf Specification") (opaqueComponent dName "a oneOf of one") + Just [] -> legacyOr (error "Bad OneOf Specification") (opaqueComponent dName "an empty oneOf") + Nothing + | not (HMO.null (_schemaProperties dSchema)) -> + createModelData (Just OpenApiObject) compSchemas (dName,dSchema) + | otherwise -> legacyOr (error "Unexpected Schema type") (opaqueComponent dName "no type") createModelData (Just OpenApiArray) compSchemas (dName,dSchema) = case _schemaItems dSchema of - Nothing -> error "No _schemaItems value for Array" - Just (OpenApiItemsArray _) -> error "OpenApiItemsArray Array type" Just (OpenApiItemsObject sch) -> do - unseenVar <- mkUnseenVar (upperFirstChar dName) + unseenVar <- componentDeclName dName let occUnseenVar = textToOccNameStr unseenVar DataTypeInfo {typ,child_types,child_instances} <- parseRecordFields (dName,sch) True True (Just JSON) compSchemas let toptype = type' occUnseenVar [] (var "Vector" @@ typ) - return (ChildType toptype:child_types, child_instances) + return (synCT unseenVar toptype:child_types, child_instances) + Nothing -> legacyOr (error "No _schemaItems value for Array") (opaqueArrayComponent dName "an array with no items") + Just (OpenApiItemsArray _) -> legacyOr (error "OpenApiItemsArray Array type") (opaqueArrayComponent dName "a tuple array") createModelData (Just OpenApiString) _ (dName,dSchema) - | Just vals@(_ : _) <- _schemaEnum dSchema = do - ModelGenState { enumsAsSums, enumSums } <- get + | Just vals@(_ : _) <- _schemaEnum dSchema, all isStringValue vals = do + ModelGenState { enumsAsSums, enumSums, modular = isModular } <- get if not enumsAsSums then do - unseenVar <- mkUnseenVar (upperFirstChar dName) - return (mkTopLevelBaseType "Text" (textToOccNameStr unseenVar), []) + unseenVar <- componentDeclName dName + return (mkTopLevelBaseType "Text" unseenVar, []) + else if isModular + then do + -- the enum is interned by value set (shared across modules, so it + -- lands in the common module); the component is a synonym for it + declName <- componentDeclName dName + DataTypeInfo {typ, child_types, child_instances} <- + mkEnumType (T.append declName "E") dName vals True True + return (synCT declName (type' (textToOccNameStr declName) [] typ) : child_types, child_instances) else case HMQ.lookup (enumKey vals) enumSums of -- the set is already a type under another name: alias to it Just existing -> do unseenVar <- mkUnseenVar (upperFirstChar dName) - return (mkTopLevelBaseType existing (textToOccNameStr unseenVar), []) + return (mkTopLevelBaseType existing unseenVar, []) Nothing -> do DataTypeInfo {child_types, child_instances} <- mkEnumType (upperFirstChar dName) dName vals True True return (child_types, child_instances) +createModelData (Just OpenApiNull) _ (dName,_) = + legacyOr (error "Top Level Schema Type: Null") (opaqueComponent dName "the null type") createModelData (Just a) _ (dName,dSchema) = do - unseenVar <- mkUnseenVar (upperFirstChar dName) - let occUnseenVar = textToOccNameStr unseenVar - return (mkTopLevelBaseType (findTopType a) occUnseenVar, []) - where findTopType OpenApiString = "Text" - findTopType OpenApiNumber = "Double" - findTopType OpenApiInteger = parseIntegerFld (_schemaFormat dSchema) - findTopType OpenApiBoolean = "Bool" - findTopType OpenApiNull = error "Top Level Schema Type: Null" + unseenVar <- componentDeclName dName + topType <- findTopType a + return (mkTopLevelBaseType topType unseenVar, []) + where findTopType OpenApiString = pure "Text" + findTopType OpenApiNumber = pure "Double" + findTopType OpenApiInteger = integerType dName (_schemaFormat dSchema) + findTopType OpenApiBoolean = pure "Bool" findTopType _ = error "Top Level Schema : Invalid State" -mkTopLevelBaseType :: Text -> OccNameStr -> [ChildType] -mkTopLevelBaseType x occ = [ChildType $ type' occ [] (var $ textToRdrNameStr x)] +-- | The legacy layout's behaviour, or the modular layout's. +legacyOr :: MonadState ModelGenState m => m a -> m a -> m a +legacyOr legacy modern = do + ModelGenState { modular = isModular } <- get + if isModular then modern else legacy + +-- | A component the generator cannot type: the JSON it carries, kept whole. +opaqueComponent :: MonadState ModelGenState m => Text -> Text -> m ([ChildType],[Instance]) +opaqueComponent dName why = do + n <- componentDeclName dName + warn ("component " <> dName <> ": " <> why <> "; typed as Opaque") + return (mkTopLevelBaseType "Opaque" n, []) + +opaqueArrayComponent :: MonadState ModelGenState m => Text -> Text -> m ([ChildType],[Instance]) +opaqueArrayComponent dName why = do + n <- componentDeclName dName + warn ("component " <> dName <> ": " <> why <> "; typed as Vector Opaque") + return ([synCT n (type' (textToOccNameStr n) [] (var "Vector" @@ var "Opaque"))], []) + +isStringValue :: Value -> Bool +isStringValue = \case + String _ -> True + _ -> False + +-- | An integer format as its Haskell type; an unknown format is Int. +integerType :: MonadState ModelGenState m => Text -> Maybe Text -> m Text +integerType ctx fmt = do + ModelGenState { modular = isModular } <- get + case fmt of + Just x | T.take 3 (upperFirstChar x) == "Int" -> pure (upperFirstChar x) + | isModular -> do + warn (ctx <> ": integer format " <> x <> " is not intN; typed as Int") + pure "Int" + | otherwise -> error "Invalid Integer Format" + Nothing -> pure "Int" + +mkTopLevelBaseType :: Text -> Text -> [ChildType] +mkTopLevelBaseType x n = [synCT n $ type' (textToOccNameStr n) [] (var $ textToRdrNameStr x)] avoidKeywords :: Text -> Set Text -> Text avoidKeywords x keywordsToAvoid = if member x keywordsToAvoid @@ -1047,7 +1312,8 @@ parseRecordFields :: -- inline child DECLS while registering their names, losing the decl for -- good (found by the M10 relocation). So a Ref is only ever a name. parseRecordFields (dName,Ref (Reference x)) isReq _generateInstance _instanceType _compSchemas = do - let sName = removeUnsupportedSymbols . upperFirstChar $ x + st <- get + let sName = refName st x return $ DataTypeInfo dName (createHsType isReq sName) [] [] parseRecordFields (dName,Inline dSchema) isReq generateInstance instanceType compSchemas = parseInlineFields (_schemaType dSchema) dName dSchema isReq generateInstance instanceType compSchemas @@ -1100,7 +1366,7 @@ createFromJsonInstancesRecord dName schemaVal compSchemas = do "$" (lambda [conP_ "v"] fromjsonExpr) )] - return $ Instance fromjsonInst + return $ Instance dName fromjsonInst createFromJsonFieldExpr :: (MonadState ModelGenState m) => @@ -1110,11 +1376,12 @@ createFromJsonFieldExpr :: [(Text,Referenced Schema)] -> m HsExpr' createFromJsonFieldExpr compSchemas dName reqParams schemaProps = do - ModelGenState {keywordsToAvoid} <- get + ModelGenState {keywordsToAvoid, modular = isModular} <- get let _unused = keywordsToAvoid -- the JSON key is the wire name, verbatim; sanitizing is only - -- for the Haskell field/constructor side - fieldExpr (x,y) = if _schemaType (refValToVal compSchemas y) == Just OpenApiArray && notElem x reqParams + -- for the Haskell field/constructor side. Legacy reads an absent + -- array as empty; modular reads every optional field as Maybe. + fieldExpr (x,y) = if not isModular && _schemaType (refValToVal compSchemas y) == Just OpenApiArray && notElem x reqParams then op (op (var "v") (findSeparatorSymbol False) (string . T.unpack $ x)) @@ -1136,7 +1403,11 @@ createToJsonInstancesRecord :: Schema -> m Instance createToJsonInstancesRecord schemaName schemaVal = do - ModelGenState {keywordsToAvoid} <- get + ModelGenState {keywordsToAvoid, modular = isModular} <- get + pure (if isModular then modularToJson schemaName schemaVal else legacyToJson keywordsToAvoid schemaName schemaVal) + +legacyToJson :: Set Text -> Text -> Schema -> Instance +legacyToJson keywordsToAvoid schemaName schemaVal = let schemaProperties = HMO.toList . _schemaProperties $ schemaVal -- pattern variables are the sanitized field names; the JSON key -- stays the wire name @@ -1144,9 +1415,26 @@ createToJsonInstancesRecord schemaName schemaVal = do wireFields = fst <$> schemaProperties rFieldList = bvar . textToOccNameStr . sanitize <$> wireFields associationList = list $ (\x -> op (string . T.unpack $ x) ".=" (var . textToRdrNameStr . sanitize $ x)) <$> wireFields - let toJsonInst = instance' (var "ToJSON" @@ var (textToRdrNameStr schemaName)) + toJsonInst = instance' (var "ToJSON" @@ var (textToRdrNameStr schemaName)) [funBind "toJSON" (match [conP (textToRdrNameStr schemaName) rFieldList] (var "object" @@ associationList) ) ] - return $ Instance toJsonInst + in Instance schemaName toJsonInst + +-- | The modular layout's ToJSON: an absent optional field is left out of +-- the object (not sent as null), so an update touches only what it names; +-- pattern variables are positional, so a field called @object@ cannot +-- shadow the function that builds the object. +modularToJson :: Text -> Schema -> Instance +modularToJson schemaName schemaVal = + Instance schemaName $ + instance' (var "ToJSON" @@ var (textToRdrNameStr schemaName)) + [funBind "toJSON" (match [conP (textToRdrNameStr schemaName) (bvar . fromString . fst <$> vars)] + (var "object" @@ (var "catMaybes" @@ list (pair <$> vars))))] + where props = fst <$> HMO.toList (_schemaProperties schemaVal) + reqs = _schemaRequired schemaVal + vars = [ ("v" <> show i, p) | (i, p) <- zip [1 :: Int ..] props ] + pair (v, p) + | p `elem` reqs = var "Just" @@ op (string (T.unpack p)) ".=" (var (fromString v)) + | otherwise = var "fmap" @@ lambda [bvar "x"] (op (string (T.unpack p)) ".=" (var "x")) @@ var (fromString v) createHsType :: Bool -> Text -> HsType' createHsType isReq x = @@ -1170,25 +1458,36 @@ parseInlineFields (Just OpenApiString) dName dSchema isReq generateInstance inst case _schemaEnum dSchema of -- sums only in JSON contexts: param records keep Text (their -- Encode/DecodeParam story is a documented cut line) - Just vals@(_ : _) | enumsAsSums && instanceType == Just JSON -> + Just vals@(_ : _) | enumsAsSums && instanceType == Just JSON && all isStringValue vals -> mkEnumType (T.append (upperFirstChar dName) "E") dName vals isReq generateInstance _ -> return $ DataTypeInfo dName (createHsType isReq "Text") [] [] parseInlineFields (Just OpenApiNumber ) dName _dSchema isReq _ _ _= return $ DataTypeInfo dName (createHsType isReq "Double") [] [] -parseInlineFields (Just OpenApiInteger) dName dSchema isReq _ _ _= +parseInlineFields (Just OpenApiInteger) dName dSchema isReq _ _ _= do + parsedInt <- integerType dName (_schemaFormat dSchema) return $ DataTypeInfo dName (createHsType isReq parsedInt) [] [] - where parsedInt = parseIntegerFld (_schemaFormat dSchema) parseInlineFields (Just OpenApiBoolean) dName _dSchema isReq _ _ _= return $ DataTypeInfo dName (createHsType isReq "Bool") [] [] -parseInlineFields (Just OpenApiArray ) dName dSchema _isReq generateInstance instanceType compSchemas= +parseInlineFields (Just OpenApiArray ) dName dSchema isReq generateInstance instanceType compSchemas = do + ModelGenState { modular = isModular } <- get + -- legacy: an array is never Maybe (absent reads as empty); modular: an + -- optional array is Maybe, so an update can leave a list alone rather + -- than send [] and clear it + let wrap t = if isModular && not isReq then var "Maybe" @@ t else t case _schemaItems dSchema of - Nothing -> error "No _schemaItems value for Array" Just (OpenApiItemsObject sch) -> do DataTypeInfo {..} <- parseRecordFields (dName,sch) True generateInstance instanceType compSchemas - return $ DataTypeInfo pName (var "Vector" @@ typ) child_types child_instances - Just (OpenApiItemsArray _) -> error "OpenApiItemsArray Array type" -parseInlineFields (Just OpenApiNull ) _dName _dSchema _isReq _ _ _= - error "Null OpenApi Type" + return $ DataTypeInfo pName (wrap (var "Vector" @@ typ)) child_types child_instances + Nothing -> legacyOr (error "No _schemaItems value for Array") (opaqueField wrap "an array with no items") + Just (OpenApiItemsArray _) -> legacyOr (error "OpenApiItemsArray Array type") (opaqueField wrap "a tuple array") + where opaqueField wrap why = do + warn (dName <> ": " <> why <> "; typed as Vector Opaque") + return $ DataTypeInfo dName (wrap (var "Vector" @@ var "Opaque")) [] [] +parseInlineFields (Just OpenApiNull ) dName _dSchema isReq _ _ _= + legacyOr (error "Null OpenApi Type") $ do + warn (dName <> ": the null type; typed as Opaque") + return $ DataTypeInfo dName (createHsType isReq "Opaque") [] [] + -- An inline object becomes a named record rather than an anonymous -- @Rec@: the Dhall bridge's generic walks (and webapi's param codecs) -- work over nominal 'Generic' records. The name is a pure function of @@ -1196,46 +1495,55 @@ parseInlineFields (Just OpenApiNull ) _dName _dSchema _isReq _ _ _= -- agree on it without sharing state, and NetSuite's ubiquitous -- @{id, refName}@ reference idiom collapses to one shared type. parseInlineFields (Just OpenApiObject ) dName dSchema isReq generateInstance instanceType compSchemas = do - dataTypeInfoList <- mapM (\(x,y) -> parseRecordFields (x,y) (x `elem` reqParams) generateInstance instanceType compSchemas) (HMO.toList . _schemaProperties $ dSchema) - let (childInlines,childTypes,childInstances) = unzip3 $ (\(DataTypeInfo a b c d) -> ((a,b),c,d)) <$> dataTypeInfoList - baseName = T.append "NsObj" (T.concat (upperFirstChar . removeUnsupportedSymbols . fst <$> childInlines)) - -- the SHAPE, not just the field names: two {refName,id} objects - -- whose id fields carry different enums are different types — - -- the old names-only key silently aliased them (first won) - shape = [ (fn, renderHsType ft) | (fn, ft) <- childInlines ] - -- seenVars BEFORE interning: a freshly minted variant name is put - -- into seenVars by mkUnseenVar itself, and must still get its decl - ModelGenState { seenVars = seenBefore } <- get - (vName, isNewName) <- internInlineShape baseName shape - let objType = var (textToRdrNameStr vName) - ModelGenState { keywordsToAvoid } <- get - let mkFld (x,y) = (textToOccNameStr (avoidKeywords (removeUnsupportedSymbols (lowerFirstChar x)) keywordsToAvoid), field y) - objDecl = ChildType $ data' (textToOccNameStr vName) [] [recordCon (textToOccNameStr vName) (mkFld <$> childInlines)] stdDeriving - newDecls = if isNewName && not (member vName seenBefore) then [objDecl] else [] - modify (updateSeenVars vName) - modify (\st -> st { inlineRecords = S.insert vName (inlineRecords st) }) - jsonInsts <- if generateInstance - then do - ModelGenState { jsonInstances } <- get - if member vName jsonInstances - then return [] - else do - modify (updateJsonInstances vName) - fj <- createFromJsonInstancesRecord vName dSchema compSchemas - tj <- createToJsonInstancesRecord vName dSchema - return [fj, tj] - else return [] - return $ DataTypeInfo dName - (if isReq then objType else var "Maybe" @@ objType) - (Prelude.concat childTypes ++ newDecls) - (Prelude.concat childInstances ++ jsonInsts) - where reqParams = _schemaRequired dSchema + ModelGenState { modular = isModular } <- get + if isModular && HMO.null (_schemaProperties dSchema) + then do + warn (dName <> ": an object with no properties; typed as Opaque") + return $ DataTypeInfo dName (createHsType isReq "Opaque") [] [] + else do + dataTypeInfoList <- mapM (\(x,y) -> parseRecordFields (x,y) (x `elem` reqParams) generateInstance instanceType compSchemas) (HMO.toList . _schemaProperties $ dSchema) + let (childInlines,childTypes,childInstances) = unzip3 $ (\(DataTypeInfo a b c d) -> ((a,b),c,d)) <$> dataTypeInfoList + ModelGenState { inlinePrefix = objPrefix } <- get + let baseName = T.append objPrefix (T.concat (upperFirstChar . removeUnsupportedSymbols . fst <$> childInlines)) + -- the SHAPE, not just the field names: two {refName,id} objects + -- whose id fields carry different enums are different types — + -- the old names-only key silently aliased them (first won) + shape = [ (fn, renderHsType ft) | (fn, ft) <- childInlines ] + -- seenVars BEFORE interning: a freshly minted variant name is put + -- into seenVars by mkUnseenVar itself, and must still get its decl + ModelGenState { seenVars = seenBefore } <- get + (vName, isNewName) <- internInlineShape baseName shape + let objType = var (textToRdrNameStr vName) + ModelGenState { keywordsToAvoid } <- get + let mkFld (x,y) = (textToOccNameStr (avoidKeywords (removeUnsupportedSymbols (lowerFirstChar x)) keywordsToAvoid), field y) + objDecl = dataCT vName $ data' (textToOccNameStr vName) [] [recordCon (textToOccNameStr vName) (mkFld <$> childInlines)] stdDeriving + newDecls = if isNewName && not (member vName seenBefore) then [objDecl] else [] + modify (updateSeenVars vName) + modify (\st -> st { inlineRecords = S.insert vName (inlineRecords st) }) + jsonInsts <- if generateInstance + then do + ModelGenState { jsonInstances } <- get + if member vName jsonInstances + then return [] + else do + modify (updateJsonInstances vName) + fj <- createFromJsonInstancesRecord vName dSchema compSchemas + tj <- createToJsonInstancesRecord vName dSchema + return [fj, tj] + else return [] + return $ DataTypeInfo dName + (if isReq then objType else var "Maybe" @@ objType) + (Prelude.concat childTypes ++ newDecls) + (Prelude.concat childInstances ++ jsonInsts) + where reqParams = _schemaRequired dSchema parseInlineFields Nothing dName dSchema isReq generateInstance instanceType compSchemas= case _schemaOneOf dSchema of Nothing -> if Prelude.null (_schemaProperties dSchema) - then error "Unexpected Schema type" + then legacyOr (error "Unexpected Schema type") $ do + warn (dName <> ": no type; typed as Opaque") + return $ DataTypeInfo dName (createHsType isReq "Opaque") [] [] else parseInlineFields (Just OpenApiObject) dName dSchema isReq generateInstance instanceType compSchemas Just x -> mkSumType dName isReq x False generateInstance instanceType compSchemas @@ -1244,8 +1552,11 @@ parseInlineFields Nothing dName dSchema isReq generateInstance instanceType comp internInlineShape :: (MonadState ModelGenState m) => Text -> [(Text, Text)] -> m (Text, Bool) internInlineShape baseName shape = do - ModelGenState { inlineShapes = shapeTbl } <- get - let entries = fromMaybe [] (HMQ.lookup baseName shapeTbl) + ModelGenState { inlineShapes = shapeTbl, modular = isModular, curModule = m } <- get + -- modular: a shape is shared within its module only, so no module + -- depends on a sibling for an inline record + let key = if isModular then T.concat [m, "/", baseName] else baseName + entries = fromMaybe [] (HMQ.lookup key shapeTbl) case Prelude.lookup shape entries of Just name -> return (name, False) Nothing -> do @@ -1253,7 +1564,7 @@ internInlineShape baseName shape = do then return baseName else mkUnseenVar (T.append baseName "V") modify (\st -> st { inlineShapes = - HMQ.insertWith (++) baseName [(shape, name)] (inlineShapes st) }) + HMQ.insertWith (++) key [(shape, name)] (inlineShapes st) }) return (name, True) mkSumType :: @@ -1282,17 +1593,12 @@ mkSumType dName isReq x isTopLevel generateInstance instanceType compSchemas = d if isReg then return $ DataTypeInfo dName (createHsType isReq vName) [] encodeDecodeInstances else do - let oneOfTyp = ChildType $ data' (textToOccNameStr vName) [] ((\(a,b) -> prefixCon (textToOccNameStr a) [field b]) <$> typList) stdDeriving + let oneOfTyp = dataCT vName $ data' (textToOccNameStr vName) [] ((\(a,b) -> prefixCon (textToOccNameStr a) [field b]) <$> typList) stdDeriving return $ DataTypeInfo dName (createHsType isReq vName) (oneOfTyp : Prelude.concat childTypes) encodeDecodeInstances -f :: Monad m => Text -> [HsDecl'] -> m () -f a xs = do - traceM $ "Trace Message : " ++ show a - mapM_ (\(!_x) -> pure ()) xs - createInstancesSumType :: MonadState ModelGenState m => Maybe ContentTypesOApi -> @@ -1305,7 +1611,6 @@ createInstancesSumType (Just JSON) tName consList = do then return [] else do modify (updateJsonInstances tName) - when (tName == "ItemSumType") $ trace "ItemType" (return ()) let fromJsonInst = createFromJsonInstanceSumType tName consList toJsonInst = createToJsonInstanceSumType tName consList return [fromJsonInst,toJsonInst] @@ -1315,7 +1620,7 @@ createFromJsonInstanceSumType :: Text -> [Text] -> Instance -createFromJsonInstanceSumType tName consList = Instance $ +createFromJsonInstanceSumType tName consList = Instance tName $ instance' (var "FromJSON" @@ var (textToRdrNameStr tName)) [funBind "parseJSON" $ match [bvar "v"] fieldInfo] where fieldInfo = foldl1 (`op` "<|>") $ (\x -> op (var (textToRdrNameStr x)) "<$>" (var "parseJSON" @@ var "v")) <$> consList @@ -1325,7 +1630,7 @@ createToJsonInstanceSumType :: Text -> [Text] -> Instance -createToJsonInstanceSumType tName consList = Instance $ +createToJsonInstanceSumType tName consList = Instance tName $ instance' (var "ToJSON" @@ var (textToRdrNameStr tName)) [funBinds "toJSON" matchList] where matchList = (`match` (var "toJSON" @@ var "x")) . (\x -> [conP x [bvar "x"]]) . textToRdrNameStr <$> consList @@ -1394,7 +1699,7 @@ mkEnumType nameHint dName vals isReq generateInstance = do tyName <- mkUnseenVar nameHint modify (\st -> st { enumSums = HMQ.insert key tyName (enumSums st) , enumTypes = S.insert tyName (enumTypes st) }) - let decl = ChildType (data' (textToOccNameStr tyName) [] + let decl = dataCT tyName (data' (textToOccNameStr tyName) [] [ prefixCon (textToOccNameStr c) [] | (c, _) <- enumCtors tyName key ] stdDeriving) insts <- emitEnumInstancesOnce tyName key generateInstance @@ -1427,11 +1732,11 @@ emitEnumInstancesOnce tyName key generateInstance = do else do modify (updateJsonInstances tyName) let pairs = enumCtors tyName key - toJ = Instance (instance' (var "ToJSON" @@ var (textToRdrNameStr tyName)) + toJ = Instance tyName (instance' (var "ToJSON" @@ var (textToRdrNameStr tyName)) [funBinds "toJSON" [ match [conP (textToRdrNameStr c) []] (var "String" @@ string (T.unpack w)) | (c, w) <- pairs ]]) - fromJ = Instance (instance' (var "FromJSON" @@ var (textToRdrNameStr tyName)) + fromJ = Instance tyName (instance' (var "FromJSON" @@ var (textToRdrNameStr tyName)) [valBind "parseJSON" (op (var "withText" @@ string (T.unpack tyName)) "$" (lambda [conP_ "t"] diff --git a/webapi-openapi/src/WebApi/OpenAPI/Modular.hs b/webapi-openapi/src/WebApi/OpenAPI/Modular.hs new file mode 100644 index 0000000..598de5f --- /dev/null +++ b/webapi-openapi/src/WebApi/OpenAPI/Modular.hs @@ -0,0 +1,857 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The modular layout: one cabal package per API, split into +-- sublibraries by who consumes them. +-- +-- The input is one OpenAPI document whose top-level @x-zb@ object says +-- which module each component schema and path belongs to (zenbridge +-- connectors' @tools/zbc normalize@ writes it). For a module prefix @P@ and +-- modules @M@: +-- +-- > library model- P.Model. the types, JSON instances +-- > library P.App the app type +-- > P.Routes. route synonyms +-- > P.Contract instance WebApi (the Apis list) +-- > P.Contract. param records, ApiContract instances +-- > library registry P.Registry.Instances. dhall-do bridge instances for the models +-- > P.Registry.Ops. the module's operations +-- > P.Registry the whole registry: +-- +-- @WebApi@ is a superclass of @ApiContract@, so the @Apis@ list (which +-- names every route) and the contract instances (which need the WebApi +-- instance) live in different modules: routes, then the list, then the +-- instances. +module WebApi.OpenAPI.Modular + ( GenConfig (..) + , generateModular + ) where + +import Control.Exception (SomeException, catch) +import Control.Monad (forM, forM_, guard, unless, when) +import Control.Monad.State.Class (modify) +import Control.Monad.State.Lazy (runState) +import Data.Aeson (FromJSON (..), Value (..), eitherDecode, encode, object, withObject, (.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict.InsOrd as HMO +import Data.List (nub, sort, sortOn) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.OpenApi + ( AdditionalProperties (..) + , Components (..) + , OpenApi (..) + , OpenApiItems (..) + , Reference (..) + , Referenced (..) + , Schema (..) + ) +import qualified Data.Set as S +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import GHC.SourceGen (instance', listPromotedTy, tyFamInst, var, (@@)) +import Ormolu (Config (cfgCheckIdempotence), defaultConfig, ormolu) +import System.Directory (createDirectoryIfMissing, removePathForcibly) +import System.FilePath (takeDirectory, ()) +import System.IO (hPutStrLn, stderr) +import WebApi.OpenAPI + +-- | What the modular layout needs to know about the package it writes. +data GenConfig = GenConfig + { gcInput :: FilePath -- ^ the normalized OpenAPI document (JSON) + , gcOutDir :: FilePath -- ^ the package root: the .cabal file and gen/ + , gcPackage :: Text + , gcVersion :: Text + , gcSynopsis :: Text + , gcApp :: Text -- ^ the webapi app type + , gcQualifier :: Text -- ^ every operation's FQN qualifier + , gcModulePrefix :: Text -- ^ e.g. Zenbridge.Connector.ZohoBooks + , gcOpsName :: Text -- ^ the registry's exported composition + , gcSumEnums :: Bool + , gcNamingMap :: Maybe FilePath + , gcPathPrefix :: Text + , gcFormat :: Bool -- ^ run the formatter over every module + , gcGhcOptions :: [Text] -- ^ for every generated component + , gcCabalExtra :: Text -- ^ the package's hand-written stanzas, appended verbatim + , gcConnectionParams :: [Text] -- ^ query parameters the connection sets, not the operation + , gcEnvelope :: [Text] -- ^ a response's envelope fields (Zoho's code, message): a + -- response of one resource beside them binds as the resource + , gcClasses :: [(Text, ClassSpec)] -- ^ the identity classes, reviewed (bindings/classes.yaml) + } + +-- | One identity class: its Haskell type, the result fields that record a +-- value of it (by operation name), and the request fields that take one +-- (@path@ for a lone path capture, @part.field@ otherwise). A class nothing +-- records is external: only a plan input supplies it. +data ClassSpec = ClassSpec + { csType :: Text + , csRecords :: [(Text, Text)] + , csWants :: [(Text, [Text])] + , csExternal :: Bool + } + +instance FromJSON ClassSpec where + parseJSON = withObject "ClassSpec" $ \o -> do + csType <- o .:? "type" .!= "Text" + csRecords <- HM.toList <$> o .:? "records" .!= HM.empty + csWants <- HM.toList <$> o .:? "wants" .!= HM.empty + csExternal <- o .:? "external" .!= False + pure ClassSpec {..} + +instance FromJSON GenConfig where + parseJSON = withObject "GenConfig" $ \o -> do + gcInput <- o .: "input" + gcOutDir <- o .: "outDir" + gcPackage <- o .: "package" + gcVersion <- o .:? "version" .!= "0.1.0.0" + gcSynopsis <- o .:? "synopsis" .!= "Generated webapi contract and dhall-do registry" + gcApp <- o .: "app" + gcQualifier <- o .: "qualifier" + gcModulePrefix <- o .: "modulePrefix" + gcOpsName <- o .:? "opsName" .!= (gcQualifier <> "Ops") + gcSumEnums <- (== ("sum" :: Text)) <$> o .:? "enumMode" .!= "text" + gcNamingMap <- o .:? "namingMap" + gcPathPrefix <- o .:? "pathPrefix" .!= "/" + gcFormat <- o .:? "format" .!= True + gcGhcOptions <- o .:? "ghcOptions" .!= ["-O0"] + gcCabalExtra <- o .:? "cabalExtra" .!= "" + gcConnectionParams <- o .:? "connectionParams" .!= [] + gcEnvelope <- o .:? "envelope" .!= [] + gcClasses <- HM.toList <$> o .:? "classes" .!= HM.empty + pure GenConfig {..} + +-- | The @x-zb@ object: modules, and the module of every component schema +-- and path. A document without one is one module, @api@. +data XZb = XZb + { xModules :: [Text] + , xSchema :: HM.HashMap Text Text + , xPath :: HM.HashMap Text Text + } + +commonM :: Text +commonM = "common" + +readXZb :: Value -> XZb +readXZb = \case + Object o | Just (Object x) <- KM.lookup "x-zb" o -> + let strs = \case + Array a -> [t | String t <- foldr (:) [] a] + _ -> [] + textMap = \case + Object m -> HM.fromList [(K.toText k, t) | (k, String t) <- KM.toList m] + _ -> HM.empty + comps = case KM.lookup "components" x of + Just (Object c) -> maybe HM.empty textMap (KM.lookup "schemas" c) + _ -> HM.empty + in XZb (maybe [] strs (KM.lookup "modules" x)) comps (maybe HM.empty textMap (KM.lookup "paths" x)) + _ -> XZb [commonM, "api"] HM.empty HM.empty + +-- | Names no generated type may take: what the generated modules import, +-- and webapi's and dhall-do's vocabulary. +reservedTypeNames :: [Text] +reservedTypeNames = + [ "Bool", "Char", "Double", "Either", "Float", "IO", "Int", "Integer", "Maybe", "Ordering", "String", "Word", "Rational" + , "True", "False", "Just", "Nothing", "Left", "Right", "LT", "EQ", "GT" + , "Eq", "Ord", "Show", "Read", "Enum", "Bounded", "Num", "Real", "Integral", "Fractional", "Floating", "RealFrac", "RealFloat" + , "Functor", "Applicative", "Monad", "MonadFail", "Foldable", "Traversable", "Semigroup", "Monoid" + , "Int8", "Int16", "Int32", "Int64", "Word8", "Word16", "Word32", "Word64", "Natural" + , "Text", "Vector", "Value", "Generic", "Opaque", "Object", "Array", "Key", "Parser", "Result", "Series", "Encoding" + , "FromJSON", "ToJSON", "Proxy", "Type", "Symbol", "Void", "Map", "Set", "UUID", "UTCTime", "ByteString", "Day", "Scientific" + , "WebApi", "ApiContract", "Route", "Request", "Response", "Content", "JSON", "PlainText", "HTML", "OctetStream" + , "MultipartFormData", "UrlEncoded", "Static", "OpId", "ApiError", "OtherError", "Resource", "Cookie", "Param" + , "GET", "POST", "PUT", "DELETE", "PATCH", "HEAD", "OPTIONS", "TRACE", "CONNECT" + , "QueryParam", "FormParam", "FileParam", "PathParam", "HeaderIn", "HeaderOut", "CookieIn", "CookieOut" + , "ApiOut", "ApiErr", "RequestBody", "ContentTypes", "OperationId", "Apis", "Version" + , "ToParam", "FromParam", "ToHeader", "FromHeader", "EncodeParam", "DecodeParam", "ParamK" + , "HsType", "ToHsVal", "FromHsVal", "OverrideType", "HsSelect", "ErrorText", "TextIso", "ViaText" + , "ConcreteActions", "ConcreteBinding", "ConcreteOp", "FQN", "Untyped" + ] + +-- | Every component schema's Haskell name, resolved once: its PascalCase +-- name, else the name under its module's, else a numbered one. +resolveNames :: [Text] -> [(Text, Text)] -> HM.HashMap Text Text +resolveNames reserved = go (S.fromList reserved) HM.empty + where + go _ acc [] = acc + go taken acc ((c, m) : rest) = + let base = pascalName c + cands = [base, pascalName m <> base] ++ [base <> T.pack (show i) | i <- [2 :: Int ..]] + n = head (filter (`S.notMember` taken) cands) + in go (S.insert n taken) (HM.insert c n acc) rest + +-- | The components a schema names, without following them. +schemaRefs :: Referenced Schema -> [Text] +schemaRefs = \case + Ref (Reference r) -> [r] + Inline s -> + concatMap schemaRefs (HMO.elems (_schemaProperties s)) + ++ items (_schemaItems s) + ++ concatMap schemaRefs (concat (mapMaybe id [_schemaOneOf s, _schemaAllOf s, _schemaAnyOf s])) + ++ maybe [] schemaRefs (_schemaNot s) + ++ case _schemaAdditionalProperties s of + Just (AdditionalPropertiesSchema r) -> schemaRefs r + _ -> [] + where + items = \case + Just (OpenApiItemsObject r) -> schemaRefs r + Just (OpenApiItemsArray rs) -> concatMap schemaRefs rs + Nothing -> [] + +-- | Where a generated declaration lives. +data Home = HModel Text | HRoutes Text | HContract Text + deriving (Eq, Ord, Show) + +generateModular :: GenConfig -> IO () +generateModular cfg@GenConfig {..} = do + raw <- either (fail . ((gcInput <> ": ") <>)) pure . eitherDecode =<< BL.readFile gcInput + oApi <- readOpenAPI gcInput + namingMap <- maybe (pure HM.empty) (\fp -> either (fail . ((fp <> ": ") <>)) pure . eitherDecode =<< BL.readFile fp) gcNamingMap + let xzb = readXZb raw + comps = _openApiComponents oApi + compSchemas = _componentsSchemas comps + schemaList = HMO.toList compSchemas + modOfComp c = HM.lookupDefault (if HM.null (xSchema xzb) then "api" else commonM) c (xSchema xzb) + modOfPath p = HM.lookupDefault (if HM.null (xPath xzb) then "api" else commonM) p (xPath xzb) + reserved = gcApp : reservedTypeNames + names = resolveNames reserved [(c, modOfComp c) | (c, _) <- schemaList] + st0 = (initState gcSumEnums reserved) + { modular = True + , compNames = names + , inlinePrefix = "Obj" + , seenVars = S.fromList (reserved ++ HM.elems names) + , connectionParams = S.fromList gcConnectionParams + } + + -- the models pass: every component, in its module + (modelOuts, st1) = flip runState st0 $ forM schemaList $ \(c, sch) -> do + let m = modOfComp c + modify (\st -> st {curModule = m}) + (cts, insts) <- createModelData (_schemaType sch) compSchemas (c, sch) + pure (m, cts, insts) + + -- the contract pass: every path, in its module + paths = [ (p, item) | (p, item) <- HMO.toList (_openApiPaths oApi), gcPathPrefix `T.isPrefixOf` T.pack p ] + (pathOuts, st2) = flip runState st1 $ forM paths $ \(p, item) -> do + let m = modOfPath (T.pack p) + modify (\st -> st {curModule = m}) + (ri, rcts, ccts, insts) <- + createTypeSynData namingMap gcApp compSchemas (_componentsParameters comps) + (_componentsRequestBodies comps) (_componentsResponses comps) (_componentsHeaders comps) (p, item) + pure (m, ri, rcts, ccts, insts) + + -- op names are identities (the FQN and the type-level OperationId) + let finalOps = [ (omKey om, finalOpName synName methName om) + | (_, ri, _, _, _) <- pathOuts, (synName, ms) <- ri, (methName, (_,_,_,_,_,_,_,om)) <- ms ] + dups = [ (n, ks) | (n, ks) <- HM.toList (HM.fromListWith (++) [ (n, [k]) | (k, n) <- finalOps ]), length ks > 1 ] + unmatched = filter (`notElem` fmap fst finalOps) (HM.keys namingMap) + unless (null dups) $ fail ("op names collide after resolution (curate the naming map): " <> show dups) + unless (null unmatched) $ hPutStrLn stderr ("[openapi] naming-map keys matching no operation: " <> show unmatched) + + -- the classes: every operation they name must exist + let opNames = S.fromList (map snd finalOps) + classOps = [ (k, n) | (k, cs) <- gcClasses, n <- map fst (csRecords cs) ++ map fst (csWants cs) ] + unknownOps = [ k <> ": " <> n | (k, n) <- classOps, not (n `S.member` opNames) ] + unless (null unknownOps) $ + fail ("the classes name operations that do not exist:\n " <> T.unpack (T.intercalate "\n " unknownOps)) + let recordsOf n = [ (fld, k) | (k, cs) <- gcClasses, (n', fld) <- csRecords cs, n' == n ] + wantsOf n = [ (part, fld, k) | (k, cs) <- gcClasses, (n', ws) <- csWants cs, n' == n, w <- ws + , let (part, rest) = T.breakOn "." w, let fld = T.drop 1 rest ] + classFields n = + (if null (recordsOf n) then "" else ", cbResultClasses = " <> hsList [ "(" <> quoted f <> ", " <> quoted k <> ")" | (f, k) <- recordsOf n ]) + <> (if null (wantsOf n) then "" else ", cbRequestClasses = " <> hsList [ "(" <> quoted pt <> ", " <> quoted f <> ", " <> quoted k <> ")" | (pt, f, k) <- wantsOf n ]) + quoted t = "\"" <> t <> "\"" + hsList xs = "[" <> T.intercalate ", " xs <> "]" + + -- request refinements from what the document declares about a field: + -- maxLength, minLength, an allowed-value list (x-zb-allowed, or a query + -- parameter's enum, which stays Text). Top-level fields of the body and + -- query parts; an optional field is held only when present. + let compOfType = HM.fromList [ (hs, c) | (c, hs) <- HM.toList names ] + fieldHs f = avoidKeywords (removeUnsupportedSymbols (lowerFirstChar f)) (S.fromList haskellKeywords) + rawObj k v = case v of + Object o -> KM.lookup k o + _ -> Nothing + rawComps kind = case rawObj "components" raw >>= rawObj kind of + Just (Object o) -> o + _ -> KM.empty + rawSchemas = rawComps "schemas" + rawParams = rawComps "parameters" + follow depth v + | depth > (20 :: Int) = v + | Just (String r) <- rawObj "$ref" v = maybe v (follow (depth + 1)) (KM.lookup (K.fromText (T.takeWhileEnd (/= '/') r)) rawSchemas) + | otherwise = v + int k v = case rawObj k v of + Just (Number n) -> Just (round n :: Integer) + _ -> Nothing + texts k v = case rawObj k v of + Just (Array a) -> [ t | String t <- foldr (:) [] a ] + _ -> [] + isText v = rawObj "type" v == Just (String "string") + consOf allowEnum v0 = + let v = follow 0 v0 + in if not (isText v) then [] else + [ ("max-length", \x -> "Natural/lessThanEqual (Text/length " <> x <> ") " <> tshow n) | Just n <- [int "maxLength" v] ] + ++ [ ("min-length", \x -> "Natural/lessThanEqual " <> tshow n <> " (Text/length " <> x <> ")") | Just n <- [int "minLength" v], n > 0 ] + ++ [ ("allowed", \x -> T.intercalate " || " [ "Text/equal " <> x <> " " <> dhallText a | a <- as ]) + | let as = texts "x-zb-allowed" v ++ (if allowEnum then texts "enum" v else []), not (null as) ] + predicate optional body + | optional = "\\(o : Field) -> merge { None = True, Some = \\(v : Text) -> " <> body "v" <> " } o" + | otherwise = "\\(v : Field) -> " <> body "v" + bodyRefinements comp = case KM.lookup (K.fromText comp) rawSchemas of + Just sch -> + let req = texts "required" sch + in [ ("body", fieldHs f, kind, predicate (f `notElem` req) body) + | Just (Object props) <- [rawObj "properties" sch], (fk, node) <- KM.toList props, let f = K.toText fk + , (kind, body) <- consOf False node ] + Nothing -> [] + queryRefinements opPath meth = + let item = rawObj "paths" raw >>= rawObj (K.fromText opPath) + params = [ p' | Just (Array a) <- [item >>= rawObj "parameters", item >>= rawObj (K.fromText (T.toLower meth)) >>= rawObj "parameters"] + , p <- foldr (:) [] a + , let p' = case rawObj "$ref" p of + Just (String r) -> fromMaybe p (KM.lookup (K.fromText (T.takeWhileEnd (/= '/') r)) rawParams) + _ -> p ] + in [ ("query", fieldHs n, kind, predicate (rawObj "required" p /= Just (Bool True)) body) + | p <- params, rawObj "in" p == Just (String "query") + , Just (String n) <- [rawObj "name" p], n `notElem` gcConnectionParams + , Just sch <- [rawObj "schema" p], (kind, body) <- consOf True sch ] + refinementsOf syn meth om b = + let opPath = T.drop (T.length meth + 1) (omKey om) + bodyComp = b >>= \x -> HM.lookup (unList (renderHsType x)) compOfType + rs = maybe [] bodyRefinements bodyComp ++ queryRefinements opPath meth + in [ "requestRefinementC (opIdOf \"" <> registryOpUuid gcApp syn meth om <> "\") " <> hsText part <> " " <> hsText fld + <> " " <> hsText (fld <> "-" <> kind) <> " " <> hsText src + | (part, fld, kind, src) <- rs ] + + -- where every declaration and instance goes + let enums = enumTypes st2 + homeFor def ct = if ctName ct `S.member` enums then HModel commonM else def + placed = + [ (homeFor (HModel m) ct, ct) | (m, cts, _) <- modelOuts, ct <- cts ] + ++ [ (homeFor (HRoutes m) ct, ct) | (m, _, rcts, _, _) <- pathOuts, ct <- rcts ] + ++ [ (homeFor (HContract m) ct, ct) | (m, _, _, ccts, _) <- pathOuts, ct <- ccts ] + firstOf = HM.fromListWith (\_ old -> old) [ (ctName ct, h) | (h, ct) <- placed ] + decls = [ (h, ct) | (h, ct) <- dedupe placed ] + dedupe = go S.empty + where go _ [] = [] + go seen ((h, ct) : rest) + | ctName ct `S.member` seen = go seen rest + | otherwise = (h, ct) : go (S.insert (ctName ct) seen) rest + insts = concat [ i | (_, _, i) <- modelOuts ] ++ concat [ i | (_, _, _, _, i) <- pathOuts ] + instHome i = fromMaybe (error ("no declaration for an instance of " <> T.unpack (instFor i))) (HM.lookup (instFor i) firstOf) + declsAt h = [ ct | (h', ct) <- decls, h' == h ] + instsAt h = [ i | i <- insts, instHome i == h ] + routeInfoOf m = concat [ ri | (m', ri, _, _, _) <- pathOuts, m' == m ] + + modules = nub (commonM : xModules xzb ++ map fst3 modelOuts ++ [ m | (m, _, _, _, _) <- pathOuts ]) + fst3 (a, _, _) = a + modelModules = [ m | m <- modules, m == commonM || not (null (declsAt (HModel m))) ] + opModules = [ m | m <- modules, not (null (routeInfoOf m)) ] + + -- a model module needs the modules its components point into + modelDeps m = + sort . nub $ + [ commonM | m /= commonM ] + ++ [ d | (c, sch) <- schemaList, modOfComp c == m, r <- schemaRefs (Inline sch) + , let d = modOfComp r, d /= m, d `elem` modelModules, HM.member r names ] + + forM_ modelModules $ \m -> + when (m == commonM && any (/= commonM) (modelDeps m)) $ + fail ("the common module points into " <> show (modelDeps m) <> ": a shared component may only point at shared components") + + let dataTypes = S.fromList [ ctName ct | (_, ct) <- decls, ctKind ct == DataDecl ] + -- what a synonym names: its right-hand side, as source + synRhs = HM.fromList [ (ctName ct, rhsOf (renderDecl (ctDecl ct))) | (_, ct) <- decls, ctKind ct == SynDecl ] + rhsOf d = stripParens (T.unwords (T.words (T.drop 1 (T.dropWhile (/= '=') d)))) + stripParens t + | "(" `T.isPrefixOf` t && ")" `T.isSuffixOf` t = stripParens (T.strip (T.drop 1 (T.dropEnd 1 t))) + | otherwise = t + -- a body or result named through a synonym still needs its record's + -- instances; an array body gets a whole-value override (dhall-do-api + -- has no OverrideType for Vector yet — ENG-4) when its element is ours + throughSyn ns = S.union ns (S.fromList [ r | n <- S.toList ns, Just r <- [HM.lookup n synRhs], r `S.member` dataTypes ]) + -- a response that is an envelope around one resource ({code, + -- message, contact}) binds as the resource: the binding's result is + -- the contact, so its fields (contact_id) are what a class records and + -- a later step reads. Lists (a resource beside page_context) and bare + -- acknowledgements ({code, message}) keep their envelope. + unwrapOf outT = do + guard (not (null gcEnvelope)) + c <- HM.lookup outT compOfType + sch <- HMO.lookup c compSchemas + [(f, Ref (Reference r))] <- pure [ pr | pr@(f', _) <- HMO.toList (_schemaProperties sch), f' `notElem` gcEnvelope ] + innerT <- HM.lookup r names + guard (innerT `S.member` dataTypes) + let req = f `elem` _schemaRequired sch + pat = outT <> " {" <> fieldHs f <> " = " <> (if req then "v" else "Just v") <> "}" + reader = "\\s -> case getSuccessOut s of { " <> pat <> " -> Right v; _ -> Left \"the response carries no " <> f <> "\" }" + pure (innerT, reader, f) + -- the type a binding returns: the resource, or the whole response + bindingResultOf o = case unwrapOf . renderHsType =<< o of + Just (t, _, _) -> Just t + Nothing -> renderHsType <$> o + unwrapped = S.fromList + [ innerT | (_, ri, _, _, _) <- pathOuts, (_, ms) <- ri, (_, (_h,_q,_c,_b,Just o,_e,_ho,_om)) <- ms + , Just (innerT, _, _) <- [unwrapOf (renderHsType o)] ] + requestSide = throughSyn (S.union (paramRecords st2) (bodyTypes st2)) + resultSide = throughSyn (S.union (resultTypes st2) unwrapped) + vectorBodies = nub + [ (r, e) | n <- S.toList (S.union (paramRecords st2) (bodyTypes st2)), Just r <- [HM.lookup n synRhs] + , Just e <- [stripParens <$> T.stripPrefix "Vector " r], e `S.member` dataTypes ] + vectorOverrides h = + concat [ [ "instance OverrideType (" <> r <> ") where" + , " overrideType = optionalOverrideType @(" <> r <> ")" + , " overrideDefault = optionalOverrideDefault @(" <> r <> ")" + , "" ] + | (r, e) <- vectorBodies, HM.lookup e firstOf == Just h ] + sumLike = S.union enums (S.fromList (HM.keys (createdSums st2))) + errorTypes = S.fromList + [ t | (_, ri, _, _, _) <- pathOuts, (_, ms) <- ri, (_, (_h,_q,_c,_b,_o,Just errT,_ho,_om)) <- ms + , let t = renderHsType errT, t `notElem` ["()", "Text"] ] + instanceLines n = + [ "instance HsType " <> n, "instance ToHsVal " <> n, "instance FromHsVal " <> n ] + ++ [ "instance OverrideType " <> n | n `S.member` requestSide, not (n `S.member` sumLike) ] + ++ [ "instance HsSelect " <> n | n `S.member` resultSide, not (n `S.member` sumLike) ] + ++ [ "instance ErrorText " <> n | n `S.member` errorTypes ] + ++ [ "" ] + bridgeFor h = concatMap instanceLines [ ctName ct | ct <- declsAt h, ctName ct `S.member` dataTypes ] ++ vectorOverrides h + + p = gcModulePrefix + modelMod m = p <> ".Model." <> pascalName m + routesMod m = p <> ".Routes." <> pascalName m + contractMod m = p <> ".Contract." <> pascalName m + instancesMod m = p <> ".Registry.Instances." <> pascalName m + opsMod m = p <> ".Registry.Ops." <> pascalName m + opsFn m = lowerFirstChar (pascalName m) <> "Ops" + appMod = p <> ".App" + contractTop = p <> ".Contract" + registryTop = p <> ".Registry" + supportMod = p <> ".Registry.Support" + genDir = gcOutDir "gen" + srcFile dir modName = genDir dir T.unpack (T.replace "." "/" modName) <> ".hs" + write = writeGenerated cfg + + removePathForcibly genDir + + -- models + forM_ modelModules $ \m -> do + let h = HModel m + body = map (renderDecl . ctDecl) (declsAt h) ++ map (renderDecl . instDecl) (instsAt h) + extra = if m == commonM then [opaqueDecl] else [] + write (srcFile ("model-" <> T.unpack m) (modelMod m)) $ + T.unlines $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DeriveGeneric #-}" + , "{-# LANGUAGE DuplicateRecordFields #-}" + , "{-# LANGUAGE KindSignatures #-}" + , "{-# LANGUAGE NoFieldSelectors #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: the " <> m <> " module's types. Do not edit." + , "module " <> modelMod m <> " where" + , "" + ] + ++ modelImports + ++ [ "import " <> modelMod d | d <- modelDeps m ] + ++ [ "" ] + ++ extra + ++ body + + -- the app type + write (srcFile "contract" appMod) $ T.unlines + [ "-- Generated by openapi-model-generator. Do not edit." + , "module " <> appMod <> " (" <> gcApp <> ") where" + , "" + , "-- | " <> gcApp <> ", as a webapi application." + , "data " <> gcApp + ] + + -- routes + forM_ opModules $ \m -> + write (srcFile "contract" (routesMod m)) $ T.unlines $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: the " <> m <> " module's routes. Do not edit." + , "module " <> routesMod m <> " where" + , "" + , "import Data.Int (Int32, Int64)" + , "import Data.Text (Text)" + , "import WebApi.Contract ((://), (:/))" + , "import " <> appMod + ] + ++ [ "import " <> modelMod d | d <- modelModules ] + ++ [ "" ] + ++ map (renderDecl . ctDecl) (declsAt (HRoutes m)) + + -- the Apis list + let apisList = listPromotedTy + [ var "Route" @@ listPromotedTy (var . textToRdrNameStr <$> meths) @@ var (textToRdrNameStr syn) + | m <- opModules, (syn, ms) <- routeInfoOf m, let meths = map fst ms ] + webApiInst = instance' (var "WebApi" @@ var (textToRdrNameStr gcApp)) [tyFamInst "Apis" [var (textToRdrNameStr gcApp)] apisList] + write (srcFile "contract" contractTop) $ T.unlines $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "{-# OPTIONS_GHC -Wno-orphans #-}" + , "" + , "-- Generated by openapi-model-generator: every route " <> gcApp <> " serves. Do not edit." + , "module " <> contractTop <> " (" <> gcApp <> ") where" + , "" + , "import WebApi.Contract" + , "import " <> appMod + ] + ++ [ "import " <> routesMod m | m <- opModules ] + ++ [ "", renderDecl webApiInst ] + + -- contracts + forM_ opModules $ \m -> do + let h = HContract m + contractInsts = concatMap (mkApiContractInstances gcApp) (routeInfoOf m) + write (srcFile "contract" (contractMod m)) $ T.unlines $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DeriveGeneric #-}" + , "{-# LANGUAGE DuplicateRecordFields #-}" + , "{-# LANGUAGE FlexibleInstances #-}" + , "{-# LANGUAGE MultiParamTypeClasses #-}" + , "{-# LANGUAGE NoFieldSelectors #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "{-# LANGUAGE TypeFamilies #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "{-# LANGUAGE TypeSynonymInstances #-}" + , "{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: the " <> m <> " module's contract. Do not edit." + , "module " <> contractMod m <> " where" + , "" + ] + ++ modelImports + ++ [ "import Data.CaseInsensitive (mk)", "import WebApi.Contract", "import WebApi.Param", "import " <> appMod, "import " <> contractTop <> " ()", "import " <> routesMod m ] + ++ [ "import " <> modelMod d | d <- modelModules ] + ++ [ "" ] + ++ map (renderDecl . ctDecl) (declsAt h) + ++ map (renderDecl . instDecl) (instsAt h) + ++ map renderDecl contractInsts + + -- registry: support + write (srcFile "registry" supportMod) $ T.unlines + [ "{-# LANGUAGE OverloadedStrings #-}" + , "" + , "-- Generated by openapi-model-generator. Do not edit." + , "module " <> supportMod <> " (opIdOf, mkFqn) where" + , "" + , "import Data.List.NonEmpty (NonEmpty (..))" + , "import Data.Maybe (fromMaybe)" + , "import Data.Text (Text)" + , "import qualified Data.Text as T" + , "import qualified Data.UUID.Types as UUID" + , "import Dhall.Do.Api.Id (FQN (..), OperationId, mkOperationId)" + , "import GHC.Stack (HasCallStack)" + , "" + , "opIdOf :: HasCallStack => Text -> OperationId" + , "opIdOf t = mkOperationId (fromMaybe (error (\"bad uuid literal: \" <> T.unpack t)) (UUID.fromText t))" + , "" + , "-- | Every operation is " <> gcQualifier <> "/." + , "mkFqn :: Text -> FQN" + , "mkFqn n = FQN {qualifier = \"" <> gcQualifier <> "\" :| [], name = n}" + ] + + -- registry: bridge instances per model module + forM_ modelModules $ \m -> + write (srcFile "registry" (instancesMod m)) $ T.unlines $ + [ "{-# LANGUAGE FlexibleInstances #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: dhall-do's bridge for the " <> m <> " module's types. Do not edit." + , "module " <> instancesMod m <> " () where" + , "" + , "import Data.Vector (Vector)" + , "import Dhall.Do.Api.Bridge" + , "import Dhall.Do.Api.WebApi.Concrete.Binding (ErrorText)" + , "import " <> modelMod m + ] + ++ [ "import " <> instancesMod d <> " ()" | d <- modelDeps m ] + ++ (if m == commonM then opaqueBridgeImports else []) + ++ [ "" ] + ++ (if m == commonM then opaqueBridge else []) + ++ bridgeFor (HModel m) + + -- registry: operations per module + forM_ opModules $ \m -> do + let ops = [ (syn, meth, maybe "()" renderHsType outInfo, om) + | (syn, ms) <- routeInfoOf m, (meth, (_h,_q,_c,_b,outInfo,_e,_ho,om)) <- ms ] + regOf (syn, meth, outT, om) = + let n = finalOpName syn meth om + in case unwrapOf outT of + Just (innerT, reader, _) -> registrationExprWith gcApp reader innerT (classFields n) (syn, meth, om) + Nothing -> registrationExprWith gcApp "Right . getSuccessOut" outT (classFields n) (syn, meth, om) + refLines = concat [ refinementsOf syn meth om b | (syn, ms) <- routeInfoOf m, (meth, (_h,_q,_c,b,_o,_e,_ho,om)) <- ms ] + -- a declaration is composed above what it names: refinements first + chain = refLines ++ map regOf ops + regLines = [ " " <> (if i == 0 then " " else ". ") <> l | (i, l) <- zip [0 :: Int ..] chain ] + write (srcFile "registry" (opsMod m)) $ T.unlines $ + [ "{-# LANGUAGE DataKinds #-}" + , "{-# LANGUAGE DisambiguateRecordFields #-}" + , "{-# LANGUAGE FlexibleInstances #-}" + , "{-# LANGUAGE DuplicateRecordFields #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# LANGUAGE TypeOperators #-}" + , "{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: the " <> m <> " module's operations. Do not edit." + , "module " <> opsMod m <> " (" <> opsFn m <> ") where" + , "" + , "import Data.Int (Int32, Int64)" + , "import Data.Text (Text)" + , "import Data.Vector (Vector)" + , "import Dhall.Do.Api.Bridge" + , "import Dhall.Do.Api.WebApi.Concrete.Binding" + , "import WebApi.Client.Session (AppIsElem, getSuccessOut)" + , "import WebApi.Contract hiding (OperationId)" + , "import " <> appMod + , "import " <> contractTop <> " ()" + , "import " <> routesMod m + , "import " <> contractMod m + , "import " <> supportMod + ] + ++ [ "import " <> modelMod d | d <- modelModules ] + ++ [ "import " <> instancesMod d <> " ()" | d <- modelModules ] + ++ [ "" ] + ++ bridgeFor (HContract m) + ++ bridgeFor (HRoutes m) + ++ [ opsFn m <> " :: forall apps. AppIsElem " <> gcApp <> " apps => ConcreteActions apps -> ConcreteActions apps" + , opsFn m <> " =" ] + ++ regLines + + -- registry: the whole + write (srcFile "registry" registryTop) $ T.unlines $ + [ "{-# LANGUAGE OverloadedStrings #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE TypeApplications #-}" + , "{-# OPTIONS_GHC -Wno-unused-imports #-}" + , "" + , "-- Generated by openapi-model-generator: every " <> gcApp <> " operation. Do not edit." + , "module " <> registryTop <> " (" <> gcOpsName <> ") where" + , "" + , "import Data.Text (Text)" + , "import Dhall.Do.Api.WebApi.Concrete.Binding (ConcreteActions, externalClassC, recordsClassC)" + , "import WebApi.Client.Session (AppIsElem)" + , "import " <> appMod + ] + ++ [ "import " <> opsMod m <> " (" <> opsFn m <> ")" | m <- opModules ] + ++ [ "" + , "-- | Every operation " <> gcApp <> " serves, added to a registry." + , gcOpsName <> " :: forall apps. AppIsElem " <> gcApp <> " apps => ConcreteActions apps -> ConcreteActions apps" + , gcOpsName <> " = " <> T.intercalate " . " (["classes" | not (null gcClasses)] ++ (if null opModules then ["id"] else map opsFn opModules)) + ] + ++ (if null gcClasses then [] else + [ "" + , "-- | The identity classes (bindings/classes.yaml): what a result records and a request takes." + , "classes :: ConcreteActions apps -> ConcreteActions apps" + , "classes =" + ] + ++ [ " " <> (if i == 0 then " " else ". ") + <> (if csExternal cs then "externalClassC \"" <> k <> "\"" else "recordsClassC @" <> csType cs <> " \"" <> k <> "\"") + | (i, (k, cs)) <- zip [0 :: Int ..] (sortOn fst gcClasses) ]) + + -- the package + let modelLibs = [ "model-" <> m | m <- modelModules ] + pkg = gcPackage + stanza name vis dir mods deps = + [ name + , " import: generated" ] + ++ [ " visibility: public" | vis ] + ++ [ " hs-source-dirs: gen/" <> dir + , " exposed-modules:" ] + ++ [ " " <> md | md <- mods ] + ++ [ " build-depends:" ] + ++ [ " " <> (if i == 0 then " " else ", ") <> d | (i, d) <- zip [0 :: Int ..] deps ] + ++ [ "" ] + cabal = T.unlines $ + [ "cabal-version: 3.0" + , "-- Generated by openapi-model-generator (tools/zbc gen). Do not edit." + , "name: " <> pkg + , "version: " <> gcVersion + , "synopsis: " <> gcSynopsis + , "build-type: Simple" + , "" + , "-- Generated code is compiled " <> T.unwords gcGhcOptions <> " whatever the consuming" + , "-- project's optimization: it is boilerplate over thousands of types." + , "common generated" + , " default-language: Haskell2010" + , " ghc-options: " <> T.unwords gcGhcOptions + , "" + ] + ++ concat + [ stanza ("library model-" <> m) True ("model-" <> m) [modelMod m] + (["base", "text", "vector", "aeson"] ++ [ pkg <> ":model-" <> d | d <- modelDeps m ]) + | m <- modelModules ] + ++ stanza "library" False "contract" + ([appMod, contractTop] ++ map routesMod opModules ++ map contractMod opModules) + (["base", "text", "vector", "aeson", "case-insensitive", "webapi-contract"] ++ [ pkg <> ":" <> l | l <- modelLibs ]) + ++ stanza "library registry" True "registry" + ([registryTop, supportMod] ++ map instancesMod modelModules ++ map opsMod opModules) + (["base", "text", "vector", "aeson", "bytestring", "uuid-types", "webapi-contract", "webapi-session", "dhall", "dhall-do-api", "dhall-do-api-webapi", pkg] + ++ [ pkg <> ":" <> l | l <- modelLibs ]) + T.writeFile (gcOutDir T.unpack pkg <> ".cabal") $ + if T.null (T.strip gcCabalExtra) + then cabal + else cabal <> "-- The package's hand-written stanzas (zbc.yaml: cabal).\n" <> gcCabalExtra + + -- every operation as data: what tests, the ledger and the docs read + let rawOp opPath meth = case raw of + Object o + | Just (Object ps) <- KM.lookup "paths" o + , Just (Object item) <- KM.lookup (K.fromText opPath) ps -> + (KM.lookup (K.fromText (T.toLower meth)) item, KM.lookup "x-mcp-group" item) + _ -> (Nothing, Nothing) + field k = \case + Just (Object o) -> KM.lookup k o + _ -> Nothing + scopesOf = \case + Just (Array reqs) -> nub [ sc | Object req <- foldr (:) [] reqs, (_, Array scs) <- KM.toList req, String sc <- foldr (:) [] scs ] + _ -> [] + strs = \case + Just (Array a) -> [ t | String t <- foldr (:) [] a ] + _ -> [] + opRecords = + [ object + [ "name" .= finalOpName syn meth om + , "id" .= registryOpUuid gcApp syn meth om + , "operationId" .= maybe Null id (field "operationId" rawOperation) + , "method" .= meth + , "path" .= T.drop (T.length meth + 1) (omKey om) + , "module" .= m + , "route" .= syn + , "pathParam" .= fmap renderHsType (omPathParam om) + , "connection" .= omConnParams om + , "query" .= fmap renderHsType q + , "header" .= fmap renderHsType h + , "body" .= fmap (unList . renderHsType) b + , "result" .= fmap renderHsType o + , "resource" .= ((\(_, _, f) -> f) <$> (unwrapOf . renderHsType =<< o)) + , "bodyComponent" .= (b >>= \x -> HM.lookup (unList (renderHsType x)) compOfType) + , "resultComponent" .= (bindingResultOf o >>= \t -> HM.lookup t compOfType) + , "bindingResult" .= bindingResultOf o + , "error" .= fmap renderHsType e + , "summary" .= omSummary om + , "scopes" .= scopesOf (field "security" rawOperation) + , "tags" .= strs (field "tags" rawOperation) + , "group" .= strs grp + ] + | m <- opModules, (syn, ms) <- routeInfoOf m, (meth, (h,q,_c,b,o,e,_ho,om)) <- ms + , let (rawOperation, grp) = rawOp (T.drop (T.length meth + 1) (omKey om)) meth ] + BL.writeFile (genDir "operations.json") $ + "[\n" <> BL.intercalate ",\n" (map encode opRecords) <> "\n]\n" + + -- what the generator could not type, for review beside the code + let ws = sort (nub (warnings st2)) + T.writeFile (genDir "warnings.txt") (T.unlines ws) + hPutStrLn stderr $ + "[openapi] " <> show (length modelModules) <> " model modules, " <> show (length opModules) <> " operation modules, " + <> show (length finalOps) <> " operations, " <> show (S.size dataTypes) <> " data types, " + <> show (length ws) <> " warnings (gen/warnings.txt)" + where + modelImports = + [ "import Control.Applicative ((<|>))" + , "import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, withText, (.:), (.:?), (.=))" + , "import Data.Int (Int32, Int64)" + , "import Data.Maybe (catMaybes)" + , "import Data.Text (Text)" + , "import Data.Vector (Vector)" + , "import GHC.Generics (Generic)" + ] + opaqueDecl = T.unlines + [ "-- | A value the spec leaves untyped, kept as the JSON it arrived as." + , "newtype Opaque = Opaque Value" + , " deriving (Show, Eq, Generic)" + , "" + , "instance FromJSON Opaque where" + , " parseJSON = pure . Opaque" + , "" + , "instance ToJSON Opaque where" + , " toJSON (Opaque v) = v" + ] + opaqueBridgeImports = + [ "import Data.Aeson (eitherDecodeStrict)" + , "import Data.Aeson.Text (encodeToLazyText)" + , "import qualified Data.Text as T" + , "import qualified Data.Text.Encoding as TE" + , "import qualified Data.Text.Lazy as TL" + ] + -- Opaque crosses to Dhall as its JSON text + opaqueBridge = + [ "instance TextIso Opaque where" + , " toTextIso (Opaque v) = TL.toStrict (encodeToLazyText v)" + , " fromTextIso t = either (Left . T.pack) (Right . Opaque) (eitherDecodeStrict (TE.encodeUtf8 t))" + , "" + , "instance HsType Opaque where" + , " hsType = hsType @(ViaText Opaque)" + , " hsNamedTypes = []" + , "" + , "instance FromHsVal Opaque where" + , " fromHsLit o = fromHsLit (ViaText o)" + , " fromHsVal = embedScalar" + , "" + , "instance ToHsVal Opaque where" + , " toHsLit e = (\\(ViaText o) -> o) <$> toHsLit e" + , "" + , "instance HsSelect Opaque where" + , " selectField = noSelect" + , "" + , "instance OverrideType Opaque where" + , " overrideType = optionalOverrideType @Opaque" + , " overrideDefault = optionalOverrideDefault @Opaque" + , "" + ] + +tshow :: Show a => a -> Text +tshow = T.pack . show + +-- | A Dhall text literal. +dhallText :: Text -> Text +dhallText t = "\"" <> T.concatMap esc t <> "\"" + where esc = \case + '"' -> "\\\"" + '\\' -> "\\\\" + '$' -> "\\u0024" + c -> T.singleton c + +-- | A Haskell string literal. +hsText :: Text -> Text +hsText t = "\"" <> T.concatMap esc t <> "\"" + where esc = \case + '"' -> "\\\"" + '\\' -> "\\\\" + '\n' -> "\\n" + c -> T.singleton c + +-- | A request body's type-level list, @'[T]@, as @T@. +unList :: Text -> Text +unList t = fromMaybe t (T.stripPrefix "'[" t >>= T.stripSuffix "]") + +-- | Write one generated module, formatted when the config asks. +writeGenerated :: GenConfig -> FilePath -> Text -> IO () +writeGenerated GenConfig {gcFormat} fp contents = do + txt <- + if gcFormat + then ormolu defaultConfig {cfgCheckIdempotence = False} fp contents + `catch` \(e :: SomeException) -> do + hPutStrLn stderr ("[openapi] formatter failed for " <> fp <> " (writing unformatted): " <> takeWhile (/= '\n') (show e)) + pure contents + else pure contents + createDirectoryIfMissing True (takeDirectory fp) + T.writeFile fp txt diff --git a/webapi-openapi/test/Golden.hs b/webapi-openapi/test/Golden.hs new file mode 100644 index 0000000..becd364 --- /dev/null +++ b/webapi-openapi/test/Golden.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE LambdaCase #-} +-- | Golden tests: each case runs the generator over a fixture and compares +-- every file it writes with the committed copy under test/golden/. +-- +-- A change to the generator's output is reviewed as a diff of these files: +-- run with GOLDEN_ACCEPT=1 to rewrite them, then read the diff. +module Main (main) where + +import Control.Monad (forM, unless, when) +import qualified Data.HashMap.Strict as HM +import qualified Data.Aeson as A +import qualified Data.ByteString.Lazy as BL +import Data.List (sort) +import System.Directory +import System.Environment (lookupEnv) +import System.Exit (exitFailure) +import System.FilePath ((), makeRelative) +import WebApi.OpenAPI (NamingMap, generateModels) + +data Case = Case + { caseName :: String + , caseInput :: FilePath + , caseNaming :: Maybe FilePath + , caseSumEnums :: Bool + } + +cases :: [Case] +cases = + [ Case "ns-currency" "test/fixtures/ns-currency-slice.json" (Just "test/fixtures/ns-currency-naming.json") False + ] + +main :: IO () +main = do + accept <- maybe False (not . null) <$> lookupEnv "GOLDEN_ACCEPT" + tmp <- ( "webapi-openapi-golden") <$> getTemporaryDirectory + failures <- forM cases $ \c -> do + let out = tmp caseName c + removePathForcibly out + naming <- maybe (pure HM.empty) loadNaming (caseNaming c) + generateModels (caseInput c) out "/" naming (caseSumEnums c) + produced <- listFiles out + let golden = "test/golden" caseName c + if accept + then do + removePathForcibly golden + mapM_ (\f -> copyInto (out f) (golden f)) produced + putStrLn ("accepted " <> caseName c <> " (" <> show (length produced) <> " files)") + pure False + else do + expected <- doesDirectoryExist golden >>= \case + True -> listFiles golden + False -> pure [] + let missing = [f | f <- expected, f `notElem` produced] + extra = [f | f <- produced, f `notElem` expected] + diffs <- fmap concat . forM [f | f <- produced, f `elem` expected] $ \f -> do + a <- readFile (golden f) + b <- readFile (out f) + length a `seq` length b `seq` pure [f | a /= b] + let bad = missing ++ extra ++ diffs + unless (null bad) $ do + putStrLn ("FAIL " <> caseName c) + mapM_ (\f -> putStrLn (" missing " <> f)) missing + mapM_ (\f -> putStrLn (" new " <> f)) extra + mapM_ (\f -> putStrLn (" differs " <> f <> " (diff " <> (golden f) <> " " <> (out f) <> ")")) diffs + when (null bad) $ putStrLn ("ok " <> caseName c) + pure (not (null bad)) + when (or failures) $ do + putStrLn "golden output changed; review the diff, then rerun with GOLDEN_ACCEPT=1" + exitFailure + where + loadNaming :: FilePath -> IO NamingMap + loadNaming fp = either (fail . ((fp <> ": ") <>)) pure . A.eitherDecode =<< BL.readFile fp + copyInto from to = do + createDirectoryIfMissing True (takeDirectory' to) + copyFile from to + takeDirectory' = reverse . drop 1 . dropWhile (/= '/') . reverse + +-- | Every regular file under a directory, relative to it, sorted. +listFiles :: FilePath -> IO [FilePath] +listFiles root = sort . map (makeRelative root) <$> go root + where + go d = do + names <- listDirectory d + fmap concat . forM names $ \n -> do + let p = d n + isDir <- doesDirectoryExist p + if isDir then go p else pure [p] diff --git a/webapi-openapi/test/fixtures/ns-currency-naming.json b/webapi-openapi/test/fixtures/ns-currency-naming.json new file mode 100644 index 0000000..0176c0e --- /dev/null +++ b/webapi-openapi/test/fixtures/ns-currency-naming.json @@ -0,0 +1,47 @@ +{ + "GET /currency": { + "name": "listCurrencies", + "uuid": "0d1e2f30-1111-4a01-8001-000000000001", + "summary": "the currencies as NetSuite lists them" + }, + "GET /currency/{id}": { + "name": "getCurrency", + "uuid": "0d1e2f30-1111-4a01-8001-000000000002", + "summary": "one currency by internal id (request.path)" + }, + "POST /currency": { + "name": "postCurrency", + "uuid": "0d1e2f30-1111-4a01-8001-000000000003", + "summary": "insert a currency (the body names it)", + "defaults": { + "body": { + "links": "mempty :: Vector NsLink" + } + } + }, + "PUT /currency/{id}": { + "name": "putCurrency", + "uuid": "0d1e2f30-1111-4a01-8001-000000000004", + "summary": "upsert a currency by external id (request.path)", + "defaults": { + "body": { + "links": "mempty :: Vector NsLink" + } + } + }, + "PATCH /currency/{id}": { + "name": "patchCurrency", + "uuid": "0d1e2f30-1111-4a01-8001-000000000005", + "summary": "update a currency by internal id (request.path)", + "defaults": { + "body": { + "links": "mempty :: Vector NsLink" + } + } + }, + "DELETE /currency/{id}": { + "name": "deleteCurrency", + "uuid": "0d1e2f30-1111-4a01-8001-000000000006", + "summary": "remove a currency by internal id (request.path)" + } +} \ No newline at end of file diff --git a/webapi-openapi/test/fixtures/ns-currency-slice.json b/webapi-openapi/test/fixtures/ns-currency-slice.json new file mode 100644 index 0000000..3d2e32a --- /dev/null +++ b/webapi-openapi/test/fixtures/ns-currency-slice.json @@ -0,0 +1,1060 @@ +{ + "components": { + "schemas": { + "currency": { + "properties": { + "currencyPrecision": { + "description": "Displays the precision of the currency, which designates the number of digits to the right of the decimal point used in currency transactions. Precision can be zero or two. The level of decimal precision indicated is used for inventory costing calculations to maintains consistency between inventory costing and reporting. Values in report results are rounded to the base currency precision. This rounding applies to currency values and non-currency values, including formula column values. To change this read-only field to a dropdown list through which you can change the precision from zero or two, contact NetSuite Technical Support.", + "format": "int64", + "title": "Currency Precision", + "type": "integer" + }, + "displaySymbol": { + "description": "Enter the currency symbol and text to use for this currency. Include spaces if you want to separate the symbol from the currency value. For example, $ USD or $CAD.", + "title": "Symbol", + "type": "string" + }, + "exchangeRate": { + "description": "Enter an exchange rate for this currency against the base currency of this company, or if you use OneWorld, for this currency against the base currency of the root parent subsidiary. The exchange rate is equal to the base currency amount divided by the foreign currency amount. For example, if your company is located in Canada (base currency) and you are defining the U.S. dollar (foreign currency), and the current exchange rate is 1.02 Canadian dollars to 1.00 U.S. dollar, the Default Exchange Rate for the U.S. dollar is 1.02/1.00, or 1.02. This rate is the basis for rates in the Currency Exchange Rates table that are used in foreign currency transactions. If you use OneWorld, this rate also is the basis for rates in the Consolidated Exchange Rates table that are used in consolidated financials. For more information, see the help topic Currency Exchange Rates.", + "format": "double", + "title": "Default Exchange Rate", + "type": "number" + }, + "externalId": { + "title": "External ID", + "type": "string" + }, + "formatSample": { + "description": "This field displays a sample of how currency amounts display for the selected format. The decimal precision shown cannot be changed. Note: The decimal precision shown is the precision used for both inventory reporting and for costing calculations.", + "title": "Format Sample", + "type": "string" + }, + "fxRateUpdateTimezone": { + "properties": { + "id": { + "enum": [ + "1", + "2", + "3", + "4" + ], + "title": "Internal identifier", + "type": "string" + }, + "refName": { + "title": "Reference Name", + "type": "string" + } + }, + "type": "object" + }, + "id": { + "title": "Internal ID", + "type": "string" + }, + "includeInFxRateUpdates": { + "description": "Check this box to update currency exchange rates daily.", + "title": "Automatic Update", + "type": "boolean" + }, + "isAnchorCurrency": { + "description": "A check in this box indicates that the currency has been selected as an anchor currency in the accounting preferences. To clear the box, change the selection in the accounting preference under Use Triangulation Calculation by NetSuite. If this currency is a designated anchor currency and has been used in an exchange rate calculation, you cannot delete this currency. For more information about triangulation and anchor currencies, see the help topics Methods for Obtaining Exchange Rates andAnchor Currencies.", + "title": "Is Anchor Currency", + "type": "boolean" + }, + "isBaseCurrency": { + "description": "Indicates that this currency is the company's base currency or in OneWorld accounts, the base currency for a subsidiary. Note: After you have entered transactions in foreign currencies, you cannot change a base currency.", + "title": "Is Base Currency", + "type": "boolean" + }, + "isInactive": { + "description": "Check this box to make the currency record is inactive, or clear it to make the record active. You cannot make a currency inactive if any open transactions exist in that currency.", + "title": "Inactive", + "type": "boolean" + }, + "lastModifiedDate": { + "format": "date-time", + "title": "Last Modified Date", + "type": "string" + }, + "links": { + "items": { + "$ref": "#/components/schemas/nsLink" + }, + "readOnly": true, + "title": "Links", + "type": "array" + }, + "locale": { + "properties": { + "id": { + "enum": [ + "it_CH", + "af_ZA", + "en_TC", + "es_EA", + "es_EC", + "pt_BR", + "en_CY", + "fr_LU", + "nl_AN", + "es_UY", + "en_TT", + "es_ES", + "pt_ST", + "en_DM", + "en_TZ", + "es_ES_EURO", + "fr_ML", + "de_DE_onLQA", + "es_VE", + "nl_BE", + "da_DK", + "pt_AO", + "to_TO", + "en_UG", + "am_ET", + "ss_SZ", + "nl_BQ", + "pt_AW", + "ar", + "ko_KR", + "en_US", + "ko_KP", + "fr_BE_EURO", + "si_AQ", + "fr_MG", + "el_GR", + "be_BY", + "en_AU", + "he_IL", + "en_AW", + "es_SV", + "en_BB", + "ar_YE", + "es_CO", + "es_CL", + "en_BM", + "pa_IN", + "en_SC", + "es_CR", + "en_BS", + "sm_WS", + "fr_KM", + "es_CU", + "en_SB", + "it_IT_EURO", + "en_SG", + "en_SH", + "en_BW", + "en_BZ", + "en_SL", + "az_AZ", + "fi_FI", + "en_SS", + "sr_YU", + "en_CD", + "ka_GE", + "en_CA", + "lv_LV", + "uk_UA", + "ur_PK", + "es_DO", + "ar_IQ", + "fr_LU_EURO", + "pt_PT", + "fr_FR_EURO", + "en_PH", + "th_TH", + "bn_BD", + "si_LK", + "en_PG", + "hu_HU", + "ar_SA", + "ar_SD", + "ru_KZ", + "ar_BH", + "nl_BE_EURO", + "ro_MD", + "en_QA", + "ru_KG", + "es_AR", + "ta_IN", + "sr_RS", + "aa_ER", + "en", + "de_DE_EURO", + "zh_MO", + "en_AE", + "ar_SY", + "es_BO", + "en_AI", + "no_NO", + "en_AG", + "nl_SR", + "fr_VU", + "en_MW", + "gu_AQ", + "ar_TN", + "nl_SX", + "hi_IN", + "en_NA", + "mn_MN", + "en_NG", + "fr_FR", + "ms_MY", + "nl_CW", + "uz_UZ", + "ar_DJ", + "sr_CS", + "de_AT_EURO", + "en_NZ", + "es_PE", + "es_PA", + "fa_IR", + "fr_GN", + "ar_DZ", + "lb_LU", + "pt_CV", + "sh_RS", + "xx_US", + "fr_WF", + "ht_HT", + "es_AR_onLQA", + "es_PR", + "ar_EG", + "es_PY", + "fr_GA", + "en_KW", + "de_AT", + "ro_RO", + "en_KY", + "fr_FR_onLQA", + "fr_DJ", + "ca_ES_EURO", + "cs_CZ", + "pl_AQ", + "en_LC", + "fr_TD", + "fr_TG", + "sv_AX", + "es_MX", + "sk_SK", + "en_LR", + "en_LS", + "ar_OM", + "dz_BT", + "te_IN", + "de_LU_EURO", + "sq_AL", + "sv_SE", + "sn_ZW", + "es_NI", + "my_MM", + "en_IE_EURO", + "en_MF", + "en_MU", + "it_IT", + "pl_PL", + "fr_BE", + "fr_BF", + "fr_BI", + "tr_TR", + "fr_BJ", + "id_ID", + "fr_RW", + "en_ZM", + "km_KH", + "ja_JP", + "fr_BL", + "de_DE", + "tg_TJ", + "ar_QA", + "de_CH", + "zh_HK", + "pt_PT_EURO", + "en_JO", + "en_JM", + "fr_CA", + "nl_NL_EURO", + "fr_CF", + "fr_CG", + "fr_CD", + "pa_AQ", + "xx_US_wthId", + "fr_CH", + "fr_CI", + "pt_GW", + "vi_VN", + "ru_MD", + "fr_CM", + "fr_SC", + "en_KE", + "bs_BA", + "ne_NP", + "sl_SI", + "en_KN", + "fr_SN", + "ar_AE", + "en_GY", + "tl_PH", + "es_IC", + "ca_ES", + "lo_LA", + "kn_IN", + "so_SO", + "fr_PF", + "ar_JO", + "nl_NL", + "is_IS", + "fi_FI_EURO", + "pt_MZ", + "sk_SK_EURO", + "sl_SI_EURO", + "ms_BN", + "en_IE", + "hr_HR", + "ar_KW", + "de_LU", + "lt_LT", + "en_IN", + "ps_AF", + "en_ZA", + "en_VC", + "ru_RU", + "sh_YU", + "ar_LB", + "mr_IN", + "dv_MV", + "fj_FJ", + "zh_TW", + "tk_TM", + "en_VU", + "ar_LY", + "fr_NE", + "en_FK", + "fr_NC", + "es_GT", + "es_GQ", + "fa_AF", + "bg_BG", + "hy_AM", + "en_CY_EURO", + "mk_MK", + "ar_MA", + "en_GD", + "en_GB", + "es_HN", + "gu_IN", + "en_GH", + "et_EE", + "en_GI", + "zh_CN", + "en_GM", + "ar_MR" + ], + "title": "Internal identifier", + "type": "string" + }, + "refName": { + "title": "Reference Name", + "type": "string" + } + }, + "type": "object" + }, + "name": { + "description": "Enter a unique name for the currency. Because many countries use the same name for their currencies, you should use a combined name that includes the country name or abbreviation as well as the name of the currency. For example, pesos are the currency in the Philippines, Uruguay, and Mexico. In the Name field, you might enter \u201cMexican peso.\u201d This name appears in the Currency field on records and transactions.", + "title": "Name", + "type": "string" + }, + "overrideCurrencyFormat": { + "description": "Check this box to customize the currency format.", + "title": "Override Currency Format", + "type": "boolean" + }, + "refName": { + "title": "Reference Name", + "type": "string" + }, + "symbol": { + "description": "Enter the three-letter International Standards Organization (ISO) code for this currency. For example, you would use PHP for Philippines pesos, UYU for Uruguayan pesos, and MXN for Mexican pesos.", + "title": "ISO Code", + "type": "string" + }, + "symbolPlacement": { + "properties": { + "id": { + "enum": [ + "1", + "2" + ], + "title": "Internal identifier", + "type": "string" + }, + "refName": { + "title": "Reference Name", + "type": "string" + } + }, + "type": "object" + } + }, + "type": "object" + }, + "currencyCollection": { + "properties": { + "count": { + "format": "int64", + "readOnly": true, + "title": "Count", + "type": "integer" + }, + "hasMore": { + "readOnly": true, + "title": "Has More Results", + "type": "boolean" + }, + "items": { + "description": "An array field that represents a collection of elements, for example, sublist lines, multiselect items, or search results.", + "items": { + "$ref": "#/components/schemas/currency" + }, + "title": "Items", + "type": "array" + }, + "links": { + "items": { + "$ref": "#/components/schemas/nsLink" + }, + "readOnly": true, + "title": "Links", + "type": "array" + }, + "offset": { + "format": "int64", + "readOnly": true, + "title": "Query Offset", + "type": "integer" + }, + "totalResults": { + "format": "int64", + "readOnly": true, + "title": "Total Results", + "type": "integer" + } + }, + "type": "object" + }, + "nsError": { + "properties": { + "o-errorDetails": { + "description": "An array containing one or more problem types.", + "items": { + "properties": { + "detail": { + "description": "A detailed, human-readable description of the problem occurrence.", + "readOnly": true, + "title": "Detail", + "type": "string" + }, + "o-errorCode": { + "description": "The application-specific error code. Similar problem types are grouped together.", + "readOnly": true, + "title": "Error Code", + "type": "string" + }, + "o-errorHeader": { + "description": "The name of the HTTP header where the problem occurs.", + "readOnly": true, + "title": "Error Header", + "type": "string" + }, + "o-errorPath": { + "description": "The JSON path that indicates where the problem occurs within the request body.", + "format": "JSONPath", + "readOnly": true, + "title": "Error Path", + "type": "string" + }, + "o-errorQueryParam": { + "description": "The name of the query parameter where the problem occurs.", + "readOnly": true, + "title": "Error Query Parameter", + "type": "string" + }, + "o-errorUrl": { + "description": "The URI of the first element in the request URL where the problem occurs.", + "format": "URI", + "readOnly": true, + "title": "Error URL", + "type": "string" + } + }, + "type": "object" + }, + "readOnly": true, + "type": "array" + }, + "status": { + "description": "The HTTP status code generated by the server the request originates from.", + "format": "int32", + "readOnly": true, + "title": "Status", + "type": "integer" + }, + "title": { + "description": "A human-readable description of the problem type.", + "readOnly": true, + "title": "Title", + "type": "string" + }, + "type": { + "description": "A URI reference to the documentation about the problem type.", + "format": "URI", + "readOnly": true, + "title": "Type", + "type": "string" + } + }, + "type": "object" + }, + "nsLink": { + "properties": { + "href": { + "readOnly": true, + "title": "Hypertext Reference", + "type": "string" + }, + "rel": { + "readOnly": true, + "title": "Relationship", + "type": "string" + } + }, + "type": "object" + } + } + }, + "info": { + "description": "Reconstructed from Oracle's official REST API Browser (system.netsuite.com, Record API 2025.1).", + "title": "NetSuite", + "version": "2025.1" + }, + "openapi": "3.0.3", + "paths": { + "/currency": { + "get": { + "operationId": "currency-get", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "The search query that is used to filter results.", + "in": "query", + "name": "q", + "schema": { + "type": "string" + } + }, + { + "description": "The limit used to specify the number of results on a single page.", + "in": "query", + "name": "limit", + "schema": { + "format": "int32", + "type": "integer" + } + }, + { + "description": "The offset used for selecting a specific page of results.", + "in": "query", + "name": "offset", + "schema": { + "format": "int32", + "type": "integer" + } + } + ], + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/currencyCollection" + } + } + }, + "description": "List of records." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Get list of records.", + "tags": [ + "currency" + ] + }, + "post": { + "operationId": "currency-post", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "The names of sublists on this record. All sublist lines will be replaced with lines specified in the request. The names are delimited by comma.", + "in": "query", + "name": "replace", + "schema": { + "type": "string" + } + }, + { + "description": "Sets the strictness of property name validation.", + "in": "header", + "name": "X-NetSuite-PropertyNameValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + }, + { + "description": "Sets the strictness of property value validation.", + "in": "header", + "name": "X-NetSuite-PropertyValueValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + } + ], + "requestBody": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/currency" + } + } + }, + "required": true + }, + "responses": { + "204": { + "description": "Inserted record." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Insert record.", + "tags": [ + "currency" + ] + } + }, + "/currency/{id}": { + "delete": { + "operationId": "currency-id-delete", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "Internal identifier.", + "in": "path", + "name": "id", + "required": true, + "schema": { + "format": "int32", + "type": "integer" + } + } + ], + "responses": { + "204": { + "description": "Removed record." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Remove record.", + "tags": [ + "currency" + ] + }, + "get": { + "operationId": "currency-id-get", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "Internal identifier.", + "in": "path", + "name": "id", + "required": true, + "schema": { + "format": "int32", + "type": "integer" + } + }, + { + "description": "Set to 'true' to automatically expand all sublists, sublist lines, and subrecords on this record.", + "in": "query", + "name": "expandSubResources", + "schema": { + "type": "boolean" + } + }, + { + "description": "Set to true to return enumeration values in a format that only shows the internal ID value.", + "in": "query", + "name": "simpleEnumFormat", + "schema": { + "type": "boolean" + } + }, + { + "description": "The names of the fields and sublists on the record. Only the selected fields and sublists will be returned in the response.", + "in": "query", + "name": "fields", + "schema": { + "type": "string" + } + } + ], + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/currency" + } + } + }, + "description": "Retrieved record." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Get record.", + "tags": [ + "currency" + ] + }, + "patch": { + "operationId": "currency-id-patch", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "Internal identifier.", + "in": "path", + "name": "id", + "required": true, + "schema": { + "format": "int32", + "type": "integer" + } + }, + { + "description": "Sets the strictness of property name validation.", + "in": "header", + "name": "X-NetSuite-PropertyNameValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + }, + { + "description": "Sets the strictness of property value validation.", + "in": "header", + "name": "X-NetSuite-PropertyValueValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + }, + { + "description": "The names of sublists on this record. All sublist lines will be replaced with lines specified in the request. The names are delimited by comma.", + "in": "query", + "name": "replace", + "schema": { + "type": "string" + } + }, + { + "description": "If set to 'true', all fields that should be deleted in the update request, including body fields, must be included in the 'replace' query parameter.", + "in": "query", + "name": "replaceSelectedFields", + "schema": { + "type": "boolean" + } + } + ], + "requestBody": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/currency" + } + } + }, + "required": true + }, + "responses": { + "204": { + "description": "Updated record." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Update record.", + "tags": [ + "currency" + ] + }, + "put": { + "operationId": "currency-id-put", + "parameters": [ + { + "description": "The server behavior requested by the client. Use 'respond-async' to execute the request asynchronously. If the request is executed asynchronously, 'Preference-applied: respond-async' is returned in the response.", + "in": "header", + "name": "Prefer", + "schema": { + "enum": [ + "respond-async" + ], + "type": "string" + } + }, + { + "description": "A user-defined unique idempotency key that is applied to every asynchronous requests to ensure that the request is executed only once. Only one request can be executed with every unique idempotency key. Use UUID in string format as defined by RFC 4122. If the request is executed synchronously, this value is ignored.", + "in": "header", + "name": "X-NetSuite-Idempotency-Key", + "schema": { + "type": "string" + } + }, + { + "description": "External identifier.", + "in": "path", + "name": "id", + "required": true, + "schema": { + "type": "string" + } + }, + { + "description": "Sets the strictness of property name validation.", + "in": "header", + "name": "X-NetSuite-PropertyNameValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + }, + { + "description": "Sets the strictness of property value validation.", + "in": "header", + "name": "X-NetSuite-PropertyValueValidation", + "schema": { + "enum": [ + "Error", + "Warning", + "Ignore" + ], + "type": "string" + } + }, + { + "description": "The names of sublists on this record. All sublist lines will be replaced with lines specified in the request. The names are delimited by comma.", + "in": "query", + "name": "replace", + "schema": { + "type": "string" + } + }, + { + "description": "If set to 'true', all fields that should be deleted in the update request, including body fields, must be included in the 'replace' query parameter.", + "in": "query", + "name": "replaceSelectedFields", + "schema": { + "type": "boolean" + } + } + ], + "requestBody": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/currency" + } + } + }, + "required": true + }, + "responses": { + "204": { + "description": "Upserted record." + }, + "default": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/nsError" + } + } + }, + "description": "Error response." + } + }, + "summary": "Insert or update record.", + "tags": [ + "currency" + ] + } + } + } +} \ No newline at end of file diff --git a/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/ns-currency-slice-models.cabal b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/ns-currency-slice-models.cabal new file mode 100644 index 0000000..78e40fe --- /dev/null +++ b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/ns-currency-slice-models.cabal @@ -0,0 +1,23 @@ +cabal-version: 3.0 +name: ns-currency-slice-models +version: 0.1.0.0 +synopsis: Generated webapi contract (openapi-model-generator) +author: "Pankaj Singh Sijwali" +maintainer: pankajsijwali1@gmail.com +build-type: Simple + +library + exposed-modules: OpenApiModels, WebApiInstances + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base, text, vector, aeson, webapi-contract + +-- the concrete registry (M9): the instance layer + registrations +-- a connector mounts; kept a sublibrary so the contract itself +-- stays free of the executor's closure +library registry + visibility: public + exposed-modules: ConcreteRegistry + hs-source-dirs: src-registry + default-language: Haskell2010 + build-depends: base, text, vector, aeson, webapi-contract, ns-currency-slice-models, uuid-types, webapi-session, dhall, dhall-do-api, dhall-do-api-webapi diff --git a/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src-registry/ConcreteRegistry.hs b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src-registry/ConcreteRegistry.hs new file mode 100644 index 0000000..da3e381 --- /dev/null +++ b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src-registry/ConcreteRegistry.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- Generated by openapi-model-generator: the concrete registry for NetSuite. +module ConcreteRegistry (netsuiteConcreteOps) where + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.UUID.Types as UUID +import GHC.Stack (HasCallStack) + +import WebApi.Client.Session (AppIsElem, getSuccessOut) +import WebApi.Contract hiding (OperationId) + +import Data.Vector (Vector) + +import Dhall.Do.Api.Bridge +import Dhall.Do.Api.Id (FQN (..), OperationId, mkOperationId) +import Dhall.Do.Api.WebApi.Concrete.Binding + +import OpenApiModels +import WebApiInstances + +instance HsType Currency +instance ToHsVal Currency +instance FromHsVal Currency +instance OverrideType Currency +instance HsSelect Currency + +instance HsType CurrencyCollection +instance ToHsVal CurrencyCollection +instance FromHsVal CurrencyCollection +instance HsSelect CurrencyCollection + +instance HsType GetCurrencyQP +instance ToHsVal GetCurrencyQP +instance FromHsVal GetCurrencyQP +instance OverrideType GetCurrencyQP + +instance HsType ListCurrenciesQP +instance ToHsVal ListCurrenciesQP +instance FromHsVal ListCurrenciesQP +instance OverrideType ListCurrenciesQP + +instance HsType NsError +instance ToHsVal NsError +instance FromHsVal NsError +instance HsSelect NsError +instance ErrorText NsError + +instance HsType NsLink +instance ToHsVal NsLink +instance FromHsVal NsLink + +instance HsType NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode +instance ToHsVal NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode +instance FromHsVal NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode + +instance HsType NsObjRefNameId +instance ToHsVal NsObjRefNameId +instance FromHsVal NsObjRefNameId + +instance HsType PatchCurrencyQP +instance ToHsVal PatchCurrencyQP +instance FromHsVal PatchCurrencyQP +instance OverrideType PatchCurrencyQP + +instance HsType PostCurrencyQP +instance ToHsVal PostCurrencyQP +instance FromHsVal PostCurrencyQP +instance OverrideType PostCurrencyQP + +instance HsType PutCurrencyQP +instance ToHsVal PutCurrencyQP +instance FromHsVal PutCurrencyQP +instance OverrideType PutCurrencyQP + +_unusedVectorAnchor :: Maybe (Vector ()) +_unusedVectorAnchor = Nothing + +opIdOf :: (HasCallStack) => Text -> OperationId +opIdOf t = mkOperationId (fromMaybe (error ("bad uuid literal: " <> T.unpack t)) (UUID.fromText t)) + +mkFqn :: Text -> FQN +mkFqn n = FQN{qualifier = "netsuite" :| [], name = n} + +netsuiteConcreteOps :: forall apps. (AppIsElem NetSuite apps) => ConcreteActions apps -> ConcreteActions apps +netsuiteConcreteOps = + addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000002") (mkFqn "getCurrency") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "one currency by internal id (request.path)"} :: ConcreteBinding apps GET NetSuite CurrencyGETRPath (Currency))) + . addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000004") (mkFqn "putCurrency") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "upsert a currency by external id (request.path)", cbRequest = setBody (setField @"links" (Const (mempty :: Vector NsLink)) unsetRecord) (emptyRequest)} :: ConcreteBinding apps PUT NetSuite CurrencyPUTRPath (NsError))) + . addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000006") (mkFqn "deleteCurrency") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "remove a currency by internal id (request.path)"} :: ConcreteBinding apps DELETE NetSuite CurrencyDELETERPath (NsError))) + . addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000005") (mkFqn "patchCurrency") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "update a currency by internal id (request.path)", cbRequest = setBody (setField @"links" (Const (mempty :: Vector NsLink)) unsetRecord) (emptyRequest)} :: ConcreteBinding apps PATCH NetSuite CurrencyPATCHRPath (NsError))) + . addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000001") (mkFqn "listCurrencies") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "the currencies as NetSuite lists them"} :: ConcreteBinding apps GET NetSuite CurrencyRPath (CurrencyCollection))) + . addConcreteOp (opIdOf "0d1e2f30-1111-4a01-8001-000000000003") (mkFqn "postCurrency") (ConcreteOp ((concreteBinding (Right . getSuccessOut)){cbSummary = Just "insert a currency (the body names it)", cbRequest = setBody (setField @"links" (Const (mempty :: Vector NsLink)) unsetRecord) (emptyRequest)} :: ConcreteBinding apps POST NetSuite CurrencyRPath (NsError))) diff --git a/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/OpenApiModels.hs b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/OpenApiModels.hs new file mode 100644 index 0000000..9fda97d --- /dev/null +++ b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/OpenApiModels.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module OpenApiModels where + +import Control.Applicative +import Data.Aeson +import Data.Int +import Data.Text (Text) +import Data.Vector as V +import GHC.Generics (Generic) + +data CurrencyCollection + = CurrencyCollection + { offset :: (Maybe Int64) + , totalResults :: (Maybe Int64) + , links :: (Vector NsLink) + , count :: (Maybe Int64) + , hasMore :: (Maybe Bool) + , items :: (Vector Currency) + } + deriving (Show, Eq, Generic) +instance FromJSON CurrencyCollection where + parseJSON = + withObject "CurrencyCollection" + $ ( \v -> + ( ( ( ( (CurrencyCollection <$> (v .:? "offset")) + <*> (v .:? "totalResults") + ) + <*> ((v .:? "links") .!= V.empty) + ) + <*> (v .:? "count") + ) + <*> (v .:? "hasMore") + ) + <*> ((v .:? "items") .!= V.empty) + ) +instance ToJSON CurrencyCollection where + toJSON + (CurrencyCollection offset totalResults links count hasMore items) = + object + [ "offset" .= offset + , "totalResults" .= totalResults + , "links" .= links + , "count" .= count + , "hasMore" .= hasMore + , "items" .= items + ] +data NsLink + = NsLink {href :: (Maybe Text), rel :: (Maybe Text)} + deriving (Show, Eq, Generic) +instance FromJSON NsLink where + parseJSON = + withObject "NsLink" + $ (\v -> (NsLink <$> (v .:? "href")) <*> (v .:? "rel")) +instance ToJSON NsLink where + toJSON (NsLink href rel) = object ["href" .= href, "rel" .= rel] +data NsObjRefNameId + = NsObjRefNameId {refName :: (Maybe Text), id :: (Maybe Text)} + deriving (Show, Eq, Generic) +data Currency + = Currency + { lastModifiedDate :: (Maybe Text) + , refName :: (Maybe Text) + , exchangeRate :: (Maybe Double) + , id :: (Maybe Text) + , isAnchorCurrency :: (Maybe Bool) + , links :: (Vector NsLink) + , symbol :: (Maybe Text) + , locale :: (Maybe NsObjRefNameId) + , includeInFxRateUpdates :: (Maybe Bool) + , displaySymbol :: (Maybe Text) + , symbolPlacement :: (Maybe NsObjRefNameId) + , name :: (Maybe Text) + , overrideCurrencyFormat :: (Maybe Bool) + , currencyPrecision :: (Maybe Int64) + , fxRateUpdateTimezone :: (Maybe NsObjRefNameId) + , isInactive :: (Maybe Bool) + , formatSample :: (Maybe Text) + , externalId :: (Maybe Text) + , isBaseCurrency :: (Maybe Bool) + } + deriving (Show, Eq, Generic) +instance FromJSON NsObjRefNameId where + parseJSON = + withObject "NsObjRefNameId" + $ (\v -> (NsObjRefNameId <$> (v .:? "refName")) <*> (v .:? "id")) +instance ToJSON NsObjRefNameId where + toJSON (NsObjRefNameId refName id) = + object ["refName" .= refName, "id" .= id] +instance FromJSON Currency where + parseJSON = + withObject "Currency" + $ ( \v -> + ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( ( (Currency <$> (v .:? "lastModifiedDate")) + <*> (v .:? "refName") + ) + <*> (v .:? "exchangeRate") + ) + <*> (v .:? "id") + ) + <*> (v .:? "isAnchorCurrency") + ) + <*> ((v .:? "links") .!= V.empty) + ) + <*> (v .:? "symbol") + ) + <*> (v .:? "locale") + ) + <*> (v .:? "includeInFxRateUpdates") + ) + <*> (v .:? "displaySymbol") + ) + <*> (v .:? "symbolPlacement") + ) + <*> (v .:? "name") + ) + <*> (v .:? "overrideCurrencyFormat") + ) + <*> (v .:? "currencyPrecision") + ) + <*> (v .:? "fxRateUpdateTimezone") + ) + <*> (v .:? "isInactive") + ) + <*> (v .:? "formatSample") + ) + <*> (v .:? "externalId") + ) + <*> (v .:? "isBaseCurrency") + ) +instance ToJSON Currency where + toJSON + ( Currency + lastModifiedDate + refName + exchangeRate + id + isAnchorCurrency + links + symbol + locale + includeInFxRateUpdates + displaySymbol + symbolPlacement + name + overrideCurrencyFormat + currencyPrecision + fxRateUpdateTimezone + isInactive + formatSample + externalId + isBaseCurrency + ) = + object + [ "lastModifiedDate" .= lastModifiedDate + , "refName" .= refName + , "exchangeRate" .= exchangeRate + , "id" .= id + , "isAnchorCurrency" .= isAnchorCurrency + , "links" .= links + , "symbol" .= symbol + , "locale" .= locale + , "includeInFxRateUpdates" .= includeInFxRateUpdates + , "displaySymbol" .= displaySymbol + , "symbolPlacement" .= symbolPlacement + , "name" .= name + , "overrideCurrencyFormat" .= overrideCurrencyFormat + , "currencyPrecision" .= currencyPrecision + , "fxRateUpdateTimezone" .= fxRateUpdateTimezone + , "isInactive" .= isInactive + , "formatSample" .= formatSample + , "externalId" .= externalId + , "isBaseCurrency" .= isBaseCurrency + ] +data NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode + = NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode + { oErrorPath :: (Maybe Text) + , detail :: (Maybe Text) + , oErrorQueryParam :: (Maybe Text) + , oErrorHeader :: (Maybe Text) + , oErrorUrl :: (Maybe Text) + , oErrorCode :: (Maybe Text) + } + deriving (Show, Eq, Generic) +data NsError + = NsError + { status :: (Maybe Int32) + , type_ :: (Maybe Text) + , oErrorDetails :: (Vector NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode) + , title :: (Maybe Text) + } + deriving (Show, Eq, Generic) +instance FromJSON NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode where + parseJSON = + withObject + "NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode" + $ ( \v -> + ( ( ( ( ( NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode + <$> (v .:? "o-errorPath") + ) + <*> (v .:? "detail") + ) + <*> (v .:? "o-errorQueryParam") + ) + <*> (v .:? "o-errorHeader") + ) + <*> (v .:? "o-errorUrl") + ) + <*> (v .:? "o-errorCode") + ) +instance ToJSON NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode where + toJSON + ( NsObjOErrorPathDetailOErrorQueryParamOErrorHeaderOErrorUrlOErrorCode + oErrorPath + detail + oErrorQueryParam + oErrorHeader + oErrorUrl + oErrorCode + ) = + object + [ "o-errorPath" .= oErrorPath + , "detail" .= detail + , "o-errorQueryParam" .= oErrorQueryParam + , "o-errorHeader" .= oErrorHeader + , "o-errorUrl" .= oErrorUrl + , "o-errorCode" .= oErrorCode + ] +instance FromJSON NsError where + parseJSON = + withObject "NsError" + $ ( \v -> + ( ((NsError <$> (v .:? "status")) <*> (v .:? "type")) + <*> ((v .:? "o-errorDetails") .!= V.empty) + ) + <*> (v .:? "title") + ) +instance ToJSON NsError where + toJSON (NsError status type_ oErrorDetails title) = + object + [ "status" .= status + , "type" .= type_ + , "o-errorDetails" .= oErrorDetails + , "title" .= title + ] diff --git a/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/WebApiInstances.hs b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/WebApiInstances.hs new file mode 100644 index 0000000..bb05199 --- /dev/null +++ b/webapi-openapi/test/golden/ns-currency/ns-currency-slice-models/src/WebApiInstances.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module WebApiInstances where + +import Control.Applicative +import Data.Aeson +import Data.Int +import Data.Text (Text) +import Data.Vector as V +import GHC.Generics (Generic) +import OpenApiModels +import WebApi.Contract +import WebApi.Param + +data Untyped = Maybe Text +type CurrencyGETR = NetSuite :// ("currency" :/ Int32) +type CurrencyGETRPath = "currency" :/ Int32 +type CurrencyPUTR = NetSuite :// ("currency" :/ Text) +type CurrencyPUTRPath = "currency" :/ Text +type CurrencyDELETER = NetSuite :// ("currency" :/ Int32) +type CurrencyDELETERPath = "currency" :/ Int32 +type CurrencyPATCHR = NetSuite :// ("currency" :/ Int32) +type CurrencyPATCHRPath = "currency" :/ Int32 +data GetCurrencyQP + = GetCurrencyQP + { expandSubResources :: (Maybe Bool) + , fields :: (Maybe Text) + , simpleEnumFormat :: (Maybe Bool) + } + deriving (Show, Eq, Generic) +data PutCurrencyQP + = PutCurrencyQP + { replaceSelectedFields :: (Maybe Bool) + , replace :: (Maybe Text) + } + deriving (Show, Eq, Generic) +data PatchCurrencyQP + = PatchCurrencyQP + { replaceSelectedFields :: (Maybe Bool) + , replace :: (Maybe Text) + } + deriving (Show, Eq, Generic) +type CurrencyR = NetSuite :// "currency" +type CurrencyRPath = "currency" +data ListCurrenciesQP + = ListCurrenciesQP + { offset :: (Maybe Int32) + , limit :: (Maybe Int32) + , q :: (Maybe Text) + } + deriving (Show, Eq, Generic) +data PostCurrencyQP + = PostCurrencyQP {replace :: (Maybe Text)} + deriving (Show, Eq, Generic) +data NetSuite +instance WebApi NetSuite where + type + Apis NetSuite = + '[ Route '[GET] CurrencyGETR + , Route '[PUT] CurrencyPUTR + , Route '[DELETE] CurrencyDELETER + , Route '[PATCH] CurrencyPATCHR + , Route '[GET, POST] CurrencyR + ] +instance ApiContract NetSuite GET CurrencyGETR where + type OperationId GET CurrencyGETR = 'OpId NetSuite "getCurrency" + type QueryParam GET CurrencyGETR = GetCurrencyQP + type ApiOut GET CurrencyGETR = Currency + type ApiErr GET CurrencyGETR = NsError +instance ApiContract NetSuite PUT CurrencyPUTR where + type OperationId PUT CurrencyPUTR = 'OpId NetSuite "putCurrency" + type QueryParam PUT CurrencyPUTR = PutCurrencyQP + type RequestBody PUT CurrencyPUTR = '[Currency] + type ApiOut PUT CurrencyPUTR = NsError + type ApiErr PUT CurrencyPUTR = NsError +instance ApiContract NetSuite DELETE CurrencyDELETER where + type OperationId DELETE CurrencyDELETER = 'OpId NetSuite "deleteCurrency" + type ApiOut DELETE CurrencyDELETER = NsError + type ApiErr DELETE CurrencyDELETER = NsError +instance ApiContract NetSuite PATCH CurrencyPATCHR where + type OperationId PATCH CurrencyPATCHR = 'OpId NetSuite "patchCurrency" + type QueryParam PATCH CurrencyPATCHR = PatchCurrencyQP + type RequestBody PATCH CurrencyPATCHR = '[Currency] + type ApiOut PATCH CurrencyPATCHR = NsError + type ApiErr PATCH CurrencyPATCHR = NsError +instance ApiContract NetSuite GET CurrencyR where + type OperationId GET CurrencyR = 'OpId NetSuite "listCurrencies" + type QueryParam GET CurrencyR = ListCurrenciesQP + type ApiOut GET CurrencyR = CurrencyCollection + type ApiErr GET CurrencyR = NsError +instance ApiContract NetSuite POST CurrencyR where + type OperationId POST CurrencyR = 'OpId NetSuite "postCurrency" + type QueryParam POST CurrencyR = PostCurrencyQP + type RequestBody POST CurrencyR = '[Currency] + type ApiOut POST CurrencyR = NsError + type ApiErr POST CurrencyR = NsError +instance ToParam 'QueryParam GetCurrencyQP +instance FromParam 'QueryParam GetCurrencyQP +instance ToParam 'QueryParam PutCurrencyQP +instance FromParam 'QueryParam PutCurrencyQP +instance ToParam 'QueryParam PatchCurrencyQP +instance FromParam 'QueryParam PatchCurrencyQP +instance ToParam 'QueryParam ListCurrenciesQP +instance FromParam 'QueryParam ListCurrenciesQP +instance ToParam 'QueryParam PostCurrencyQP +instance FromParam 'QueryParam PostCurrencyQP diff --git a/webapi-openapi/webapi-openapi.cabal b/webapi-openapi/webapi-openapi.cabal index c5bf921..18ddb43 100644 --- a/webapi-openapi/webapi-openapi.cabal +++ b/webapi-openapi/webapi-openapi.cabal @@ -18,6 +18,7 @@ source-repository head library exposed-modules: WebApi.OpenAPI + WebApi.OpenAPI.Modular hs-source-dirs: src build-depends: @@ -55,4 +56,20 @@ executable openapi-model-generator , unordered-containers default-language: Haskell2010 - ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N \ No newline at end of file + ghc-options: -Wall -Werror -O2 -threaded -rtsopts -with-rtsopts=-N + +-- Golden output: the generator over test/fixtures, compared file by file +-- with test/golden (GOLDEN_ACCEPT=1 rewrites them). Run from this directory. +test-suite golden + type: exitcode-stdio-1.0 + main-is: Golden.hs + hs-source-dirs: test + build-depends: base >= 4.9 && < 5 + , webapi-openapi + , aeson + , bytestring + , directory + , filepath + , unordered-containers + default-language: Haskell2010 + ghc-options: -Wall -Werror \ No newline at end of file