graphql-w-persistent 0.6.0.0 → 0.7.0.0
raw patch · 12 files changed
+541/−309 lines, 12 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- GraphQLdbi: EOFDataProcessingException :: QueryException
+ GraphQLdbi: EOFDataProcessingException1 :: QueryException
+ GraphQLdbi: EOFDataProcessingException2 :: QueryException
+ GraphQLdbi: EOFDataProcessingException3 :: QueryException
+ GraphQLdbi: EOFDataProcessingException4 :: QueryException
+ GraphQLdbi: EOFDataProcessingException5 :: QueryException
+ GraphQLdbi: EOFDataProcessingException6 :: QueryException
+ GraphQLdbi: EOFDataProcessingException7 :: QueryException
+ GraphQLdbi: EOFDataProcessingException8 :: QueryException
+ GraphQLdbi: EOFDataProcessingException9 :: QueryException
Files
- ChangeLog.md +4/−0
- graphql-w-persistent.cabal +1/−1
- src/Components/DataProcessors/ListDataProcessor.hs +59/−35
- src/Components/ObjectHandlers/ObjectsHandler.hs +35/−21
- src/Components/ObjectHandlers/ServerObjectValidator.hs +14/−15
- src/Components/Parsers/QueryParser.hs +101/−91
- src/Components/Parsers/ServerSchemaJsonParser.hs +41/−30
- src/Components/Parsers/VariablesParser.hs +2/−4
- src/Components/QueryComposers/SQLQueryComposer.hs +17/−12
- src/GraphQLdbi.hs +253/−97
- src/Model/ServerExceptions.hs +9/−1
- src/Model/ServerObjectTypes.hs +5/−2
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for graphql-w-persistent +## 0.7.0.0 -- 2019-11-16 + +* fix comma and tab problems in query, allow personalized unique ids, and allow per-object nested-object field names + ## 0.6.0.0 -- 2019-08-31 * reduce computations, fix bug on variables to parent object arguments, fix bug when querying parental objects, add scalar argument feature
graphql-w-persistent.cabal view
@@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.0.0 +version: 0.7.0.0 -- A short (one-line) description of the package. synopsis: GraphQL interface middleware for (SQL) databases.
src/Components/DataProcessors/ListDataProcessor.hs view
@@ -3,13 +3,21 @@ import Data.Text (Text,unpack,pack) import Text.JSON (showJSON,showJSONs,JSValue,JSObject,toJSObject,encodeStrict) import Control.Exception (throw) -import Data.List (foldl') +import Data.Foldable (foldl',foldr') import Model.ServerExceptions ( QueryException( InvalidObjectException, InvalidScalarException, InvalidArgumentException, - EOFDataProcessingException, + EOFDataProcessingException1, + EOFDataProcessingException2, + EOFDataProcessingException3, + EOFDataProcessingException4, + EOFDataProcessingException5, + EOFDataProcessingException6, + EOFDataProcessingException7, + EOFDataProcessingException8, + EOFDataProcessingException9, InvalidVariableTypeException ) ) @@ -27,55 +35,58 @@ isServerObjectTable, getNestedObjectFieldLabel, getScalarFieldLabel, - translateTableToObject + translateTableToObject, + countTableIds ) -- with root objects we want one json representation of separate graphql results... -processReturnedValues :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> String +processReturnedValues :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> String processReturnedValues sss sodn soa robjs tbls rlts = encodeStrict $ processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts -processReturnedValuesToJsonObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> JSObject (JSObject JSValue) +processReturnedValuesToJsonObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> JSObject (JSObject JSValue) processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts = toJSObject [("data", toJSObject [processReturnedValue sss sodn soa x y z | (x,y,z) <- zip3 robjs tbls rlts])] -- with qraphql query object and sql return data, we want json representation on graphql query results... -processReturnedValue :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> RootObject -> [[String]] -> [[[Text]]] -> (String, JSValue) +processReturnedValue :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> RootObject -> [[String]] -> [[[Text]]] -> (String, JSValue) processReturnedValue sss sodn soa (NestedObject Nothing name sobj _ sfs) tbls rlts = (name, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts) processReturnedValue sss sodn soa (NestedObject (Just alias) name sobj _ sfs) tbls rlts = (alias, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts) -- with SubFields and data rows, we want json representation on qraphql query data -processSubFields :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [JSValue] +processSubFields :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [JSValue] processSubFields _ _ _ _ _ _ [] = [] processSubFields _ _ _ _ _ [] _ = [] -- are the query results from unique objects to make separate objects -- assume that if last table is same, fetchNextRow is same object instance processSubFields sss sodn soa sobj tbls sfs rlts - | (null $ foldr (++) [] rlts)==True = [] - | sameTables&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts]) - | sameTables = processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts] - | otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts]) + | (null $ foldl' (++) [] rlts)==True = [] + | sameTables&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls sfs remData) + | sameTables = processSubFields sss sodn soa sobj tbls sfs remData + | otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls sfs remData) where - sameTables = foldl' (\y x->(last x)==(last $ head tbls)&&y) True tbls - object = makeOneGQLObject sss sodn soa sobj tbls sfs [fetchGraphQlRow x | x<-rlts] + sameTables = foldr' (\x y->(last x)==(last $ head tbls)&&y) True tbls + object = makeOneGQLObject sss sodn soa sobj tbls sfs [fetchGraphQlRow x idC | (idC, x)<-zip idCounts rlts] -- different tables is possibly different result rows. I should not assume that they are same. - notEmptyQueryResults = [(x,y) | (x,y)<-zip tbls rlts, null y==False] + notEmptyQueryResults = [(x,y,z) | (x,y,z)<-zip3 tbls rlts idCounts, null y==False] -- assume tbls are segmented from last table -- groupedData :: [[([String],[[Text]])]] - groupedData = foldr (\(x,y) z -> if (null z)==True then [[(x,y)]] else if (last x)==(last $ fst $ head $ head z) then (((x,y):(head z)):(tail z)) else ([(x,y)]:z)) [] $ [(x,fetchGraphQlRow y) | (x,y)<-notEmptyQueryResults] + groupedData = foldr (\(x,y) z -> if (null z)==True then [[(x,y)]] else if (last x)==(last $ fst $ head $ head z) then (((x,y):(head z)):(tail z)) else ([(x,y)]:z)) [] $ [(x,fetchGraphQlRow y z) | (x,y,z)<-notEmptyQueryResults] labeledData = [unzip x | x<-groupedData] objects = foldr (\(x,y) z -> (makeOneGQLObject sss sodn soa sobj x sfs y):z) [] labeledData + remData = [removeDataRow x idC | (idC, x)<-zip idCounts rlts] + idCounts = [countTableIds (last tbl) sodn | tbl<-tbls] -- assume all last elements are same in tbls -- assume all instances (ist) are same -makeOneGQLObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [(String,JSValue)] +makeOneGQLObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [(String,JSValue)] makeOneGQLObject _ _ _ _ _ [] (([]:_):_) = [] -- done makeOneGQLObject _ _ _ _ _ _ ([]:_) = [] -- no column data makeOneGQLObject _ _ _ _ _ _ [] = [] -- no queries (unusual) -makeOneGQLObject _ _ _ _ _ [] _ = throw EOFDataProcessingException -- columns and no fields -makeOneGQLObject _ _ _ _ [] _ _ = throw EOFDataProcessingException -- no reference tables (unusual) +makeOneGQLObject _ _ _ _ _ [] _ = throw EOFDataProcessingException1 -- columns and no fields +makeOneGQLObject _ _ _ _ [] _ _ = throw EOFDataProcessingException2 -- no reference tables (unusual) makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias "__typename" trans arg)):[]) (([]:_):_) = (getScalarFieldLabel $ ScalarType alias "__typename" trans arg, showJSON $ pack $ translateTableToObject (last $ head $ tbls) sodn):[] -- field and no result columns -- makeOneGQLObject _ _ _ _ _ ((Left _):[]) (([]:_):_) = [] -- field and no result columns (unusual) -- makeOneGQLObject _ _ _ _ _ ((Right (Left _)):[]) (([]:_):_) = [] -- field and no result columns (unusual) makeOneGQLObject sss sodn soa _ tbls (Right (Right (InlinefragmentObject ifo sfs)):[]) (([]:_):_) | (isServerObjectTable (last $ head tbls) ifo sodn soa)==False = [] -- field and no result columns -makeOneGQLObject _ _ _ _ _ (_:[]) (([]:_):_) = throw EOFDataProcessingException -- field and no result columns -makeOneGQLObject _ _ _ _ _ _ (([]:_):_) = throw EOFDataProcessingException -- fields and no result columns +makeOneGQLObject _ _ _ _ _ (_:[]) (([]:_):_) = throw EOFDataProcessingException3 -- field and no result columns +makeOneGQLObject _ _ _ _ _ _ (([]:_):_) = throw EOFDataProcessingException4 -- fields and no result columns makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias "__typename" trans arg)):b) (((i:j):k):l) = (getScalarFieldLabel $ ScalarType alias "__typename" trans arg, showJSON $ pack $ translateTableToObject (last $ head $ tbls) sodn):(makeOneGQLObject sss sodn soa sobj tbls b (((i:j):k):l)) -- (((:fld):ist):qry) makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias name trans arg)):b) (((i:j):k):l) = (getScalarFieldLabel $ ScalarType alias name trans arg, castJSType (findPrimitiveScalarTypeType (translateTableToObject (last $ head tbls) sodn) name trans arg sss) i):(makeOneGQLObject sss sodn soa sobj tbls b [removeNDataColumns 1 x | x<-(((i:j):k):l)]) makeOneGQLObject sss sodn soa sobj tbls ((Right (Left (NestedObject alias name nso ss sfs))):b) (((i:j):k):l) = ((getNestedObjectFieldLabel $ NestedObject alias name nso ss sfs), showJSONs (processSubFields sss sodn soa nso nxtTbls sfs [pullNDataColumns x y | (x,y)<-zip nestedObjectFieldCounts (((i:j):k):l)])):(makeOneGQLObject sss sodn soa sobj [updateTables (countNOTables sodn soa (NestedObject alias name nso ss sfs) x) x | x<-tbls] b [removeNDataColumns x y | (x,y)<-zip nestedObjectFieldCounts (((i:j):k):l)]) @@ -116,23 +127,36 @@ | arg==oname = typ | otherwise = findOptionType arg rst -fetchGraphQlRow :: [[Text]] -> [[Text]] -fetchGraphQlRow rlts = if (head $ head rlts)==(pack "Unexpected null") then [] else [t | (h:t)<-rlts, h==(head $ head rlts)] -removeDataRow :: [[Text]] -> [[Text]] -removeDataRow rlts = [x | x<-rlts, (head x)/=(head $ head rlts)] +fetchGraphQlRow :: [[Text]] -> Int -> [[Text]] +fetchGraphQlRow rlts idRows = if (all ((==) (pack "Unexpected null")) + firstIds) then [] else + [drop idRows rltRow | rltRow<-rlts, + (take idRows rltRow)==firstIds] + where + firstIds = take idRows $ head rlts +removeDataRow :: [[Text]] -> Int -> [[Text]] +removeDataRow rlts idRows = [rltRow | rltRow<-rlts, + (take idRows rltRow)/=(take idRows $ head rlts)] pullNDataColumns :: Int -> [[Text]] -> [[Text]] pullNDataColumns _ [] = [] pullNDataColumns cnt rslt | (cnt<0) = throw InvalidArgumentException - | otherwise = [if (length x)<cnt then throw EOFDataProcessingException else take cnt x | x<-rslt] + | otherwise = [if (length x)<cnt then throw EOFDataProcessingException5 else take cnt x | x<-rslt] -- count how many columns are added to sql data result for this nested object including the nested object id -countQueriedSubFields :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int -countQueriedSubFields sodn soa (NestedObject alias name sobj ss sfs) tbls = countQueriedSubFieldsHelper sodn soa sfs tbls 1 -countQueriedSubFieldsHelper :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int +countQueriedSubFields :: [(String,[String],String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int +countQueriedSubFields sodn soa (NestedObject alias name sobj ss sfs) tbls = + countQueriedSubFieldsHelper sodn soa sfs tbls $ + countTableIds (last tbls) sodn +countQueriedSubFieldsHelper :: [(String,[String],String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int countQueriedSubFieldsHelper _ _ [] _ acc = acc countQueriedSubFieldsHelper sodn soa ((Left (ScalarType _ "__typename" _ _)):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls acc countQueriedSubFieldsHelper sodn soa ((Left (ScalarType _ _ _ _)):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls (acc+1) -countQueriedSubFieldsHelper sodn soa ((Right (Left (NestedObject _ _ _ _ sfs))):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls (acc+(countQueriedSubFieldsHelper sodn soa sfs (init tbls) 1)) +countQueriedSubFieldsHelper sodn soa ((Right (Left (NestedObject _ _ _ _ sfs))):t) tbls acc = + countQueriedSubFieldsHelper sodn soa t tbls $ + acc+(countQueriedSubFieldsHelper sodn soa sfs nxtTblSet $ + countTableIds (last nxtTblSet) sodn) + where + nxtTblSet = init tbls countQueriedSubFieldsHelper sodn soa ((Right (Right (InlinefragmentObject ifo sfs))):t) tbls acc | (isServerObjectTable (last tbls) ifo sodn soa)==True = countQueriedSubFieldsHelper sodn soa (sfs++t) tbls acc countQueriedSubFieldsHelper sodn soa (_:t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls acc @@ -140,9 +164,9 @@ -- remove nested object columns from data row that is including nested object id removeNDataColumns :: Int -> [[Text]] -> [[Text]] removeNDataColumns 0 rslt = rslt -removeNDataColumns (-1) _ = throw EOFDataProcessingException -removeNDataColumns _ [[]] = throw EOFDataProcessingException -- [[]] -removeNDataColumns _ ([]:_) = throw EOFDataProcessingException +removeNDataColumns (-1) _ = throw EOFDataProcessingException6 +removeNDataColumns _ [[]] = throw EOFDataProcessingException7 -- [[]] +removeNDataColumns _ ([]:_) = throw EOFDataProcessingException8 removeNDataColumns cnt rslt = removeNDataColumns (cnt-1) [t | (h:t)<-rslt] castJSType :: String -> Text -> JSValue castJSType "Text" val = showJSON val @@ -155,9 +179,9 @@ castJSType "TimeOfDay" val = showJSON val castJSType "UTCTime" val = showJSON val castJSType _ val = throw InvalidVariableTypeException -countNOTables :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int +countNOTables :: [(String,[String],String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int countNOTables sodn soa (NestedObject alias name sobj ss sfs) tbls = countSubfieldsTables sodn soa sfs tbls 1 -countSubfieldsTables :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int +countSubfieldsTables :: [(String,[String],String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int countSubfieldsTables _ _ [] _ acc = acc countSubfieldsTables sodn soa ((Left _):t) tbls acc = countSubfieldsTables sodn soa t tbls acc countSubfieldsTables sodn soa ((Right (Left h)):t) tbls acc = countSubfieldsTables sodn soa t (updateTables foCount tbls) (acc+foCount) @@ -168,7 +192,7 @@ countSubfieldsTables sodn soa (_:t) tbls acc = countSubfieldsTables sodn soa t tbls acc updateTables :: Int -> [String] -> [String] updateTables 0 rlt = rlt -updateTables _ [] = throw EOFDataProcessingException +updateTables _ [] = throw EOFDataProcessingException9 updateTables n lst | n<0 = throw InvalidArgumentException | otherwise = updateTables (n-1) ((init $ init lst)++[last lst])
src/Components/ObjectHandlers/ObjectsHandler.hs view
@@ -2,7 +2,7 @@ import Control.Exception (throw) -import Data.List (foldl') +import Data.Foldable (foldl',foldr') import Model.ServerExceptions ( QueryException( InvalidObjectException, @@ -59,7 +59,7 @@ getIntersection :: Eq a => [[a]] -> [a] getIntersection [] = [] getIntersection ([]:t) = [] -getIntersection ((h:t1):t2) = if foldl' (\y x -> (elem h x)&&y) True t2 then h:getIntersection (t1:t2) else getIntersection (t1:t2) +getIntersection ((h:t1):t2) = if foldr' (\x y -> (elem h x)&&y) True t2 then h:getIntersection (t1:t2) else getIntersection (t1:t2) -- REFERENCE SCHEMA {- @@ -68,8 +68,19 @@ -} readServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject readServerObject _ [] [] = throw InvalidObjectException -readServerObject str ((a,b):t) c = if (elem str b)==True then (a :: ServerObject) else readServerObject str t c -readServerObject str [] ((a,b,_):t) = if (elem str b)==True then (a :: ServerObject) else readServerObject str [] t +readServerObject str ((a,b):t) [] = if (elem str b)==True then (a :: ServerObject) else readServerObject str t [] +readServerObject str ptv ((a,b,_):t) = if (elem str b)==True then (a :: ServerObject) else readServerObject str ptv t +readFieldObject :: String -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> ServerObject -> ServerObject +readFieldObject _ [] [] _ = throw InvalidObjectException +readFieldObject str ptvs ((pObj,_,pCldn):rst) hld = if hld==pObj then + findSingularObject $ foldr (\cld y->(readFieldObject str ptvs [] cld):y) [] pCldn + else readFieldObject str ptvs rst hld +readFieldObject str ((ptv,objs):rst) [] hld = if hld==ptv then + readServerObject str objs [] + else readFieldObject str rst [] hld +findSingularObject :: [String] -> String +findSingularObject [] = throw InvalidObjectException +findSingularObject (fst:rst) = if all ((==) fst) rst then fst else throw InvalidObjectException -- INLINE-FRAGMENTS isSameIFObjectReference :: InlinefragmentObject -> InlinefragmentObject -> Bool isSameIFObjectReference (InlinefragmentObject obj1 _) (InlinefragmentObject obj2 _) = obj1==obj2 @@ -78,11 +89,14 @@ isValidServerObjectChild _ _ [] = False isValidServerObjectChild pnt cld ((so,_,cdn):t) = if pnt==so then elem cld cdn else isValidServerObjectChild pnt cld t -- SCHEMA HEIRARCHY -isServerObjectTable :: String -> ServerObject -> [(String,String)] -> [(String,[String],[String])] -> Bool -isServerObjectTable tbl soj sodn soa = elem tbl $ translateServerObjectToDBName soj sodn soa -translateTableToObject :: String -> [(String,String)] -> String +isServerObjectTable :: String -> ServerObject -> [(String,[String],String)] -> [(String,[String],[String])] -> Bool +isServerObjectTable tbl soj sodn soa = foldr' (\(_,x) y->x==tbl||y) False $ translateServerObjectToDBName soj sodn soa +translateTableToObject :: String -> [(String,[String],String)] -> String translateTableToObject _ [] = throw InvalidObjectException -translateTableToObject tbl ((pObj,pTbl):rst) = if tbl==pTbl then pObj else translateTableToObject tbl rst +translateTableToObject tbl ((pObj,_,pTbl):rst) = if tbl==pTbl then pObj else translateTableToObject tbl rst +countTableIds :: String -> [(String,[String],String)] -> Int +countTableIds _ [] = throw InvalidObjectException +countTableIds tbl ((_,ids,ntbl):t) = if (tbl==ntbl) then length ids else countTableIds tbl t {- checking server type attributes -} @@ -90,16 +104,16 @@ -- this is used to check queries against valid subfields isValidServerObjectScalarField :: ServerObject -> String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool isValidServerObjectScalarField _ _ [] _ = throw InvalidObjectException -isValidServerObjectScalarField sobj name pvs ((pnt,_,cdn):t) = if sobj==pnt then foldl' (\y x->(isValidServerObjectScalarField x name pvs [])&&y) True cdn else isValidServerObjectScalarField sobj name pvs t +isValidServerObjectScalarField sobj name pvs ((pnt,_,cdn):t) = if sobj==pnt then foldr' (\x y->(isValidServerObjectScalarField x name pvs [])&&y) True cdn else isValidServerObjectScalarField sobj name pvs t isValidServerObjectScalarField sobj name ((ptv,fds):t) _ - | sobj==ptv = foldl' (\y (n,_,_)->(name==n)||y) False fds + | sobj==ptv = foldr' (\(n,_,_)y->(name==n)||y) False fds | otherwise = isValidServerObjectScalarField sobj name t [] -- If no transformation is present, I allow different types for different children objects of the same scalar field. -- If there is a transformation, I require same type and transformation values since I cannot infer which child transformation before making queries while I can deduce types after queries with tables. isValidScalarTransformation :: ServerObject -> String -> Transformation -> Argument -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool isValidScalarTransformation _ _ Nothing _ _ _ = True isValidScalarTransformation _ _ _ _ [] _ = throw InvalidObjectException -isValidScalarTransformation sobj name trans arg pvs ((pnt,_,cdn):t) = if sobj==pnt then foldl' (\y x->(isValidScalarTransformation x name trans arg pvs [])&&y) True cdn else isValidScalarTransformation sobj name trans arg pvs t +isValidScalarTransformation sobj name trans arg pvs ((pnt,_,cdn):t) = if sobj==pnt then foldr' (\x y->(isValidScalarTransformation x name trans arg pvs [])&&y) True cdn else isValidScalarTransformation sobj name trans arg pvs t isValidScalarTransformation sobj name (Just trans) arg ((ptv,fds):t) _ | sobj==ptv = findAndCheckScalarTransformation name trans arg fds | otherwise = isValidScalarTransformation sobj name (Just trans) arg t [] @@ -109,21 +123,21 @@ findAndCheckTransformationOption :: String -> Argument -> [(String,[(String,String,String,String)])] -> Bool findAndCheckTransformationOption _ Nothing _ = True findAndCheckTransformationOption _ _ [] = throw InvalidArgumentException -findAndCheckTransformationOption trans (Just arg) ((name,opts):t) = if trans==name then foldl' (\y (n,_,_,_)->(arg==n)||y) False opts else findAndCheckTransformationOption trans (Just arg) t +findAndCheckTransformationOption trans (Just arg) ((name,opts):t) = if trans==name then foldr' (\(n,_,_,_) y->(arg==n)||y) False opts else findAndCheckTransformationOption trans (Just arg) t -- you can create as many relationships as you want with your server... -isValidServerObjectNestedObjectField :: ServerObject -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool -isValidServerObjectNestedObjectField sobj name pvo ((so,_,cdn):t) = if sobj==so then foldl' (\y x->(isValidServerObjectNestedObjectField x name pvo [])&&y) True cdn else isValidServerObjectNestedObjectField sobj name pvo t -isValidServerObjectNestedObjectField _ _ [] _ = throw InvalidObjectException -isValidServerObjectNestedObjectField sobj name ((a,b):t) _ - | sobj==a = elem name b - | otherwise = isValidServerObjectNestedObjectField sobj name t [] +-- isValidServerObjectNestedObjectField :: ServerObject -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool +-- isValidServerObjectNestedObjectField sobj name pvo ((so,_,cdn):t) = if sobj==so then foldl' (\y x->(isValidServerObjectNestedObjectField x name pvo [])&&y) True cdn else isValidServerObjectNestedObjectField sobj name pvo t +-- isValidServerObjectNestedObjectField _ _ [] _ = throw InvalidObjectException +-- isValidServerObjectNestedObjectField sobj name ((a,b):t) _ +-- | sobj==a = elem name b +-- | otherwise = isValidServerObjectNestedObjectField sobj name t [] -- split server object to sql query -- EFFECTS: returns the database table references for the server object. -translateServerObjectToDBName :: ServerObject -> [(String,String)] -> [(String,[String],[String])] -> [String] +translateServerObjectToDBName :: ServerObject -> [(String,[String],String)] -> [(String,[String],[String])] -> [([String],String)] translateServerObjectToDBName sobj pdn ((so,_,cdn):t) = if sobj==so then foldl' (\y x-> (translateServerObjectToDBName x pdn [])++y) [] cdn else translateServerObjectToDBName sobj pdn t translateServerObjectToDBName _ [] _ = throw InvalidObjectException -translateServerObjectToDBName sobj ((a,b):t) _ - | sobj==a = [b] +translateServerObjectToDBName sobj ((a,b,c):t) _ + | sobj==a = [(b,c)] | otherwise = translateServerObjectToDBName sobj t [] getDBObjectRelationships :: String -> String -> [(String,String,[String])] -> [String] getDBObjectRelationships _ _ [] = throw RelationshipConfigurationException
src/Components/ObjectHandlers/ServerObjectValidator.hs view
@@ -2,7 +2,7 @@ import Control.Exception (throw) -import Data.List (foldl') +import Data.Foldable (foldr') import Model.ServerObjectTypes ( ServerObject, RootObject, @@ -20,27 +20,26 @@ ) import Components.ObjectHandlers.ObjectsHandler ( isValidServerObjectChild, - isValidServerObjectNestedObjectField, isValidServerObjectScalarField, isValidScalarTransformation ) -- check that all nested objects are with valid properties -checkObjectsAttributes :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool -checkObjectsAttributes objs sss sos soa = foldl' (\y x-> (hasValidAttributes x sss sos soa)&&y) True objs -hasValidAttributes :: NestedObject -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool -hasValidAttributes (NestedObject alias name sobject Nothing sfs) sss sos soa = isValidSubFields sobject sfs sss sos soa -hasValidAttributes (NestedObject alias name sobject (Just ss) sfs) sss sos soa = (isValidSubSelection sobject ss sss soa)&&isValidSubFields sobject sfs sss sos soa +checkObjectsAttributes :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool +checkObjectsAttributes objs sss soa = foldr' (\x y-> (hasValidAttributes x sss soa)&&y) True objs +hasValidAttributes :: NestedObject -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool +hasValidAttributes (NestedObject alias name sobject Nothing sfs) sss soa = isValidSubFields sobject sfs sss soa +hasValidAttributes (NestedObject alias name sobject (Just ss) sfs) sss soa = (isValidSubSelection sobject ss sss soa)&&isValidSubFields sobject sfs sss soa isValidSubSelection :: ServerObject -> ScalarType -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool isValidSubSelection obj (ScalarType alias name trans arg) sss soa = (isValidServerObjectScalarField obj name sss soa)&&isValidScalarTransformation obj name trans arg sss soa -isValidSubFields :: ServerObject -> [Field] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool -isValidSubFields _ [] _ _ _ = True -- we should not get an empty query -isValidSubFields obj sfs sss sos soa = foldl' (\y x-> (isValidSubField obj x sss sos soa)&&y) True sfs -isValidSubField :: ServerObject -> Field -> [(String,[(String,String,[(String,[(String,String,String,String)])])])]-> [(String,[String])] -> [(String,[String],[String])] -> Bool -isValidSubField obj (Left (ScalarType alias "__typename" trans arg)) sss sos soa = True -isValidSubField obj (Left (ScalarType alias name trans arg)) sss sos soa = (isValidServerObjectScalarField obj name sss soa)&&isValidScalarTransformation obj name trans arg sss soa -isValidSubField obj (Right (Left (NestedObject alias name sobject ss sfs))) sss sos soa = (isValidServerObjectNestedObjectField obj name sos soa)&&hasValidAttributes (NestedObject alias name sobject ss sfs) sss sos soa -isValidSubField obj (Right (Right (InlinefragmentObject ifo sfs))) sss sos soa = (isValidServerObjectChild obj ifo soa)&&isValidSubFields ifo sfs sss sos soa +isValidSubFields :: ServerObject -> [Field] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool +isValidSubFields _ [] _ _ = True -- we should not get an empty query +isValidSubFields obj sfs sss soa = foldr' (\x y-> (isValidSubField obj x sss soa)&&y) True sfs +isValidSubField :: ServerObject -> Field -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool +isValidSubField obj (Left (ScalarType alias "__typename" trans arg)) sss soa = True +isValidSubField obj (Left (ScalarType alias name trans arg)) sss soa = (isValidServerObjectScalarField obj name sss soa)&&isValidScalarTransformation obj name trans arg sss soa +isValidSubField obj (Right (Left (NestedObject alias name sobject ss sfs))) sss soa = hasValidAttributes (NestedObject alias name sobject ss sfs) sss soa +isValidSubField obj (Right (Right (InlinefragmentObject ifo sfs))) sss soa = (isValidServerObjectChild obj ifo soa)&&isValidSubFields ifo sfs sss soa -- replace variables with values and do type checking -- ASSUME: variables are prefixed with $ replaceObjectsVariables :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> [RootObject] -> [(String,String,String)] -> [RootObject]
src/Components/Parsers/QueryParser.hs view
@@ -1,8 +1,9 @@ module Components.Parsers.QueryParser (processString,validateQuery,parseStringToObjects) where -import Components.ObjectHandlers.ObjectsHandler (readServerObject) +import Components.ObjectHandlers.ObjectsHandler (readServerObject, readFieldObject) import Control.Exception (throw) import Data.Char (toLower) +import Data.Foldable (foldl') import Model.ServerExceptions ( QueryException( SyntaxException, @@ -42,7 +43,7 @@ removeCommentsHelper :: String -> Bool -> String removeCommentsHelper [] _ = [] removeCommentsHelper ('#':t) _ = removeCommentsHelper t True -removeCommentsHelper ('\r':t) _ = '\r':removeCommentsHelper t False +-- removeCommentsHelper ('\r':t) _ = '\r':removeCommentsHelper t False removeCommentsHelper ('\n':t) _ = '\n':removeCommentsHelper t False removeCommentsHelper (_:t) True = removeCommentsHelper t True removeCommentsHelper (h:t) mde = h:removeCommentsHelper t mde @@ -50,7 +51,8 @@ removeLinebreaks :: String -> String removeLinebreaks "" = "" removeLinebreaks ('\n':t) = ' ':removeLinebreaks t -removeLinebreaks ('\r':t) = ' ':removeLinebreaks t +removeLinebreaks ('\r':t) = removeLinebreaks t +removeLinebreaks ('\t':t) = ' ':removeLinebreaks t removeLinebreaks (h:t) = h:removeLinebreaks t @@ -87,9 +89,9 @@ {-----Step 3. PARSING-----} -parseStringToObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> RootObjects -parseStringToObjects [] _ _ _ = throw EmptyQueryException -parseStringToObjects str svrobjs soa vars = composeObjects qry svrobjs soa vars fragments +parseStringToObjects :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> RootObjects +parseStringToObjects [] _ _ _ _ = throw EmptyQueryException +parseStringToObjects str svrobjs sos soa vars = composeObjects qry svrobjs sos soa vars fragments where (qry,fmts) = getQueryAndFragments str fragments = parseFragments fmts svrobjs soa @@ -165,11 +167,13 @@ createFragmentHelper (':':t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++":") True True True True rst1 rst2 svrobjs soa createFragmentHelper ('$':t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"$") True True True True rst1 rst2 svrobjs soa createFragmentHelper ('@':t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"@") True True True True rst1 rst2 svrobjs soa -createFragmentHelper (h:t) l acc _ _ _ _ rst1 rst2 svrobjs soa - | isValidIdentifierChar h = createFragmentHelper t l (acc++[h]) True True True True rst1 rst2 svrobjs soa - | otherwise = throw ParseFragmentException +createFragmentHelper (h:t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++[h]) True True True True rst1 rst2 svrobjs soa +-- | isValidIdentifierChar h = createFragmentHelper t l (acc++[h]) True True True True rst1 rst2 svrobjs soa +-- | otherwise = throw ParseFragmentException +-- only names isValidFragmentNameChar :: Char -> Bool isValidFragmentNameChar c = ((fromEnum c)>=65&&(fromEnum c)<=90)||((fromEnum c)>=97&&(fromEnum c)<=122)||((fromEnum c)>=48&&(fromEnum c)<=57)||((fromEnum c)==95) +-- variables or names isValidIdentifierChar :: Char -> Bool isValidIdentifierChar c = ((fromEnum c)>=65&&(fromEnum c)<=90)||((fromEnum c)>=97&&(fromEnum c)<=122)||((fromEnum c)>=48&&(fromEnum c)<=57)||((fromEnum c)==95)||((fromEnum c)==36) -- call after infering types on nested objects @@ -190,13 +194,13 @@ passing code block to separateRootObjects() where code block is not including query opening and closing brackets TODO: change Bool to Either with exceptions -} -composeObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects -composeObjects "" _ _ _ _ = throw EmptyQueryException -composeObjects str svrobjs soa vars fmts = composeObjectsHelper str 0 svrobjs soa vars fmts -composeObjectsHelper :: String -> Int -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects -composeObjectsHelper "" _ _ _ _ _ = throw EmptyQueryException -composeObjectsHelper ('{':t) 0 svrobjs soa vars fmts = separateRootObjects (extractLevel t) svrobjs soa vars fmts -- find and separate every root object -composeObjectsHelper (_:t) l svrobjs soa vars fmts = composeObjectsHelper t l svrobjs soa vars fmts +composeObjects :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects +composeObjects "" _ _ _ _ _ = throw EmptyQueryException +composeObjects str svrobjs sos soa vars fmts = composeObjectsHelper str 0 svrobjs sos soa vars fmts +composeObjectsHelper :: String -> Int -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects +composeObjectsHelper "" _ _ _ _ _ _ = throw EmptyQueryException +composeObjectsHelper ('{':t) 0 svrobjs sos soa vars fmts = separateRootObjects (extractLevel t) svrobjs sos soa vars fmts -- find and separate every root object +composeObjectsHelper (_:t) l svrobjs sos soa vars fmts = composeObjectsHelper t l svrobjs sos soa vars fmts -- ...separate and determine operation -- TODO: implement operations -- determineOperation :: String -> (Operation,String) @@ -210,31 +214,37 @@ -- REQUIRES: brackets are balanced and ordered -- NOTE: only querying is first supported; mutations are later -- EFFECTS: passing block to createNestedObject where block is including opening and closing curly brackets -separateRootObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject] -separateRootObjects str svrobjs soa vars fmts = separateRootObjectsHelper str "" svrobjs soa vars fmts -separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject] -separateRootObjectsHelper "" _ _ _ _ _ = [] -separateRootObjectsHelper ('{':t) acc svrobjs soa vars fmts = (((createNestedObject (acc++"{"++level) svrobjs soa vars fmts) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs soa vars fmts) +separateRootObjects :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject] +separateRootObjects str svrobjs sos soa vars fmts = separateRootObjectsHelper str "" svrobjs sos soa vars fmts +separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject] +separateRootObjectsHelper "" _ _ _ _ _ _ = [] +separateRootObjectsHelper ('{':t) acc svrobjs sos soa vars fmts = (((createNestedObject (acc++"{"++level) svrobjs sos soa vars fmts Nothing) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs sos soa vars fmts) where (level,levelTail) = splitLevel t "" 0 -separateRootObjectsHelper (h:t) acc svrobjs soa vars fmts = separateRootObjectsHelper t (acc++[h]) svrobjs soa vars fmts +separateRootObjectsHelper (',':t) acc svrobjs sos soa vars fmts = separateRootObjectsHelper t acc svrobjs sos soa vars fmts +separateRootObjectsHelper (h:t) acc svrobjs sos soa vars fmts = separateRootObjectsHelper t (acc++[h]) svrobjs sos soa vars fmts -- create root object from block -- EFFECTS: passing code block to parseSubFields where block is not including root object opening and closing curly brackets. -createNestedObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject -createNestedObject str svrobjs soa vars fmts = createNestedObjectHelper str "" svrobjs soa vars fmts -createNestedObjectHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject -createNestedObjectHelper "" _ _ _ _ _ = throw InvalidObjectException -- we should not encounter this since we already checked against empty brackets -createNestedObjectHelper ('{':t) acc svrobjs soa vars fmts = NestedObject (parseAlias acc) (parseName acc) serverObj (parseSubSelection acc) ((parseSubFields (extractLevel t) svrobjs soa vars fmts serverObj) :: SubFields) :: RootObject +createNestedObject :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> Maybe ServerObject -> NestedObject +createNestedObject str svrobjs sos soa vars fmts sobj = createNestedObjectHelper str "" svrobjs sos soa vars fmts sobj +createNestedObjectHelper :: String -> String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> Maybe ServerObject -> NestedObject +createNestedObjectHelper "" _ _ _ _ _ _ _ = throw InvalidObjectException -- we should not encounter this since we already checked against empty brackets +createNestedObjectHelper ('{':t) acc svrobjs sos soa vars fmts sobj = NestedObject (parseAlias acc) (parseName acc) serverObj (parseSubSelection acc) ((parseSubFields (extractLevel t) svrobjs sos soa vars fmts serverObj) :: SubFields) :: RootObject where - serverObj = parseServerObject acc svrobjs soa -createNestedObjectHelper (h:t) acc svrobjs soa vars fmts = createNestedObjectHelper t (acc++[h]) svrobjs soa vars fmts + serverObj = parseServerObject acc svrobjs sos soa sobj +createNestedObjectHelper (h:t) acc svrobjs sos soa vars fmts sobj = createNestedObjectHelper t (acc++[h]) svrobjs sos soa vars fmts sobj -- given object header without any braces, we want a name. -parseServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject -parseServerObject "" svrobjs soa = readServerObject "" svrobjs soa -parseServerObject str svrobjs soa - | (elem ':' str)==True&&(elem '(' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str)) svrobjs soa - | (elem ':' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" str) svrobjs soa +parseServerObject :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> Maybe ServerObject -> ServerObject +parseServerObject "" svrobjs sos soa Nothing = readServerObject "" svrobjs soa +parseServerObject str svrobjs sos soa Nothing + | (elem ':' str)==True&&(elem '(' str)==True = readServerObject (removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str)) svrobjs soa + | (elem ':' str)==True = readServerObject (removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" str) svrobjs soa | otherwise = readServerObject (removeSpaces str) svrobjs soa +parseServerObject "" svrobjs sos soa (Just holder) = readFieldObject "" sos soa holder +parseServerObject str svrobjs sos soa (Just holder) + | (elem ':' str)==True&&(elem '(' str)==True = readFieldObject (removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str)) sos soa holder + | (elem ':' str)==True = readFieldObject (removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" str) sos soa holder + | otherwise = readFieldObject (removeSpaces str) sos soa holder -- given object header without any braces, we want the alias if there is one. parseAlias :: String -> Alias parseAlias "" = Nothing :: Alias @@ -245,79 +255,79 @@ parseName :: String -> Name parseName "" = "" parseName str - | (elem ':' str)==True&&(elem '(' str)==True = removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str) - | (elem ':' str)==True = removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" str + | (elem ':' str)==True&&(elem '(' str)==True = removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str) + | (elem ':' str)==True = removeSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" str | otherwise = removeSpaces str parseSubSelection :: String -> SubSelection parseSubSelection "" = Nothing :: SubSelection parseSubSelection ('(':t) - | (elem ':' t)==True&&(elem ')' t)==True = Just (ScalarType (Nothing :: Alias) ((removeSideSpaces (foldr (\x y -> if x==':' then "" else x:y) "" t)) :: Name) (Nothing :: Transformation) ((Just $ removeSideSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x==')' then "" else x:y) "" t)) :: Argument)) :: SubSelection + | (elem ':' t)==True&&(elem ')' t)==True = Just (ScalarType (Nothing :: Alias) ((removeSideSpaces (foldr (\x y -> if x==':' then "" else x:y) "" t)) :: Name) (Nothing :: Transformation) ((Just $ removeSideSpaces $ foldl' (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x==')' then "" else x:y) "" t)) :: Argument)) :: SubSelection parseSubSelection (h:t) = parseSubSelection t -- REQUIRES: code block on nested object subfields where nested object opening and closing curly brackets are not included -parseSubFields :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field] -parseSubFields "" _ _ _ _ _ = [] -parseSubFields str svrobjs soa vars fmts sobj = parseSubFieldsHelper str "" "" svrobjs soa True vars fmts sobj -parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field] -parseSubFieldsHelper "" "" "" _ _ _ _ _ _ = [] -parseSubFieldsHelper "" "" acc _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field] -parseSubFieldsHelper "" "" acc _ _ False _ _ _ = [] -parseSubFieldsHelper "" acc "" _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field] -parseSubFieldsHelper "" acc "" _ _ False _ _ _ = [] +parseSubFields :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field] +parseSubFields "" _ _ _ _ _ _ = [] +parseSubFields str svrobjs sos soa vars fmts sobj = parseSubFieldsHelper str "" "" svrobjs sos soa True vars fmts sobj +parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> Bool -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field] +parseSubFieldsHelper "" "" "" _ _ _ _ _ _ _ = [] +parseSubFieldsHelper "" "" acc _ _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field] +parseSubFieldsHelper "" "" acc _ _ _ False _ _ _ = [] +parseSubFieldsHelper "" acc "" _ _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field] +parseSubFieldsHelper "" acc "" _ _ _ False _ _ _ = [] -- There is not a case where both acc1 and acc2 are not empty, but I'll catch anyway -parseSubFieldsHelper "" acc1 acc2 _ _ True _ _ _ = (Left $ createScalarType (acc2++acc1)):[] -parseSubFieldsHelper "" acc1 acc2 _ _ False _ _ _ = [] -parseSubFieldsHelper (':':t) acc1 acc2 svrobjs soa inc vars fmts sobj = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1++":") "" svrobjs soa inc vars fmts sobj -parseSubFieldsHelper (' ':t) acc1 acc2 svrobjs soa inc vars fmts sobj - | (length acc1)>0 = parseSubFieldsHelper t "" acc1 svrobjs soa inc vars fmts sobj - | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj -parseSubFieldsHelper (',':t) acc1 acc2 svrobjs soa True vars fmts sobj - | (length acc1)>0 = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj - | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj -- if acc is not empty, I assume that acc1 is empty -parseSubFieldsHelper (',':t) acc1 acc2 svrobjs soa inc vars fmts sobj - | (length acc1)>0 = parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj - | (length acc2)>0 = parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj - | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj -parseSubFieldsHelper ('(':t) acc1 acc2 svrobjs soa inc vars fmts sobj - | (length acc1)>0 = parseSubFieldsHelper selectTail (acc1++"("++subselect) "" svrobjs soa inc vars fmts sobj - | (length acc2)>0 = parseSubFieldsHelper selectTail (acc2++"("++subselect) "" svrobjs soa inc vars fmts sobj +parseSubFieldsHelper "" acc1 acc2 _ _ _ True _ _ _ = (Left $ createScalarType (acc2++acc1)):[] +parseSubFieldsHelper "" acc1 acc2 _ _ _ False _ _ _ = [] +parseSubFieldsHelper (':':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1++":") "" svrobjs sos soa inc vars fmts sobj +parseSubFieldsHelper (' ':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj + | (length acc1)>0 = parseSubFieldsHelper t "" acc1 svrobjs sos soa inc vars fmts sobj + | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs sos soa inc vars fmts sobj +parseSubFieldsHelper (',':t) acc1 acc2 svrobjs sos soa True vars fmts sobj + | (length acc1)>0 = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t "" "" svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t "" "" svrobjs sos soa True vars fmts sobj -- if acc is not empty, I assume that acc1 is empty +parseSubFieldsHelper (',':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj + | (length acc1)>0 = parseSubFieldsHelper t "" "" svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = parseSubFieldsHelper t "" "" svrobjs sos soa True vars fmts sobj + | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs sos soa inc vars fmts sobj +parseSubFieldsHelper ('(':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj + | (length acc1)>0 = parseSubFieldsHelper selectTail (acc1++"("++subselect) "" svrobjs sos soa inc vars fmts sobj + | (length acc2)>0 = parseSubFieldsHelper selectTail (acc2++"("++subselect) "" svrobjs sos soa inc vars fmts sobj where (subselect,selectTail) = getSubSelection t -parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs soa True vars fmts sobj - | (length acc1)>0 = (Right (Left (createNestedObject (acc1++"{"++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj - | (length acc2)>0 = (Right (Left (createNestedObject (acc2++"{"++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj +parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs sos soa True vars fmts sobj + | (length acc1)>0 = (Right (Left (createNestedObject (acc1++"{"++level) svrobjs sos soa vars fmts (Just sobj)) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = (Right (Left (createNestedObject (acc2++"{"++level) svrobjs sos soa vars fmts (Just sobj)) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs sos soa True vars fmts sobj where (level,levelTail) = splitLevel t "" 0 -parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs soa _ vars fmts sobj - | (length acc1)>0 = parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj - | (length acc2)>0 = parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj +parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs sos soa _ vars fmts sobj + | (length acc1)>0 = parseSubFieldsHelper levelTail "" "" svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = parseSubFieldsHelper levelTail "" "" svrobjs sos soa True vars fmts sobj where (level,levelTail) = splitLevel t "" 0 -parseSubFieldsHelper ('@':t) acc1 acc2 svrobjs soa _ vars fmts sobj - | directive==True = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa True vars fmts sobj - | otherwise = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa False vars fmts sobj +parseSubFieldsHelper ('@':t) acc1 acc2 svrobjs sos soa _ vars fmts sobj + | directive==True = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs sos soa True vars fmts sobj + | otherwise = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs sos soa False vars fmts sobj where (directive,directiveTail) = checkDirective ('@':t) vars -parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs soa True vars fmts sobj - | (length acc2)>0 = if isInlineFragment then (Left $ createScalarType acc2 :: Field):(Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa True vars fmts sobj +parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = if isInlineFragment then (Left $ createScalarType acc2 :: Field):(Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs sos soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs sos soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs sos soa True vars fmts sobj where (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment ('.':t) (fragmentName,fragmentTail) = findFragment ('.':t) fContents = expandFragment fragmentName sobj fmts -parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs soa inc vars fmts sobj - | (length acc1)>0 = parseSubFieldsHelper t (acc1++".") "" svrobjs soa True vars fmts sobj - | (length acc2)>0 = if isInlineFragment then (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa inc vars fmts sobj - | isInlineFragment==True = (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj - | otherwise = parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa inc vars fmts sobj +parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj + | (length acc1)>0 = parseSubFieldsHelper t (acc1++".") "" svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = if isInlineFragment then (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs sos soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs sos soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs sos soa inc vars fmts sobj + | isInlineFragment==True = (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs sos soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs sos soa True vars fmts sobj + | otherwise = parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs sos soa inc vars fmts sobj where (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment ('.':t) (fragmentName,fragmentTail) = findFragment ('.':t) fContents = expandFragment fragmentName sobj fmts -parseSubFieldsHelper ('}':t) acc1 acc2 svrobjs soa inc vars fmts sobj = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj -- this character is removed when I pull a level -parseSubFieldsHelper (h:t) acc1 acc2 svrobjs soa True vars fmts sobj - | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa True vars fmts sobj -parseSubFieldsHelper (h:t) acc1 acc2 svrobjs soa inc vars fmts sobj - | (length acc2)>0 = parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa True vars fmts sobj - | otherwise = parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa inc vars fmts sobj +parseSubFieldsHelper ('}':t) acc1 acc2 svrobjs sos soa inc vars fmts sobj = parseSubFieldsHelper t acc1 acc2 svrobjs sos soa inc vars fmts sobj -- this character is removed when I pull a level +parseSubFieldsHelper (h:t) acc1 acc2 svrobjs sos soa True vars fmts sobj + | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) "" svrobjs sos soa True vars fmts sobj +parseSubFieldsHelper (h:t) acc1 acc2 svrobjs sos soa inc vars fmts sobj + | (length acc2)>0 = parseSubFieldsHelper t (acc1++[h]) "" svrobjs sos soa True vars fmts sobj + | otherwise = parseSubFieldsHelper t (acc1++[h]) "" svrobjs sos soa inc vars fmts sobj checkInlinefragment :: String -> (Bool,String,String,String) @@ -352,8 +362,8 @@ (contents,tail) = splitSubject t "" 0 checkInlinefragmentHelper _ _ _ _ = throw ParseFragmentException -createInlinefragmentObject :: String -> String -> [(String,String,String)] -> [Fragment] -> [(String,[String])] -> [(String,[String],[String])] -> InlinefragmentObject -createInlinefragmentObject bdy obj vars fmts svrobjs soa = InlinefragmentObject (readServerObject obj svrobjs soa) ((parseSubFields bdy svrobjs soa vars fmts obj) :: SubFields) +createInlinefragmentObject :: String -> String -> [(String,String,String)] -> [Fragment] -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> InlinefragmentObject +createInlinefragmentObject bdy obj vars fmts svrobjs sos soa = InlinefragmentObject (readServerObject obj svrobjs soa) ((parseSubFields bdy svrobjs sos soa vars fmts obj) :: SubFields) findFragment :: String -> (String,String) findFragment "" = throw ParseFragmentException @@ -419,8 +429,8 @@ getDirective (' ':t) = getDirective t getDirective ('@':t) = (dir,val,tail) where - dir = removeSideSpaces $ foldl (\y x -> if x=='@' then "" else y++[x]) "" $ getPrefix ('@':t) '(' - val = removeSideSpaces $ foldl (\y x -> if x==':' then "" else y++[x]) "" $ getPrefix t ')' + dir = removeSideSpaces $ foldl' (\y x -> if x=='@' then "" else y++[x]) "" $ getPrefix ('@':t) '(' + val = removeSideSpaces $ foldl' (\y x -> if x==':' then "" else y++[x]) "" $ getPrefix t ')' tail = getSuffix t ')' getPrefix :: String -> Char -> String getPrefix "" _ = "" @@ -466,17 +476,17 @@ parseTransformation :: String -> Transformation parseTransformation "" = Nothing :: Transformation parseTransformation str - | (elem '(' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==':' then "" else x:y) "" $ foldl (\y x -> if x=='(' then "" else y++[x]) "" str) :: Transformation + | (elem '(' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==':' then "" else x:y) "" $ foldl' (\y x -> if x=='(' then "" else y++[x]) "" str) :: Transformation | (elem '(' str) = throw SyntaxException | otherwise = Nothing :: Transformation parseArgument :: String -> Argument parseArgument "" = Nothing :: Argument parseArgument str - | (elem ')' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==')' then "" else x:y) "" $ foldl (\y x -> if x==':' then "" else y++[x]) "" str) :: Argument + | (elem ')' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==')' then "" else x:y) "" $ foldl' (\y x -> if x==':' then "" else y++[x]) "" str) :: Argument | (elem ')' str) = throw SyntaxException | otherwise = Nothing :: Argument removeSideSpaces :: String -> String -removeSideSpaces str = foldl (\y x -> if x==' '&&(length y)==0 then "" else y++[x]) "" $ foldr (\x y -> if x==' '&&(length y)==0 then "" else x:y) "" str +removeSideSpaces str = foldl' (\y x -> if x==' '&&(length y)==0 then "" else y++[x]) "" $ foldr (\x y -> if x==' '&&(length y)==0 then "" else x:y) "" str -- parseOperation :: String -> Operation -- TODO: support mutations
src/Components/Parsers/ServerSchemaJsonParser.hs view
@@ -1,7 +1,7 @@ module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where import Control.Exception (throw) -import Data.List (foldl') +import Data.Foldable (foldl',foldr') import Text.JSON ( JSValue(JSObject), JSObject, @@ -12,6 +12,8 @@ import Model.ServerExceptions ( QueryException( ImportSchemaServerNameException, + ImportSchemaServerNameException, + ImportSchemaServerNameException, ImportSchemaException, ImportSchemaChildrenException, ImportSchemaPseudonymsException, @@ -24,39 +26,40 @@ ) -fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])]) +fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])]) fetchArguments fp = do schema <- Prelude.readFile fp return $ parseSchema schema -parseSchema :: String -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])]) +parseSchema :: String -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])]) parseSchema str = parseHelper $ checkJSValueListValue (decode str :: Result (JSObject JSValue)) checkJSValueListValue :: Result (JSObject JSValue) -> (JSObject JSValue) checkJSValueListValue (Error str) = throw ImportSchemaException checkJSValueListValue (Ok a) = a -parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])]) +parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])]) parseHelper json = if (isValidParentScalars soa sss)&&(isWithoutDups svrobjs sss sos sor soa) then (svrobjs,sss,sos,sdbn,sor,soa) else throw ImportSchemaChildrenException where (svrobjs,sss,sos,sdbn,sor) = parsePrimitivesIterator [] [] [] [] [] $ getObjects (valFromObj "PrimitiveObjects" json :: Result [JSObject JSValue]) soa = parseParentsIterator [] $ getObjects (valFromObj "ParentalObjects" json :: Result [JSObject JSValue]) -parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])]) +parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[(String,[String])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])]) parsePrimitivesIterator svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor) -parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = if foldl' (\acc (prev,_)->(prev==name)||acc) False sdbn then throw ImportSchemaDuplicateException else parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,table):sdbn) (sor++(processRelationships relationships)) t +parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = if foldr' (\(prev,_,_) acc->(prev==name)||acc) False sdbn then throw ImportSchemaDuplicateException else parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,uids,table):sdbn) (sor++(processRelationships relationships)) t where name = getString (valFromObj "ServerName" obj :: Result String) 0 pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0 - scalars = checkScalars (valFromObj "ScalarFields" obj :: Result [JSValue]) - nestedobjects = getStringList (valFromObj "ObjectFields" obj :: Result [String]) 1 + scalars = getScalars $ getObjects (valFromObj "ScalarFields" obj :: Result [JSObject JSValue]) + nestedobjects = getObjectFields $ getObjects (valFromObj "ObjectFields" obj :: Result [JSObject JSValue]) + uids = getStringList (valFromObj "UniqueIds" obj :: Result [String]) 2 table = getString (valFromObj "DatabaseTable" obj :: Result String) 2 relationships = getListStringList (valFromObj "DatabaseRelationships" obj :: Result [[String]]) parseParentsIterator :: [(String,[String],[String])] -> [JSObject JSValue] -> [(String,[String],[String])] parseParentsIterator soa [] = soa -parseParentsIterator soa (obj:t) = if foldl' (\acc (prev,_,_)->(prev==name)||acc) False soa then throw ImportSchemaDuplicateException else parseParentsIterator ((name,pseudonyms,children):soa) t +parseParentsIterator soa (obj:t) = if foldr' (\(prev,_,_) acc->(prev==name)||acc) False soa then throw ImportSchemaDuplicateException else parseParentsIterator ((name,pseudonyms,children):soa) t where name = getString (valFromObj "ServerName" obj :: Result String) 0 pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0 - children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 2 + children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 1 getObjects :: Result [JSObject JSValue] -> [JSObject JSValue] -getObjects (Error _) = throw ImportSchemaServerNameException +getObjects (Error _) = throw ImportSchemaException getObjects (Ok objects) = objects getString :: Result String -> Int -> String getString (Ok str) _ = str @@ -67,18 +70,17 @@ getStringList :: Result [String] -> Int -> [String] getStringList (Ok rlt) _ = rlt getStringList _ 0 = throw ImportSchemaPseudonymsException -getStringList _ 1 = throw ImportSchemaObjectFieldsException -getStringList _ 2 = throw ImportSchemaChildrenException +getStringList _ 1 = throw ImportSchemaChildrenException +getStringList _ 2 = throw ImportSchemaDatabaseTablesException getStringList _ _ = throw ImportSchemaException getListStringList :: Result [[String]] -> [[String]] getListStringList (Error str) = throw ImportSchemaDatabaseRelationshipsException getListStringList (Ok rlt) = rlt -checkScalars :: Result [JSValue] -> [(String,String,[(String,[(String,String,String,String)])])] -checkScalars (Error str) = throw ImportSchemaScalarFieldsException -checkScalars (Ok a) = getScalars a -getScalars :: [JSValue] -> [(String,String,[(String,[(String,String,String,String)])])] +checkScalars :: Result [JSObject JSValue] -> [(String,String,[(String,[(String,String,String,String)])])] +checkScalars = getScalars . getObjects +getScalars :: [JSObject JSValue] -> [(String,String,[(String,[(String,String,String,String)])])] getScalars [] = [] -getScalars ((JSObject obj):t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String),getScalarArguments $ getObjects (valFromObj "Arguments" obj :: Result [JSObject JSValue])):getScalars t +getScalars (obj:t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String),getScalarArguments $ getObjects (valFromObj "Arguments" obj :: Result [JSObject JSValue])):getScalars t getScalarArguments :: [JSObject JSValue] -> [(String,[(String,String,String,String)])] getScalarArguments [] = [] getScalarArguments (h:t) = (name,options):getScalarArguments t @@ -93,6 +95,12 @@ typ = getType (valFromObj "Type" h :: Result String) prefix = getString (valFromObj "Prefix" h :: Result String) 1 suffix = getString (valFromObj "Suffix" h :: Result String) 1 +getObjectFields :: [JSObject JSValue] -> [(String,[String])] +getObjectFields [] = [] +getObjectFields (h:t) = (obj, names):getObjectFields t + where + obj = getString (valFromObj "ServerName" h :: Result String) 0 + names = getStringList (valFromObj "Names" h :: Result [String]) 0 getType :: Result String -> String getType (Ok "Text") = "Text" getType (Ok "ByteString") = "ByteString" @@ -114,29 +122,32 @@ getThird (h1:h2:h3:t) = h3 getThird _ = throw ImportSchemaException -- no duplicated names in schema -isWithoutDups :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,String,[String])] -> [(String,[String],[String])] -> Bool -isWithoutDups sobjs sss sos sor soa = (isNoDupsNames $ foldr (++) [] ([x | (_,x)<-sobjs]++[x | (_,x,_)<-soa]))&&(isNoDupsScalars sss)&&(isNoDupsNestedObjects sos)&&(isNoDupsRelationships sor) +isWithoutDups :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[(String,[String])])] -> [(String,String,[String])] -> [(String,[String],[String])] -> Bool +isWithoutDups sobjs sss sos sor soa = (isNoDupsNames $ foldl' (++) [] ([x | (_,x)<-sobjs]++[x | (_,x,_)<-soa]))&&(isNoDupsScalars sss)&&(isNoDupsNestedObjects sos)&&(isNoDupsRelationships sor) isNoDupsNames :: [String] -> Bool isNoDupsNames [] = True -isNoDupsNames (nm:rst) = (foldl' (\y x->x/=nm&&y) True rst)&&isNoDupsNames rst +isNoDupsNames (nm:rst) = (elem nm rst==False)&&isNoDupsNames rst isNoDupsScalars :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool -isNoDupsScalars sss = foldl' (\y (_,x)->y&&isNoDupsScalarNames x) True sss +isNoDupsScalars sss = foldr' (\(_,x) y->y&&isNoDupsScalarNames x) True sss isNoDupsScalarNames :: [(String,String,[(String,[(String,String,String,String)])])] -> Bool isNoDupsScalarNames [] = True -isNoDupsScalarNames ((name,_,args):rst) = (foldl' (\y (x,_,_)->name/=x&&y) True rst)&&(isNoDupsScalarArguments args)&&isNoDupsScalarNames rst +isNoDupsScalarNames ((name,_,args):rst) = (foldr' (\(x,_,_) y->name/=x&&y) True rst)&&(isNoDupsScalarArguments args)&&isNoDupsScalarNames rst isNoDupsScalarArguments :: [(String,[(String,String,String,String)])] -> Bool isNoDupsScalarArguments [] = True -isNoDupsScalarArguments ((name,opts):rst) = (foldl' (\y (n,o)->name/=n&&y&&isNoDupsArgumentOptions o) True rst)&&isNoDupsScalarArguments rst +isNoDupsScalarArguments ((name,opts):rst) = (foldr' (\(n,o) y->name/=n&&y&&isNoDupsArgumentOptions o) True rst)&&isNoDupsScalarArguments rst isNoDupsArgumentOptions :: [(String,String,String,String)] -> Bool isNoDupsArgumentOptions [] = True -isNoDupsArgumentOptions ((name,_,_,_):rst) = (foldl' (\y (n,_,_,_)->name/=n&&y) True rst)&&isNoDupsArgumentOptions rst -isNoDupsNestedObjects :: [(String,[String])] -> Bool +isNoDupsArgumentOptions ((name,_,_,_):rst) = (foldr' (\(n,_,_,_) y->name/=n&&y) True rst)&&isNoDupsArgumentOptions rst +isNoDupsNestedObjects :: [(String,[(String,[String])])] -> Bool isNoDupsNestedObjects [] = True isNoDupsNestedObjects ((_,[]):rst) = isNoDupsNestedObjects rst -isNoDupsNestedObjects ((obj,no:objs):rst) = (elem no objs)==False&&isNoDupsNestedObjects ((obj,objs):rst) +isNoDupsNestedObjects ((obj,(no,nms):objs):rst) = noDupObj&&noDupNms&&isNoDupsNestedObjects ((obj,objs):rst) + where + noDupObj = foldr' (\(x,_) y->x/=no&&y) True objs + noDupNms = isNoDupsNames nms isNoDupsRelationships :: [(String,String,[String])] -> Bool isNoDupsRelationships [] = True -isNoDupsRelationships ((from,to,_):rst) = (foldl' (\y (a,b,_)->(from/=a||to/=b)&&y) True rst)&&isNoDupsRelationships rst +isNoDupsRelationships ((from,to,_):rst) = (foldr' (\(a,b,_) y->(from/=a||to/=b)&&y) True rst)&&isNoDupsRelationships rst -- shared scalars are same type isValidParentScalars :: [(String,[String],[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool isValidParentScalars [] _ = True @@ -145,9 +156,9 @@ isValidParentScalars ((_,_,(h:cld)):t) sss = (isValidScalarsType (getPrimitiveScalars h sss) cld sss)&&isValidParentScalars t sss getPrimitiveScalars :: String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] getPrimitiveScalars _ [] = throw ImportSchemaChildrenException -getPrimitiveScalars name ((nm,st):t) = if name==nm then foldl' (\y (n,tp,_)->(n,tp):y) [] st else getPrimitiveScalars name t +getPrimitiveScalars name ((nm,st):t) = if name==nm then foldr' (\(n,tp,_) y->(n,tp):y) [] st else getPrimitiveScalars name t isValidScalarsType :: [(String,String)] -> [String] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool isValidScalarsType _ [] _ = True isValidScalarsType [] _ _ = True -isValidScalarsType ((name,typ):t) cld sss = foldl' (\y x->foldl' (\b (n,tp)->if n==name then typ==tp&&y else y) True (getPrimitiveScalars x sss)) True cld +isValidScalarsType ((name,typ):t) cld sss = foldr' (\x y->foldr' (\(n,tp) b->((n==name&&typ==tp)||n/=name)&&y) True (getPrimitiveScalars x sss)) True cld
src/Components/Parsers/VariablesParser.hs view
@@ -45,7 +45,7 @@ getVariableTypePairs :: String -> [(String,String,Maybe String)] getVariableTypePairs [] = throw EmptyQueryException getVariableTypePairs qry - | (elem '(' epilogue)&&(elem ')' epilogue) = separateVariables False "" False "" "" $ removeLeadingSpaces $ foldl (\y x -> if x=='(' then [] else y++[x]) [] $ foldr (\x y -> if x==')' then [] else x:y) [] epilogue + | (elem '(' epilogue)&&(elem ')' epilogue) = separateVariables False "" False "" "" $ removeLeadingSpaces $ foldl' (\y x -> if x=='(' then [] else y++[x]) [] $ foldr (\x y -> if x==')' then [] else x:y) [] epilogue | (elem '(' epilogue) = throw VariablesSyntaxException | (elem ')' epilogue) = throw VariablesSyntaxException | otherwise = [] @@ -77,9 +77,7 @@ finalizedValue = removeTailSpaces acc3 separateVariables var acc1 typ acc2 acc3 (h:t) = separateVariables var acc1 typ acc2 (acc3++[h]) t removeTailSpaces :: String -> String -removeTailSpaces str = reverseString $ removeLeadingSpaces $ reverseString str -reverseString :: String -> String -reverseString str = foldl (\y x->x:y) [] str +removeTailSpaces str = reverse $ removeLeadingSpaces $ reverse str isValidBaseType :: String -> Bool isValidBaseType "Text" = True isValidBaseType "ByteString" = True
src/Components/QueryComposers/SQLQueryComposer.hs view
@@ -35,20 +35,21 @@ ) -makeSqlQueries :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> ([[[String]]],[[String]]) +makeSqlQueries :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> ([[[String]]],[[String]]) makeSqlQueries [] _ _ _ _ = ([],[]) makeSqlQueries rojs sss sodn sor soa = unzip [unzip y | y<-[makeSqlQuerySet sss sodn sor soa x | x<-rojs]] -makeSqlQuerySet :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> RootObject -> [([String],String)] -makeSqlQuerySet sss sodn sor soa obj = if (length dbNames)==1 then addSqlQueryFields (getSubFields obj) (fromList [(firstTable,1)]) ("select "++firstTable++"1.id,") (" from"++(makeSqlTablePhrase obj firstTable 1)) (" order by "++firstTable++"1.id asc") (((firstTable,1):[])) [] sss sodn sor soa (firstTable:[]) else foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields obj) (fromList [(x,1)]) ("select "++x++"1.id,") (" from"++(makeSqlTablePhrase obj x 1)) (" order by "++x++"1.id asc") ((x,1):[]) [] sss sodn sor soa (x:[])) | x<-dbNames] +makeSqlQuerySet :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> RootObject -> [([String],String)] +makeSqlQuerySet sss sodn sor soa obj = if (length dbNames)==1 then addSqlQueryFields (getSubFields obj) (fromList [(firstTable,1)]) ("select "++(makeTableIdentifier firstTableName firstIds "")++",") (" from"++(makeSqlTablePhrase obj firstTable 1)) (" order by "++(makeTableIdentifier firstTableName firstIds " asc")) (((firstTable,1):[])) [] sss sodn sor soa (firstTable:[]) else (foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields obj) (fromList [(x,1)]) ("select "++(makeTableIdentifier xName xIds "")++",") (" from"++(makeSqlTablePhrase obj x 1)) (" order by "++(makeTableIdentifier xName xIds " asc")) ((x,1):[]) [] sss sodn sor soa (x:[])) | (xIds,x)<-dbNames, let xName=x++(show 1)]) where dbNames = translateServerObjectToDBName (getServerObject obj) sodn soa - firstTable = head dbNames + (firstIds,firstTable) = head dbNames + firstTableName = firstTable++(show 1) -- making table phrase when there is only one sql table makeSqlTablePhrase :: NestedObject -> String -> Int -> String makeSqlTablePhrase obj name number = if (withSubSelection obj)==True then " (select * from "++name++" where "++(getSubSelectionField obj)++"="++(getSubSelectionArgument obj)++") as "++name++numStr else " "++name++" as "++name++numStr where numStr = show number -addSqlQueryFields :: SubFields -> Map String Int -> String -> String -> String -> [(String,Int)] -> [SubFields] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> [String] -> [([String],String)] +addSqlQueryFields :: SubFields -> Map String Int -> String -> String -> String -> [(String,Int)] -> [SubFields] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> [String] -> [([String],String)] addSqlQueryFields [] counts select from order [] [] _ _ _ _ tbls = [(tbls,(removeLastChar select)++from++order++";")] addSqlQueryFields [] _ _ _ _ [] _ _ _ _ _ _ = throw CreatingSqlQueryObjectFieldsException addSqlQueryFields [] counts select from order _ [] _ _ _ _ tbls = [(tbls,(removeLastChar select)++from++order++";")] @@ -61,14 +62,14 @@ (prefix,suffix) = getPrimitiveScalarTypeArgumentOptions (translateTableToObject ltable sodn) name trans arg sss -- since only difference is table name, I should remove repeated computations by changing only name... addSqlQueryFields ((Right (Left h)):t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls - | (length tables)>1 = foldl' (\y x-> x++y) [] [addSqlQueryFields (getSubFields h) newCounts (select++x++xNumStr++".id,") (from++(makeTransitions newCounts (getDBObjectRelationships ltable x sor) h)) (order++","++x++xNumStr++".id asc") ((x,xNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa (x:tbls) | x<-tables, let newCounts=calcNewCounts ltable x counts sor, let xNum=(!) newCounts x, let xNumStr=show xNum] - | (length tables)>0 = addSqlQueryFields (getSubFields h) firstTableNewCounts (select++firstSubfieldTable++firsttableNumStr++".id,") (from++(makeTransitions firstTableNewCounts (getDBObjectRelationships ltable firstSubfieldTable sor) h)) (order++","++firstSubfieldTable++firsttableNumStr++".id asc") ((firstSubfieldTable,firsttableNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa $ firstSubfieldTable:tbls + | (length tables)>1 = foldl' (\y x-> x++y) [] [addSqlQueryFields (getSubFields h) newCounts (select++(makeTableIdentifier xName xIds "")++",") (from++(makeTransitions newCounts (getDBObjectRelationships ltable x sor) h)) (order++","++(makeTableIdentifier xName xIds " asc")) ((x,xNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa (x:tbls) | (xIds,x)<-tables, let newCounts=calcNewCounts ltable x counts sor, let xNum=(!) newCounts x, let xName=x++(show xNum)] + | (length tables)>0 = addSqlQueryFields (getSubFields h) firstTableNewCounts (select++(makeTableIdentifier firstTableName firstTableIds "")++",") (from++(makeTransitions firstTableNewCounts (getDBObjectRelationships ltable firstTable sor) h)) (order++","++(makeTableIdentifier firstTableName firstTableIds " asc")) ((firstTable,firstTableNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa (firstTable:tbls) where tables = translateServerObjectToDBName (getServerObject h) sodn soa - firstSubfieldTable = head tables - firstTableNewCounts = calcNewCounts ltable firstSubfieldTable counts sor - firsttableNum = (!) firstTableNewCounts firstSubfieldTable - firsttableNumStr = show firsttableNum + (firstTableIds, firstTable) = head tables + firstTableNewCounts = calcNewCounts ltable firstTable counts sor + firstTableNum = (!) firstTableNewCounts firstTable + firstTableName = firstTable++(show firstTableNum) addSqlQueryFields ((Right (Right (InlinefragmentObject ifo sfs))):t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls | isServerObjectTable ltable ifo sodn soa = addSqlQueryFields (sfs++t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls addSqlQueryFields (h:t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls = addSqlQueryFields t counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls @@ -142,4 +143,8 @@ getArgumentOption Nothing ((_,_,prefix,suffix):_) = (prefix,suffix) getArgumentOption (Just opt) ((name,_,prefix,suffix):rst) | opt==name = (prefix,suffix) - | otherwise = getArgumentOption (Just opt) rst+ | otherwise = getArgumentOption (Just opt) rst +makeTableIdentifier :: String -> [String] -> String -> String +makeTableIdentifier _ [] _ = [] +makeTableIdentifier tbl (h:[]) ins = tbl++"."++h++ins +makeTableIdentifier tbl (h:t) ins = tbl++"."++h++ins++","++(makeTableIdentifier tbl t ins)
src/GraphQLdbi.hs view
@@ -1,13 +1,13 @@ {- | Module : GraphQLdbi -Description : Here are methods to interpret your GraphQL-SQL query and process the Persistent style results +Description : Here are methods to interpret your GraphQL-to-SQL query and process the Persistent style results License : IPS Maintainer : jasonsychau@live.ca Stability : provisional <https://graphql.github.io/ Here> is a link to the official documents. You can learn and get a feel of how can you implement this package which is a GraphQL-to-SQL translator with Persistent package style return-value processing to make a GraphQL format return object string. -This module is made to enable interpreting your GraphQL queries. The expected query type is a single string to comprise all your GraphQL queries and fragments. Expected variable type is a single string to your variable-to-value definitions. +This module is made to enable interpreting your GraphQL queries. The expected query type is a single string to comprise all your GraphQL queries and fragments, and the expected variable type is a single string to your variable-to-value definitions. When errors are encountered, this module is simply going to throw an uncaught Exception. The Exception name is some hint to where was the error encountered. More information is provided in the below function description. @@ -38,21 +38,21 @@ {- | - This function is to parse your schema. The return values are passed to the other two functions to interpret your schema. You can define your schema with tuples and lists without reading a json file as defined in below function, but you will not receive type and duplicate checking from this function. + This function is to parse your schema. The return values are passed to the other two functions to interpret your schema. You can declare and define your schema with tuples and lists without reading a json file as defined in below function, but you will not receive type and duplicate checking from this function. __Schema:__ The schema json file is formated as one json object to describe the GraphQL objects and the object heirarchy. Only "PrimitiveObjects" are valid descendants to "ParentalObjects". Only the shared object fields and shared scalar fields are parental object fields. - If a parental object is a declared field from a primitive object, all descendants are supposed to be declared in the primitive object database relationships. - When declaring any primitive or parental object, the pseudonym is supposed to list all possible reference words to the object (in root object or nested object) - Primitive objects are expected to have a unique "id" column in the declared database table. + If a parental object is a declared field from a primitive object, all descendants are supposed to be declared in database relationships. + When declaring any primitive or parental object, the pseudonym is supposed to list all possible root object references. As a nested object, you should declare the names in the nested object field definitions in corresponding object definitions. + Primitive objects are expected to not have all NULL unique id values, and they are otherwise removed from the result. Database relationships are defined as an ordered sequence from the identity table to the target association table. The order is identity table, identity table join field(s), target table, target table join field(s), then (multiple) triplets (of intermediate table, intermediate table to-join field, then intermediate table from-join field in order of nearness from identity table) if relevant. If multiple fields are defining the join, one declares every field with a space " " separation. For example, the declaration is [A,"a b", B, "c d"] if the join condition is A.a=B.c and A.b = B.d. - You can add schema associations as declaring more fields in the primitive objects. + You can add schema associations as declaring more object-fields in the primitive objects. __Scalar fields:__ @@ -63,18 +63,14 @@ Exceptions are returned when error is faced. This method returns errors of: - * ImportSchemaException (when there is a problem with reading your schema) - * ImportSchemaServerNameException (when there is a problem with reading your servername argument) - * ImportSchemaPseudonymsException (when there is a problem with reading your pseudonyms list argument) - * ImportSchemaScalarFieldsException (when there is a problem with reading your scalarfields list argument) - * ImportSchemaObjectFieldsException (when there is a problem with reading your objectfields list argument) - * ImportSchemaDatabaseTablesException (when there is a problem with reading your databasetables list argument) - * ImportSchemaDatabaseRelationshipsException (when there is a problem with reading your databaserelationships list argument) - * ImportSchemaDuplicateException (when two or more Server objects are sharing the same name) - - __Important note:__ - - It is assumed that all nested objects are corresponding to a database table with a primary key that's named "id". + * ImportSchemaException (if there is a problem with reading your schema) + * ImportSchemaServerNameException (if there is a problem with reading your servername argument) + * ImportSchemaPseudonymsException (if there is a problem with reading your pseudonyms list argument) + * ImportSchemaScalarFieldsException (if there is a problem with reading your scalarfields list argument) + * ImportSchemaObjectFieldsException (if there is a problem with reading your objectfields list argument) + * ImportSchemaDatabaseTablesException (if there is a problem with reading your databasetables list argument) + * ImportSchemaDatabaseRelationshipsException (if there is a problem with reading your databaserelationships list argument) + * ImportSchemaDuplicateException (if two or more Server objects are sharing the same name) __Schema format example:__ @@ -102,8 +98,7 @@ "ServerName": "Person", "Pseudonyms": [ "person", - "Person", - "owner" + "Person" ], "ScalarFields": [ { @@ -135,14 +130,47 @@ } ], "ObjectFields": [ - "pet", - "breed", - "species", - "genus", - "family", - "taxonomy" + { + "Names": [ + "pet" + ], + "ServerName": "Pet" + }, + { + "Names": [ + "breed" + ], + "ServerName": "Breed" + }, + { + "Names": [ + "species" + ], + "ServerName": "Species" + }, + { + "Names": [ + "genus" + ], + "ServerName": "Genus" + }, + { + "Names": [ + "family" + ], + "ServerName": "Family" + }, + { + "Names": [ + "taxonomy" + ], + "ServerName": "Taxonomy" + } ], "DatabaseTable": "person", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["person","id","pet","id","pet_ownership","owner_id","animal_id"], ["person","id","breed","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id"], @@ -170,13 +198,41 @@ } ], "ObjectFields": [ - "genus", - "species", - "breed", - "pet", - "person" + { + "Names": [ + "genus" + ], + "ServerName": "Genus" + }, + { + "Names": [ + "species" + ], + "ServerName": "Species" + }, + { + "Names": [ + "breed" + ], + "ServerName": "Breed" + }, + { + "Names": [ + "pet" + ], + "ServerName": "Pet" + }, + { + "Names": [ + "person" + ], + "ServerName": "Person" + } ], "DatabaseTable": "family", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["family","id","person","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"], ["family","id","pet","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"], @@ -204,13 +260,41 @@ } ], "ObjectFields": [ - "family", - "species", - "breed", - "pet", - "person" + { + "Names": [ + "family" + ], + "ServerName": "Family" + }, + { + "Names": [ + "species" + ], + "ServerName": "Species" + }, + { + "Names": [ + "breed" + ], + "ServerName": "Breed" + }, + { + "Names": [ + "pet" + ], + "ServerName": "Pet" + }, + { + "Names": [ + "person" + ], + "ServerName": "Person" + } ], "DatabaseTable": "genus", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["genus","id","person","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"], ["genus","id","pet","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"], @@ -238,13 +322,41 @@ } ], "ObjectFields": [ - "family", - "genus", - "breed", - "pet", - "person" + { + "Names": [ + "family" + ], + "ServerName": "Family" + }, + { + "Names": [ + "genus" + ], + "ServerName": "Genus" + }, + { + "Names": [ + "breed" + ], + "ServerName": "Breed" + }, + { + "Names": [ + "pet" + ], + "ServerName": "Pet" + }, + { + "Names": [ + "person" + ], + "ServerName": "Person" + } ], "DatabaseTable": "species", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["species","id","person","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"], ["species","id","pet","id","breed","species_id","id","pet_type","breed_id","pet_id"], @@ -272,13 +384,41 @@ } ], "ObjectFields": [ - "family", - "genus", - "species", - "pet", - "person" + { + "Names": [ + "family" + ], + "ServerName": "Family" + }, + { + "Names": [ + "genus" + ], + "ServerName": "Genus" + }, + { + "Names": [ + "species" + ], + "ServerName": "Species" + }, + { + "Names": [ + "pet" + ], + "ServerName": "Pet" + }, + { + "Names": [ + "person" + ], + "ServerName": "Person" + } ], "DatabaseTable": "breed", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["breed","id","person","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"], ["breed","id","pet","id","pet_type","breed_id","pet_id"], @@ -323,14 +463,47 @@ } ], "ObjectFields": [ - "owner", - "breed", - "species", - "genus", - "family", - "taxonomy" + { + "Names": [ + "owner" + ], + "ServerName": "Person" + }, + { + "Names": [ + "breed" + ], + "ServerName": "Breed" + }, + { + "Names": [ + "species" + ], + "ServerName": "Species" + }, + { + "Names": [ + "genus" + ], + "ServerName": "Genus" + }, + { + "Names": [ + "family" + ], + "ServerName": "Family" + }, + { + "Names": [ + "taxonomy" + ], + "ServerName": "Taxonomy" + } ], "DatabaseTable": "pet", + "UniqueIds": [ + "id" + ], "DatabaseRelationships": [ ["pet","id","person","id","pet_ownership","animal_id","owner_id"], ["pet","id","breed","id","pet_type","pet_id","breed_id"], @@ -345,7 +518,7 @@ __Schema recommendation:__ - If you add every possible chain from every PrimitiveObject to every other PrimitiveObject, you can extend the schema coverage and query capacities. + When you add every possible chain from every PrimitiveObject to every other PrimitiveObject, the schema coverage is extended. __Closing remark:__ @@ -353,7 +526,7 @@ @"In contrast, GraphQL only returns the data that's explicitly requested, so new capabilities can be added via new types and new fields on those types without creating a breaking change. This has lead to a common practice of always avoiding breaking changes and serving a versionless API."@ - <https://graphql.github.io/learn/best-practices/> - With respect to that, you should be sure to be explicit with your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server to make graph-like associations. + With respect to that, you should elaborate on your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server by making associations that are like simple arcs in a graph. -} processSchema :: (MonadIO m) => FilePath -- ^ This is the path to schema json file @@ -362,55 +535,38 @@ schema <- liftIO $ fetchArguments fp return schema {- | - This function is to parse, validate, and interpret your query with variables. If you don't have variables, you may pass an empty string. The function is expecting your schema as SchemaSpec type from the above function. You can alternatively define you schema with lists and tuples. The order is - - @ - ([(ServerObjectName,[ServerObjectPseudonyms])],[(ServerObjectName,[(ScalarName,ScalarType)])],[(ServerObjectName,[NestedObjectNames])],[(ServerObjectName,ServerObjectDatabaseTableName)],[(StartingDatabaseTableName,EndingDatabaseTableName,[PathBetweenDatabaseTables])],[(ParentServerObjectName,[ParentPseudonyms],[ServerObjectDescendants])]) - @ + This function is to parse, validate, and interpret your query with variables. If you don't have variables, you may pass an empty string. The function is expecting your schema as SchemaSpec type from the above function. You can alternatively define you schema with lists and tuples. - You also can use the above function to print your schema data and paste it into your script file. + You also can use the above function to print and paste your schema data into your script file. __Function return value:__ The returned values are one tuple to contain information to pass into your database interface and to later reuse in below data processing function. The tuple is (PackagedObjects,SQLQueries). The second tuple member is a collection of queries. - An example is given on this <https://github.com/jasonsychau/graphql-w-persistent page> to iterate the queries to your database. - The example is also showing how is the first member passed to the data processing function. + Examples are found in this <https://github.com/jasonsychau/graphql-w-persistent repository page> to pass queries (and data) to your database. __Function exceptions:__ Exceptions are returned when error is faced. This method returns errors of: - * SyntaxException (when there is a problem with the given GraphQL query syntax) - * ParseFragmentException (when there is a problem with a Fragment syntax) - * EmptyQueryException (when the query is left blank) - * InvalidObjectException (when there is problem in nested object syntax, an object is not recognized, or server data is misinterpreted) - * InvalidObjectSubFieldException (when a subfield is requested from nested object that is not having ownership of the subfield) - * InvalidScalarException (when there is syntax error in listing scalar fields, or server data is misinterpreted) - * NullArgumentException (when a transformation is set but no argument is given though we do not yet support transformations) - * CreatingSqlQueryObjectFieldsException (when there are too many nested object subfields than nested objects to hold them or when there is a problem with the aligning of server object relationship argument - that's the fifth schema argument) - * RelationshipConfigurationException (when the relationship schema fifth arugment is incorrect number of String values, when an unrecognized pairing is found, or when two table field cardinalities are not same) - * FailedObjectEqualityException (when we could not match identical queries) - * DuplicateRootObjectsException (when there is an overlapping query) - - * MissingVariableValueException (when we are missing variables in the variables-value string to the query) - * InvalidVariableNameException (when we cannot find a variable in the query with given variables-value string) - * MismatchedVariableTypeException (when query variable type is not matching object scalar type) - * InvalidVariableTypeException (when variable type is invalid or missing) - * ReadVariablesException (when the variables json string syntax is incorrect or was not correctly read) - * VariablesSyntaxException (when the query variables declaration is invalid syntax) - - __Schema format example:__ - - You should refer to the above function details for information on schema format and details. - - __Closing remark:__ - - As the last remark, I'll turn attention to a quote from specifications. - - @"In contrast, GraphQL only returns the data that's explicitly requested, so new capabilities can be added via new types and new fields on those types without creating a breaking change. This has lead to a common practice of always avoiding breaking changes and serving a versionless API."@ - <https://graphql.github.io/learn/best-practices/> + * SyntaxException (if there is a problem with the given GraphQL query syntax) + * ParseFragmentException (if there is a problem with a Fragment syntax) + * EmptyQueryException (if the query is left blank) + * InvalidObjectException (if there is problem in nested object syntax, an object is not recognized, or server data is misinterpreted) + * InvalidObjectSubFieldException (if a subfield is requested from nested object that is not having ownership of the subfield) + * InvalidScalarException (if there is syntax error in listing scalar fields, or server data is misinterpreted) + * NullArgumentException (if a transformation is set but no argument is given though we do not yet support transformations) + * CreatingSqlQueryObjectFieldsException (if there are too many nested object subfields than nested objects to hold them or if there is a problem with the aligning of server object relationship argument - that's the fifth schema argument) + * RelationshipConfigurationException (if the relationship schema fifth arugment is incorrect number of String values, if an unrecognized pairing is found, or if two table field cardinalities are not same) + * FailedObjectEqualityException (if we could not match identical queries) + * DuplicateRootObjectsException (if there is an overlapping query) - With respect to that, you should be sure to be explicit with your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server to make graph-like associations. + * MissingVariableValueException (if we are missing variables in the variables-value string to the query) + * InvalidVariableNameException (if we cannot find a variable in the query with given variables-value string) + * MismatchedVariableTypeException (if query variable type is not matching object scalar type) + * InvalidVariableTypeException (if variable type is invalid or missing) + * ReadVariablesException (if the variables json string syntax is incorrect or was not correctly read) + * VariablesSyntaxException (if the query variables declaration is invalid syntax) -} processQueryString :: SchemaSpecs -- ^ This is the data about your schema -> String -- ^ This is the GraphQL query @@ -419,20 +575,20 @@ processQueryString (svrobjs,sss,sos,sodn,sor,soa) qry vars = let dvars = parseVariables vars qry str = processString qry - objs = if (validateQuery str)==True then (parseStringToObjects str svrobjs soa dvars) else throw SyntaxException + objs = if (validateQuery str)==True then (parseStringToObjects str svrobjs sos soa dvars) else throw SyntaxException robjs = mergeDuplicatedRootObjects $ replaceObjectsVariables sss soa objs dvars - (tbls,qrys) = if (checkObjectsAttributes robjs sss sos soa)==True then (makeSqlQueries robjs sss sodn sor soa) else (throw InvalidObjectSubfieldException) + (tbls,qrys) = if (checkObjectsAttributes robjs sss soa)==True then (makeSqlQueries robjs sss sodn sor soa) else (throw InvalidObjectSubfieldException) in (zip robjs tbls,qrys) {- | - After casting all database results to Text (example is given in <https://github.com/jasonsychau/graphql-w-persistent examples> page), you may use this function to process data to GraphQL format. + After casting all database results to Text (examples are given in this repository <https://github.com/jasonsychau/graphql-w-persistent site>), you may use this function to make GraphQL data. The second argument is the package objects given from function processQueryString. - The return result is a string to resemble the GraphQL return value. + The return result is a string to resemble a GraphQL return value. __Formatting notes (IMPORTANT):__ - Nulls are expected as "Unexpected null". This is the Persistent default and important when processing ids to separate different results. One can translate nulls to "Unexpected null" when making Text types of query results. + Nulls are expected as "Unexpected null". This is the Persistent default and important when processing ids to separate different results. One can translate nulls to "Unexpected null" when making Text types of query results. This is in the repository examples. __Function exceptions:__
src/Model/ServerExceptions.hs view
@@ -18,7 +18,15 @@ NullArgumentException | CreatingSqlQueryObjectFieldsException | CreatingSqlQueryObjectsException | - EOFDataProcessingException | + EOFDataProcessingException1 | + EOFDataProcessingException2 | + EOFDataProcessingException3 | + EOFDataProcessingException4 | + EOFDataProcessingException5 | + EOFDataProcessingException6 | + EOFDataProcessingException7 | + EOFDataProcessingException8 | + EOFDataProcessingException9 | RelationshipConfigurationException | FailedObjectEqualityException | DuplicateRootObjectsException |
src/Model/ServerObjectTypes.hs view
@@ -14,6 +14,7 @@ -- | NestedObjects are the general object type. They are found as RootObjects or as object Subfields. data NestedObject = NestedObject !Alias !Name !ServerObject !SubSelection !SubFields + deriving Show type Alias = Maybe String type ServerObject = String type SubSelection = Maybe ScalarType @@ -21,10 +22,12 @@ type Field = Either ScalarType FieldObject type FieldObject = Either NestedObject InlinefragmentObject data InlinefragmentObject = InlinefragmentObject !ServerObject !SubFields + deriving Show -- | ScalarTypes are the other subfield type. They are also found at object attributes. data ScalarType = ScalarType !Alias !Name !Transformation !Argument - deriving Eq + -- deriving Eq + deriving (Show,Eq) type Transformation = Maybe String type Argument = Maybe String @@ -36,6 +39,6 @@ , replacement :: String } -type SchemaSpecs = ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])]) +type SchemaSpecs = ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])]) type QueryData = [(RootObject,[[String]])]