diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for graphql-w-persistent +## 0.8.0.0 -- 2019-12-28 + +* reduce space footprint by querying objects individually and only once per reference + ## 0.7.0.1 -- 2019-12-28 * fix exceptions diff --git a/graphql-w-persistent.cabal b/graphql-w-persistent.cabal --- a/graphql-w-persistent.cabal +++ b/graphql-w-persistent.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.7.0.1 +version: 0.8.0.0 -- A short (one-line) description of the package. synopsis: GraphQL interface middleware for (SQL) databases. diff --git a/src/Components/DataProcessors/ListDataProcessor.hs b/src/Components/DataProcessors/ListDataProcessor.hs --- a/src/Components/DataProcessors/ListDataProcessor.hs +++ b/src/Components/DataProcessors/ListDataProcessor.hs @@ -5,14 +5,14 @@ import Control.Exception (throw) import Data.Foldable (foldl',foldr') import Model.ServerExceptions ( - QueryException( - InvalidObjectException, - InvalidScalarException, - InvalidArgumentException, - EOFDataProcessingException, - InvalidVariableTypeException - ) + QueryException( + InvalidObjectException, + InvalidScalarException, + InvalidArgumentException, + EOFDataProcessingException, + InvalidVariableTypeException ) + ) import Model.ServerObjectTypes ( NestedObject(..), Field, @@ -24,86 +24,101 @@ InlinefragmentObject(..) ) import Components.ObjectHandlers.ObjectsHandler ( - isServerObjectTable, - getNestedObjectFieldLabel, - getScalarFieldLabel, - translateTableToObject, - countTableIds + isServerObjectTable, + getNestedObjectFieldLabel, + getScalarFieldLabel, + 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],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> String +-- root objects to one json representation of separate graphql results +processReturnedValues :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[(Int,Bool,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],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> JSObject (JSObject JSValue) +processReturnedValuesToJsonObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[(Int,Bool,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],[String])] -> RootObject -> [[String]] -> [[[Text]]] -> (String, JSValue) +-- qraphql query object and sql return data to json representation on graphql query results +processReturnedValue :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> RootObject -> [[(Int,Bool,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 -> [[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 $ 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) +-- SubFields and data rows to json representation on qraphql query data +processSubFields :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[(Int,Bool,String)]] -> [Field] -> [[[[Text]]]] -> [JSValue] +processSubFields sss sodn soa sobj tbls (sf:sfs) (vRlt:rlts) + | all (\x -> (null x)||(null $ head x)) (vRlt:rlts) = [] -- all first query (object query) are no results (or no query) + | oneObject&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls (sf:sfs) remData) + | oneObject = processSubFields sss sodn soa sobj tbls (sf:sfs) remData + | otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls (sf:sfs) remData) where - 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,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 z) | (x,y,z)<-notEmptyQueryResults] + oneObject = all (\x -> (null x)||((snd3 $ head x)==False)) $ tail tbls + zDta = zip3 tbls (vRlt:rlts) idCounts + object = makeOneGQLObject sss sodn soa sobj tbls (sf:sfs) [fetchGraphQlRow dt idC | (_,dt,idC)<-zDta] + notEmptyQueryResults = [(x,y,z) | (x,y,z)<-zDta,(null x)==False,(null y)==False,(null $ head y)==False] + -- groupedData :: [[([(Int,Bool,String)],[[[Text]]])]] + groupedData = foldl' (\z (x,y) ->if (null z)==True then [[(x,y)]] else if (null x)||((snd3 $ head x)==False) then ((init z)++[(last z)++[(x,y)]]) else (z++[[(x,y)]])) [] $ [(x,fetchGraphQlRow y z) | (x,y,z)<-notEmptyQueryResults] + -- labeledData :; [([[(Int,Bool,String)]],[[[[Text]]]])] 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 -> [[String]] -> [Field] -> [[[Text]]] -> [(String,JSValue)] -makeOneGQLObject _ _ _ _ _ [] (([]:_):_) = [] -- done -makeOneGQLObject _ _ _ _ _ _ ([]:_) = [] -- no column data -makeOneGQLObject _ _ _ _ _ _ [] = [] -- no queries (unusual) -makeOneGQLObject _ _ _ _ _ [] _ = throw EOFDataProcessingException -- columns and no fields + objects = foldr (\(x,y) z -> (makeOneGQLObject sss sodn soa sobj x (sf:sfs) y):z) [] labeledData + remData = [removeDataRow x idC | (_, x, idC)<-zDta] + idCounts = if (null tbls)||(null $ head tbls) then [] else foldl' (\y x -> if (null x) then y++[0] else if (not $ snd3 $ head x) then y++[last y] else y++[countTableIds (thd3 $ head x) sodn]) [countTableIds (thd3 $ head $ head tbls) sodn] $ tail tbls +processSubFields _ _ _ _ _ _ [] = [] -- no variants (maybe not possible) +processSubFields _ _ _ _ _ [] _ = [] -- no fields (when finished) + +thd3 :: (a,b,c) -> c +thd3 (_,_,x) = x +snd3 :: (a,b,c) -> b +snd3 (_,x,_) = x + +makeOneGQLObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[(Int,Bool,String)]] -> [Field] -> [[[[Text]]]] -> [(String,JSValue)] makeOneGQLObject _ _ _ _ [] _ _ = throw EOFDataProcessingException -- 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 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)]) +makeOneGQLObject _ _ _ _ ([]:_) _ _ = throw EOFDataProcessingException -- no reference tables in first varient (unusual) +makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias "__typename" trans arg)):b) dat = (getScalarFieldLabel $ ScalarType alias "__typename" trans arg, showJSON $ pack $ translateTableToObject (thd3 $ head $ head tbls) sodn):(makeOneGQLObject sss sodn soa sobj tbls b dat) +makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias name trans arg)):b) ((((i:j):k):l):m) = (getScalarFieldLabel $ ScalarType alias name trans arg, castJSType (findPrimitiveScalarTypeType (translateTableToObject (thd3 $ head $ head tbls) sodn) name trans arg sss) i):(makeOneGQLObject sss sodn soa sobj tbls b (((j:k):l):m)) +makeOneGQLObject sss sodn soa sobj tbls ((Right (Left (NestedObject alias name nso ss sfs))):b) ((j:k):l) = ((getNestedObjectFieldLabel $ NestedObject alias name nso ss sfs), showJSONs (processSubFields sss sodn soa nso nxtTbls sfs nxtData)):(makeOneGQLObject sss sodn soa sobj remTbls b remData) where - nxtTbls = [init x | x<-tbls] - nestedObjectFieldCounts = [countQueriedSubFields sodn soa (NestedObject alias name nso ss sfs) x | x<-nxtTbls] -makeOneGQLObject sss sodn soa sobj tbls ((Right (Right (InlinefragmentObject ifo sfs))):b) (((i:j):k):l) - | (isServerObjectTable (last $ head tbls) ifo sodn soa)==True = makeOneGQLObject sss sodn soa sobj tbls (sfs++b) (((i:j):k):l) -makeOneGQLObject sss sodn soa sobj tbls (_:b) (((i:j):k):l) = makeOneGQLObject sss sodn soa sobj tbls b (((i:j):k):l) + (nxtTbls,nxtData,remTbls,remData) = separateObjectData tbls ((j:k):l) +makeOneGQLObject sss sodn soa sobj tbls ((Right (Right (InlinefragmentObject ifo sfs))):b) dat + | (isServerObjectTable (thd3 $ head $ head tbls) ifo sodn soa)==True = makeOneGQLObject sss sodn soa sobj tbls (sfs++b) dat + | otherwise = makeOneGQLObject sss sodn soa sobj tbls b dat +makeOneGQLObject _ _ _ _ _ [] ((([]:_):_):_) = [] -- no columns (in first variant and first query) and no fields (done) +makeOneGQLObject _ _ _ _ _ _ (([]:_):_) = [] -- no rows (no data) +makeOneGQLObject _ _ _ _ _ ((Right (Left _)):[]) ([]:_) = throw EOFDataProcessingException -- field and no queries (unusual) +makeOneGQLObject _ _ _ _ _ _ ([]:_) = [] -- no queries (no data) +makeOneGQLObject _ _ _ _ _ _ [] = [] -- no variants (unusual) +makeOneGQLObject _ _ _ _ _ [] _ = [] -- columns and no fields (done or error) +makeOneGQLObject _ _ _ _ _ ((Left _):_) ((([]:_):_):_) = throw EOFDataProcessingException -- field and no result columns +separateObjectData :: [[(Int,Bool,String)]] -> [[[[Text]]]] -> ([[(Int,Bool,String)]],[[[[Text]]]],[[(Int,Bool,String)]],[[[[Text]]]]) +separateObjectData info dat = foldl' (\(nTbls,nDt,rTbls,rDt) (meta,ndt)-> let + mty = null meta + one = (length meta)==1 + newMeta = if mty||one then [] else (lvl,fst,tbl):(take (objQryCount-1) flwObjs) + newData = if mty then [] else if fFst then take (length newMeta) nxtDat else if tblPos<=((length newMeta)-1) then take ((length nxtObjs)-tblPos) ndt else [] + remMeta = if mty then [] else if one then meta else (head meta):(drop objQryCount $ nxtObjs) + remData = if mty then [] else if fFst then (head ndt):(drop objQryCount nxtDat) else if tblPos<=(objQryCount-1) then [] else ndt + nxtObjs = tail meta + flwObjs = tail nxtObjs + nxtDat = tail ndt + (lvl,fst,tbl) = head nxtObjs + objQryCount = foldr' (\(nlvl,nfst,ntbl) y->if nlvl<=lvl then 1 else y+1) 1 flwObjs + tblPos = foldr' (\(idx,(_,fst,_)) y->if fst then idx else y) ((length nxtObjs)-1) $ zip [0..] $ nxtObjs + (_,fFst,_) = head meta + in + (nTbls++[newMeta],nDt++[newData],rTbls++[remMeta],rDt++[remData])) ([],[],[],[]) $ zip info dat + findPrimitiveScalarTypeType :: ServerObject -> String -> Transformation -> Argument -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> String -findPrimitiveScalarTypeType _ _ _ _ [] = throw InvalidObjectException findPrimitiveScalarTypeType sobj name trans arg ((obj,flds):rst) | sobj==obj = findScalarTypeType name trans arg flds | otherwise = findPrimitiveScalarTypeType sobj name trans arg rst +findPrimitiveScalarTypeType _ _ _ _ [] = throw InvalidObjectException findScalarTypeType :: String -> Transformation -> Argument -> [(String,String,[(String,[(String,String,String,String)])])] -> String -findScalarTypeType _ _ _ [] = throw InvalidScalarException findScalarTypeType name Nothing _ ((sName,sType,opts):rst) | name==sName = sType | otherwise = findScalarTypeType name Nothing Nothing rst findScalarTypeType name (Just trans) arg ((sName,sType,args):rst) | name==sName = findArgumentOptionType trans arg args | otherwise = findScalarTypeType name (Just trans) arg rst +findScalarTypeType _ _ _ [] = throw InvalidScalarException findArgumentOptionType :: String -> Argument -> [(String,[(String,String,String,String)])] -> String -findArgumentOptionType _ _ [] = throw InvalidArgumentException findArgumentOptionType trans Nothing ((aname,[]):rst) | trans==aname = throw InvalidArgumentException | otherwise = findArgumentOptionType trans Nothing rst @@ -113,53 +128,59 @@ findArgumentOptionType trans (Just arg) ((aname,opts):rst) | trans==aname = findOptionType arg opts | otherwise = findArgumentOptionType trans (Just arg) rst +findArgumentOptionType _ _ [] = throw InvalidArgumentException findOptionType :: String -> [(String,String,String,String)] -> String -findOptionType _ [] = throw InvalidArgumentException findOptionType arg ((oname,typ,_,_):rst) | arg==oname = typ | otherwise = findOptionType arg rst +findOptionType _ [] = throw InvalidArgumentException -fetchGraphQlRow :: [[Text]] -> Int -> [[Text]] -fetchGraphQlRow rlts idRows = if (all ((==) (pack "Unexpected null")) - firstIds) then [] else - [drop idRows rltRow | rltRow<-rlts, - (take idRows rltRow)==firstIds] +fetchGraphQlRow :: [[[Text]]] -> Int -> [[[Text]]] +fetchGraphQlRow _ 0 = [] -- no queries +fetchGraphQlRow [] _ = [] -- no queries +fetchGraphQlRow ([]:_) _ = [] -- no query results for object +fetchGraphQlRow rlts idCols = if (all ((==) nll) firstIds) then [] else + [[drop idCols rw | rw<-qryRlt, (take idCols rw)==firstIds] | qryRlt<-rlts] 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) [(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 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 + firstIds = take idCols $ head $ head rlts + nll = pack "Unexpected null" +removeDataRow :: [[[Text]]] -> Int -> [[[Text]]] +removeDataRow _ 0 = [] -- no queries +removeDataRow ([]:_) _ = [] -- no query results for object +removeDataRow rlts idCols = [[rw | rw<-qryRlt, (take idCols rw)/=firstIds] | qryRlt<-rlts] + where firstIds = take idCols $ head $ head rlts --- 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 cnt rslt = removeNDataColumns (cnt-1) [t | (h:t)<-rslt] + +-- pullNDataColumns :: Int -> [[Text]] -> [[Text]] +-- pullNDataColumns _ [] = [] +-- pullNDataColumns cnt rslt +-- | (cnt<0) = throw InvalidArgumentException +-- | otherwise = [if (length x) [(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 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 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 +-- countQueriedSubFieldsHelper _ _ [] _ acc = acc +-- -- 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 cnt rslt = removeNDataColumns (cnt-1) [t | (h:t)<-rslt] castJSType :: String -> Text -> JSValue castJSType "Text" val = showJSON val castJSType "ByteString" val = showJSON val @@ -171,20 +192,20 @@ castJSType "TimeOfDay" val = showJSON val castJSType "UTCTime" val = showJSON val castJSType _ val = throw InvalidVariableTypeException -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],[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) - where - foCount = countNOTables sodn soa h (init tbls) -countSubfieldsTables sodn soa ((Right (Right (InlinefragmentObject ifo sfs))):t) tbls acc - | (isServerObjectTable (last tbls) ifo sodn soa)==True = countSubfieldsTables sodn soa (sfs++t) tbls acc -countSubfieldsTables sodn soa (_:t) tbls acc = countSubfieldsTables sodn soa t tbls acc -updateTables :: Int -> [String] -> [String] -updateTables 0 rlt = rlt -updateTables _ [] = throw EOFDataProcessingException -updateTables n lst - | n<0 = throw InvalidArgumentException - | otherwise = updateTables (n-1) ((init $ init lst)++[last lst]) +-- 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],[String])] -> [Field] -> [String] -> Int -> Int +-- 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) +-- where +-- foCount = countNOTables sodn soa h (init tbls) +-- countSubfieldsTables sodn soa ((Right (Right (InlinefragmentObject ifo sfs))):t) tbls acc +-- | (isServerObjectTable (last tbls) ifo sodn soa)==True = countSubfieldsTables sodn soa (sfs++t) tbls acc +-- countSubfieldsTables sodn soa (_:t) tbls acc = countSubfieldsTables sodn soa t tbls acc +-- countSubfieldsTables _ _ [] _ acc = acc +-- updateTables :: Int -> [String] -> [String] +-- updateTables 0 rlt = rlt +-- updateTables _ [] = throw EOFDataProcessingException +-- updateTables n lst +-- | n<0 = throw InvalidArgumentException +-- | otherwise = updateTables (n-1) ((init $ init lst)++[last lst]) diff --git a/src/Components/ObjectHandlers/ObjectsHandler.hs b/src/Components/ObjectHandlers/ObjectsHandler.hs --- a/src/Components/ObjectHandlers/ObjectsHandler.hs +++ b/src/Components/ObjectHandlers/ObjectsHandler.hs @@ -67,63 +67,61 @@ - A valid argument is any string that is provided to reference database objects -} readServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject -readServerObject _ [] [] = throw InvalidObjectException -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 +readServerObject str ((a,b):t) [] = if (elem str b)==True then (a :: ServerObject) else readServerObject str t [] +readServerObject _ [] [] = throw InvalidObjectException 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 +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 _ [] [] _ = throw InvalidObjectException findSingularObject :: [String] -> String -findSingularObject [] = throw InvalidObjectException findSingularObject (fst:rst) = if all ((==) fst) rst then fst else throw InvalidObjectException +findSingularObject [] = throw InvalidObjectException -- INLINE-FRAGMENTS isSameIFObjectReference :: InlinefragmentObject -> InlinefragmentObject -> Bool isSameIFObjectReference (InlinefragmentObject obj1 _) (InlinefragmentObject obj2 _) = obj1==obj2 -- SERVER OBJECTS isValidServerObjectChild :: ServerObject -> ServerObject -> [(String,[String],[String])] -> Bool -isValidServerObjectChild _ _ [] = False isValidServerObjectChild pnt cld ((so,_,cdn):t) = if pnt==so then elem cld cdn else isValidServerObjectChild pnt cld t +isValidServerObjectChild _ _ [] = False -- SCHEMA HEIRARCHY 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 _ [] = throw InvalidObjectException countTableIds :: String -> [(String,[String],String)] -> Int -countTableIds _ [] = throw InvalidObjectException countTableIds tbl ((_,ids,ntbl):t) = if (tbl==ntbl) then length ids else countTableIds tbl t +countTableIds _ [] = throw InvalidObjectException {- checking server type attributes -} --- EFFECT: returns exclusive list of valid fields that are found in the database table for each Server object +-- returns exclusive list of valid fields that are found in the database table for each Server object -- 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 foldr' (\x y->(isValidServerObjectScalarField x name pvs [])&&y) True cdn else isValidServerObjectScalarField sobj name pvs t -isValidServerObjectScalarField sobj name ((ptv,fds):t) _ +isValidServerObjectScalarField sobj name ((ptv,fds):t) [] | 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. +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 _ _ [] _ = throw InvalidObjectException 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 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) _ +isValidScalarTransformation sobj name (Just trans) arg ((ptv,fds):t) [] | sobj==ptv = findAndCheckScalarTransformation name trans arg fds | otherwise = isValidScalarTransformation sobj name (Just trans) arg 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 _ _ _ _ [] _ = throw InvalidObjectException findAndCheckScalarTransformation :: String -> String -> Argument -> [(String,String,[(String,[(String,String,String,String)])])] -> Bool -findAndCheckScalarTransformation name trans arg [] = throw InvalidScalarException findAndCheckScalarTransformation name trans arg ((n,_,args):t) = if name==n then findAndCheckTransformationOption trans arg args else findAndCheckScalarTransformation name trans arg t +findAndCheckScalarTransformation name trans arg [] = throw InvalidScalarException 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 foldr' (\(n,_,_,_) y->(arg==n)||y) False opts else findAndCheckTransformationOption trans (Just arg) t +findAndCheckTransformationOption _ _ [] = throw InvalidArgumentException -- 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 @@ -134,13 +132,13 @@ -- split server object to sql query -- EFFECTS: returns the database table references for the server object. 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,c):t) _ +translateServerObjectToDBName sobj ((a,b,c):t) [] | sobj==a = [(b,c)] | otherwise = translateServerObjectToDBName sobj t [] +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 getDBObjectRelationships :: String -> String -> [(String,String,[String])] -> [String] -getDBObjectRelationships _ _ [] = throw RelationshipConfigurationException getDBObjectRelationships from to ((a,b,c):t) - | from==a&&to==b = c - | otherwise = getDBObjectRelationships from to t + | from==a&&to==b = c + | otherwise = getDBObjectRelationships from to t +getDBObjectRelationships _ _ [] = throw RelationshipConfigurationException diff --git a/src/Components/ObjectHandlers/ServerObjectTrimmer.hs b/src/Components/ObjectHandlers/ServerObjectTrimmer.hs --- a/src/Components/ObjectHandlers/ServerObjectTrimmer.hs +++ b/src/Components/ObjectHandlers/ServerObjectTrimmer.hs @@ -26,61 +26,61 @@ -- TODO: replace all check-then-process to single process... mergeDuplicatedRootObjects robjs = mergeDuplicatedRootObjectsHelper robjs [] mergeDuplicatedRootObjectsHelper :: [RootObject] -> [RootObject] -> [RootObject] -mergeDuplicatedRootObjectsHelper [] rst = rst mergeDuplicatedRootObjectsHelper (h:t) rst = mergeDuplicatedRootObjectsHelper differences (rst++[mergeDuplicates h duplicates]) where (duplicates, differences) = separateDuplicatesAndDifferences h t --- we want two lists of duplicates and differences +mergeDuplicatedRootObjectsHelper [] rst = rst +-- two lists of duplicates and differences separateDuplicatesAndDifferences :: RootObject -> [RootObject] -> ([RootObject],[RootObject]) separateDuplicatesAndDifferences robj [] = ([],[]) separateDuplicatesAndDifferences robj lst = separateDuplicatesAndDifferencesHelper robj lst [] [] separateDuplicatesAndDifferencesHelper :: RootObject -> [RootObject] -> [RootObject] -> [RootObject] -> ([RootObject],[RootObject]) -separateDuplicatesAndDifferencesHelper robj [] dup diff = (dup,diff) separateDuplicatesAndDifferencesHelper robj (h:t) dup diff | (isSameNObjectReference robj h)&&(isSameObjectSubSelection robj h) = separateDuplicatesAndDifferencesHelper robj t (h:dup) diff | (isSameNObjectReference robj h) = throw DuplicateRootObjectsException | otherwise = separateDuplicatesAndDifferencesHelper robj t dup (h:diff) +separateDuplicatesAndDifferencesHelper robj [] dup diff = (dup,diff) -- merge together valid (same reference and same subselection) RootObjects -- ASSUME: all objects are same reference and subselection mergeDuplicates :: RootObject -> [RootObject] -> RootObject -mergeDuplicates robj [] = robj mergeDuplicates (NestedObject alias name sobj ss sf1) ((NestedObject _ _ _ _ sf2):t) = mergeDuplicates (NestedObject alias name sobj ss (compressSubFields (sf1++sf2))) t --- with a list of Fields, we want to merge duplicate Fields +mergeDuplicates robj [] = robj +-- from list of Fields to merged duplicate Fields compressSubFields :: [Field] -> [Field] compressSubFields [] = [] compressSubFields lst = compressSubFieldsHelper lst [] --- We want a removed-duplicate set with a list of Fields, and empty list. +-- want a removed-duplicate set with a list of Fields, and empty list. compressSubFieldsHelper :: [Field] -> [Field] -> [Field] -compressSubFieldsHelper [] rst = rst compressSubFieldsHelper ((Left h):t) rst = compressSubFieldsHelper t (combineScalarTypeWithPresent rst h) compressSubFieldsHelper ((Right (Left h)):t) rst = compressSubFieldsHelper t (combineNestedObjectWithPresent rst h) compressSubFieldsHelper ((Right (Right h)):t) rst = compressSubFieldsHelper t (combineInlinefragmentObjectWithPresent rst h) --- with list of Field and one ScalarType, we want a union set of list and new ScalarType +compressSubFieldsHelper [] rst = rst +-- from list of Field and one ScalarType to a union set of list and new ScalarType combineScalarTypeWithPresent :: [Field] -> ScalarType -> [Field] combineScalarTypeWithPresent fld st = combineScalarTypeWithPresentHelper fld st [] combineScalarTypeWithPresentHelper :: [Field] -> ScalarType -> [Field] -> [Field] -combineScalarTypeWithPresentHelper [] st acc = acc++[Left st] combineScalarTypeWithPresentHelper ((Left h):t) st acc | h==st = acc++((Left h):t) combineScalarTypeWithPresentHelper (h:t) st acc = combineScalarTypeWithPresentHelper t st $ acc++[h] --- with list of Field and one NestedObject, we want a union set of list and new NestedObject +combineScalarTypeWithPresentHelper [] st acc = acc++[Left st] +-- from list of Field and one NestedObject to a union set of list and new NestedObject combineNestedObjectWithPresent :: [Field] -> NestedObject -> [Field] combineNestedObjectWithPresent fld no = combineNestedObjectWithPresentHelper fld no [] combineNestedObjectWithPresentHelper :: [Field] -> NestedObject -> [Field] -> [Field] -combineNestedObjectWithPresentHelper [] no acc = acc++[Right $ Left no] combineNestedObjectWithPresentHelper ((Right (Left h)):t) no acc | (isSameNObjectReference h no)&&(isSameObjectSubSelection h no) = ((Right $ Left $ mergeNObjects h no):t)++acc | isSameNObjectReference h no = throw DuplicateRootObjectsException | otherwise = combineNestedObjectWithPresentHelper t no ((Right $ Left h):acc) combineNestedObjectWithPresentHelper (h:t) no acc = combineNestedObjectWithPresentHelper t no (h:acc) +combineNestedObjectWithPresentHelper [] no acc = acc++[Right $ Left no] combineInlinefragmentObjectWithPresent :: [Field] -> InlinefragmentObject -> [Field] -combineInlinefragmentObjectWithPresent [] ifo = [Right $ Right ifo] combineInlinefragmentObjectWithPresent ((Right (Left h)):t) ifo = (Right $ Left h):combineInlinefragmentObjectWithPresent t ifo combineInlinefragmentObjectWithPresent ((Right (Right h)):t) ifo | isSameIFObjectReference h ifo = (Right $ Right $ mergeIFObjects h ifo):t combineInlinefragmentObjectWithPresent (h:t) ifo = h:combineInlinefragmentObjectWithPresent t ifo --- we want one NestedObject that is same reference, same SubSelection and union set subfields with two NestedObjects that are same reference (alias, name, and ServerObject) and same SubSelection. +combineInlinefragmentObjectWithPresent [] ifo = [Right $ Right ifo] +-- one NestedObject that is same reference, same SubSelection and union set subfields with two NestedObjects that are same reference (alias, name, and ServerObject) and same SubSelection. mergeNObjects :: NestedObject -> NestedObject -> NestedObject mergeNObjects (NestedObject alias1 name1 sobj1 ss1 sfs1) (NestedObject alias2 name2 sobj2 ss2 sfs2) = if alias1==alias2&&name1==name2&&sobj1==sobj2&&ss1==ss2 then NestedObject alias1 name1 sobj1 ss1 (compressSubFields (sfs1++sfs2)) else throw FailedObjectEqualityException --- we want one InlinefragmentObject that is same ServerObject and is union set subfields with two InlinefragmentObjects that are same reference (ServerObject) +-- one InlinefragmentObject that is same ServerObject and is union set subfields with two InlinefragmentObjects that are same reference (ServerObject) mergeIFObjects :: InlinefragmentObject -> InlinefragmentObject -> InlinefragmentObject mergeIFObjects (InlinefragmentObject sobj1 sfs1) (InlinefragmentObject sobj2 sfs2) = if sobj1==sobj2 then InlinefragmentObject sobj1 (compressSubFields (sfs1++sfs2)) else throw FailedObjectEqualityException diff --git a/src/Components/ObjectHandlers/ServerObjectValidator.hs b/src/Components/ObjectHandlers/ServerObjectValidator.hs --- a/src/Components/ObjectHandlers/ServerObjectValidator.hs +++ b/src/Components/ObjectHandlers/ServerObjectValidator.hs @@ -43,12 +43,10 @@ -- 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] -replaceObjectsVariables _ _ [] _ = [] replaceObjectsVariables sss soa objs vars = [replaceObjectVariables sss soa obj vars | obj<-objs] -- TODO -- check parent object subselection -- finish no dups in parse schema --- change all left/right pattern match to also pattern match inside replaceObjectVariables :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> RootObject -> [(String,String,String)] -> RootObject replaceObjectVariables sss soa (NestedObject alias name sobject Nothing sfs) vars = NestedObject alias name sobject Nothing [replaceSubfieldVariables sss soa sobject vars sf | sf<-sfs] replaceObjectVariables sss soa (NestedObject alias name sobject (Just (ScalarType sAlias sName trans Nothing)) sfs) vars = NestedObject alias name sobject (Just $ ScalarType sAlias sName trans Nothing) [replaceSubfieldVariables sss soa sobject vars sf | sf<-sfs] @@ -58,28 +56,28 @@ newValue = if isVariable arg then replaceScalarVariable (getScalarTypeForVariableReplacement sobject sName sss soa) arg vars else arg getScalarTypeForVariableReplacement :: ServerObject -> String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> String -getScalarTypeForVariableReplacement obj st sss ((pnt,_,[]):rst) = if pnt==obj then throw InvalidObjectException else getScalarTypeForVariableReplacement obj st sss rst -getScalarTypeForVariableReplacement obj st sss ((pnt,_,(fst:_)):rst) = if pnt==obj then getScalarTypeForVariableReplacement fst st sss [] else getScalarTypeForVariableReplacement obj st sss rst -getScalarTypeForVariableReplacement _ _ [] _ = throw InvalidObjectException -getScalarTypeForVariableReplacement obj st ((h,sts):rst) _ +getScalarTypeForVariableReplacement obj st ((h,sts):rst) [] | h==obj = findScalarType st sts | otherwise = getScalarTypeForVariableReplacement obj st rst [] +getScalarTypeForVariableReplacement obj st sss ((pnt,_,(fst:_)):rst) = if pnt==obj then getScalarTypeForVariableReplacement fst st sss [] else getScalarTypeForVariableReplacement obj st sss rst +getScalarTypeForVariableReplacement obj st sss ((pnt,_,[]):rst) = if pnt==obj then throw InvalidObjectException else getScalarTypeForVariableReplacement obj st sss rst +getScalarTypeForVariableReplacement _ _ [] _ = throw InvalidObjectException findScalarType :: String -> [(String,String,[(String,[(String,String,String,String)])])] -> String -findScalarType _ [] = throw InvalidScalarException findScalarType st ((name,typ,_):rst) | st==name = typ | otherwise = findScalarType st rst +findScalarType _ [] = throw InvalidScalarException -- findScalars :: [(String,[(String,String,[(String,[(String,String,String)])])])] -> [(String,[String],[String])] -> String -> [(String,String,[(String,[(String,String,String)])])] -- findScalars [] _ _ = throw InvalidObjectException -- findScalars sss ((pnt,_,cld):t) sobj = if sobj==pnt then foldl' (\y x->) [] cld else findScalars sss t sobj -- findScalars ((name,sclrs):t) [] sobj = if sobj==name then sclrs else findScalars t [] sobj replaceScalarVariable :: String -> String -> [(String,String,String)] -> String -replaceScalarVariable _ _ [] = throw InvalidScalarException replaceScalarVariable typ arg ((vn,vt,vval):rst) | arg==vn&&typ==vt = vval | arg==vn = throw MismatchedVariableTypeException | otherwise = replaceScalarVariable typ arg rst +replaceScalarVariable _ _ [] = throw InvalidScalarException -- findScalarType :: [(String,String,[(String,[(String,String,String)])])] -> String -> String -- findScalarType [] _ = throw InvalidObjectScalarFieldException -- findScalarType ((name,typ,_):t) sname = if sname==name then typ else findScalarType t sname diff --git a/src/Components/Parsers/QueryParser.hs b/src/Components/Parsers/QueryParser.hs --- a/src/Components/Parsers/QueryParser.hs +++ b/src/Components/Parsers/QueryParser.hs @@ -41,20 +41,19 @@ removeComments :: String -> String removeComments str = removeCommentsHelper str False removeCommentsHelper :: String -> Bool -> String -removeCommentsHelper [] _ = [] removeCommentsHelper ('#':t) _ = removeCommentsHelper t True -- 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 +removeCommentsHelper (h:t) False = h:removeCommentsHelper t False +removeCommentsHelper (_:t) _ = removeCommentsHelper t True +removeCommentsHelper "" _ = "" -- NOTE: this is used with only the textarea field of forms since they are giving line breaks these combinations... removeLinebreaks :: String -> String -removeLinebreaks "" = "" removeLinebreaks ('\n':t) = ' ':removeLinebreaks t removeLinebreaks ('\r':t) = removeLinebreaks t removeLinebreaks ('\t':t) = ' ':removeLinebreaks t removeLinebreaks (h:t) = h:removeLinebreaks t - +removeLinebreaks "" = "" {-----Step 2. VALIDATION-----} validateQuery :: String -> Bool @@ -64,21 +63,20 @@ validateBracketLocationQuery :: String -> Bool validateBracketLocationQuery str = validateBracketLocationQueryHelper str 0 0 validateBracketLocationQueryHelper :: String -> Int -> Int -> Bool -validateBracketLocationQueryHelper "" x y = (x==y) validateBracketLocationQueryHelper ('{':t) o c = validateBracketLocationQueryHelper t (o+1) c validateBracketLocationQueryHelper ('}':t) o c | o<=c = False | otherwise = validateBracketLocationQueryHelper t o (c+1) validateBracketLocationQueryHelper (_:t) o c = validateBracketLocationQueryHelper t o c +validateBracketLocationQueryHelper "" x y = (x==y) validateNoEmptyBrackets :: String -> Bool validateNoEmptyBrackets str = validateNoEmptyBracketsHelper str "" [] validateNoEmptyBracketsHelper :: String -> String -> [String] -> Bool -validateNoEmptyBracketsHelper "" acc nst = (length nst)<1 +validateNoEmptyBracketsHelper (' ':b) acc [] = validateNoEmptyBracketsHelper b acc [] +validateNoEmptyBracketsHelper (' ':b) acc (i:j) = validateNoEmptyBracketsHelper b acc (i:j) validateNoEmptyBracketsHelper ('{':b) acc [] = validateNoEmptyBracketsHelper b [] [acc] validateNoEmptyBracketsHelper ('}':b) acc [] = False -validateNoEmptyBracketsHelper (' ':b) acc [] = validateNoEmptyBracketsHelper b acc [] validateNoEmptyBracketsHelper (a:b) acc [] = validateNoEmptyBracketsHelper b (acc++[a]) [] -validateNoEmptyBracketsHelper (' ':b) acc (i:j) = validateNoEmptyBracketsHelper b acc (i:j) validateNoEmptyBracketsHelper ('{':b) acc (i:j) | (length acc)==0 = False | otherwise = validateNoEmptyBracketsHelper b [] (acc:i:j) @@ -86,6 +84,7 @@ | (length acc)==0 = False | otherwise = validateNoEmptyBracketsHelper b i j validateNoEmptyBracketsHelper (a:b) acc (i:j) = validateNoEmptyBracketsHelper b (acc++[a]) (i:j) +validateNoEmptyBracketsHelper "" acc nst = (length nst)<1 {-----Step 3. PARSING-----} @@ -100,20 +99,20 @@ getQueryAndFragments :: String -> (String, String) getQueryAndFragments str = getQueryAndFragmentsHelper str 0 False "" "" getQueryAndFragmentsHelper :: String -> Int -> Bool -> String -> String -> (String, String) -getQueryAndFragmentsHelper "" _ _ x y = (x, y) getQueryAndFragmentsHelper ('{':t) l False q f = getQueryAndFragmentsHelper t (l+1) False (q++"{") f getQueryAndFragmentsHelper ('}':t) 1 False q f = getQueryAndFragmentsHelper t 0 True (q++"}") f getQueryAndFragmentsHelper ('}':t) l False q f = getQueryAndFragmentsHelper t (l-1) False (q++"}") f getQueryAndFragmentsHelper (h:t) l False q f = getQueryAndFragmentsHelper t l False (q++[h]) f getQueryAndFragmentsHelper (h:t) l m q f = getQueryAndFragmentsHelper t l m q (f++[h]) +getQueryAndFragmentsHelper "" _ _ x y = (x, y) parseFragments :: String -> [(String,[String])] -> [(String,[String],[String])] -> [Fragment] parseFragments str svrobjs soa = parseFragmentsHelper str "" 0 [] svrobjs soa parseFragmentsHelper :: String -> String -> Int -> [Fragment] -> [(String,[String])] -> [(String,[String],[String])] -> [Fragment] -parseFragmentsHelper "" _ _ rslt _ _ = rslt parseFragmentsHelper ('{':t) acc l rslt svrobjs soa = parseFragmentsHelper t (acc++"{") (l+1) rslt svrobjs soa parseFragmentsHelper ('}':t) acc 1 rslt svrobjs soa = parseFragmentsHelper t [] 0 ((createFragment acc svrobjs soa):rslt) svrobjs soa -- completed one fragment parseFragmentsHelper ('}':t) acc l rslt svrobjs soa = parseFragmentsHelper t (acc++"}") (l-1) rslt svrobjs soa -- closed a nested object parseFragmentsHelper (h:t) acc l rslt svrobjs soa = parseFragmentsHelper t (acc++[h]) l rslt svrobjs soa +parseFragmentsHelper "" _ _ rslt _ _ = rslt -- with a fragment string that is without closing curly braces, we want a fragments createFragment :: String -> [(String,[String])] -> [(String,[String],[String])] -> Fragment createFragment str svrobjs soa = createFragmentHelper str 0 [] False False False False "" "" svrobjs soa @@ -124,7 +123,34 @@ o is for object -} createFragmentHelper :: String -> Int -> String -> Bool -> Bool -> Bool -> Bool -> String -> String -> [(String,[String])] -> [(String,[String],[String])] -> Fragment -createFragmentHelper "" l acc d n a o rst1 rst2 svrobjs soa = if (l==1&&d==True&&n==True&&a==True&&o==True) then Fragment { name=rst1,targetObject=(readServerObject rst2 svrobjs soa),replacement=acc } else throw ParseFragmentException +createFragmentHelper (' ':t) 0 acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t 0 "" True True True True rst1 rst2 svrobjs soa +createFragmentHelper ('{':t) 0 acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t 1 "" True True True True rst1 rst2 svrobjs soa +createFragmentHelper (_:_) 0 _ True True True True _ _ _ _ = throw ParseFragmentException +createFragmentHelper ('{':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t (l+1) (acc++"{") True True True True rst1 rst2 svrobjs soa +createFragmentHelper ('}':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t (l-1) (acc++"}") True True True True rst1 rst2 svrobjs soa +createFragmentHelper (' ':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++" ") True True True True rst1 rst2 svrobjs soa +createFragmentHelper (')':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++")") True True True True rst1 rst2 svrobjs soa +createFragmentHelper ('(':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"(") True True True True rst1 rst2 svrobjs soa +createFragmentHelper (':':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++":") True True True True rst1 rst2 svrobjs soa +createFragmentHelper ('$':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"$") True True True True rst1 rst2 svrobjs soa +createFragmentHelper ('@':t) l acc True True True True rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"@") True True True True rst1 rst2 svrobjs soa +createFragmentHelper (h:t) l acc True True True True 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 +createFragmentHelper (' ':t) l "" True False a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True False a o rst1 rst2 svrobjs soa +createFragmentHelper (' ':t) l acc True False a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True a o acc rst2 svrobjs soa +createFragmentHelper (h:t) l acc True False a o rst1 rst2 svrobjs soa + | (isValidFragmentNameChar h)==False = throw ParseFragmentException + | otherwise = createFragmentHelper t l (acc++[h]) True False a o rst1 rst2 svrobjs soa +createFragmentHelper (' ':t) l "" True True True False rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True False rst1 rst2 svrobjs soa +createFragmentHelper (h:t) l "" True True True False rst1 rst2 svrobjs soa + | (fromEnum h)>=97||(fromEnum h)<=122 = createFragmentHelper t l [h] True True True False rst1 rst2 svrobjs soa + | otherwise = throw ParseFragmentException +createFragmentHelper (' ':t) l acc True True True False rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True True rst1 acc svrobjs soa +createFragmentHelper ('{':t) l acc True True True False rst1 rst2 svrobjs soa = createFragmentHelper t (l+1) "" True True True True rst1 acc svrobjs soa +createFragmentHelper (h:t) l acc True True True False rst1 rst2 svrobjs soa + | isValidIdentifierChar h = createFragmentHelper t l (acc++[h]) True True True False rst1 rst2 svrobjs soa + | otherwise = throw ParseFragmentException createFragmentHelper ('f':t) l "" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "f" False n a o rst1 rst2 svrobjs soa createFragmentHelper ('r':t) l "f" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fr" False n a o rst1 rst2 svrobjs soa createFragmentHelper ('a':t) l "fr" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fra" False n a o rst1 rst2 svrobjs soa @@ -135,41 +161,15 @@ createFragmentHelper ('t':t) l "fragmen" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fragment" False n a o rst1 rst2 svrobjs soa createFragmentHelper (' ':t) l "fragment" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True n a o rst1 rst2 svrobjs soa createFragmentHelper (' ':t) l "" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" False n a o rst1 rst2 svrobjs soa -createFragmentHelper _ _ _ False _ _ _ _ _ _ _ = throw ParseFragmentException -createFragmentHelper (' ':t) l "" _ False a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True False a o rst1 rst2 svrobjs soa -createFragmentHelper (' ':t) l acc _ False a o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True a o acc rst2 svrobjs soa -createFragmentHelper (h:t) l acc _ False a o rst1 rst2 svrobjs soa - | (isValidFragmentNameChar h)==False = throw ParseFragmentException - | otherwise = createFragmentHelper t l (acc++[h]) True False a o rst1 rst2 svrobjs soa -createFragmentHelper (' ':t) l "" _ _ False o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True False o rst1 rst2 svrobjs soa -createFragmentHelper (' ':t) l "on" _ _ False o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True o rst1 rst2 svrobjs soa -createFragmentHelper (' ':_) _ _ _ _ False _ _ _ _ _ = throw ParseFragmentException -createFragmentHelper ('o':t) l acc _ _ False o rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"o") True True False o rst1 rst2 svrobjs soa -createFragmentHelper ('n':t) l acc _ _ False o rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"n") True True False o rst1 rst2 svrobjs soa -createFragmentHelper _ _ _ _ _ False _ _ _ _ _ = throw ParseFragmentException -createFragmentHelper (' ':t) l "" _ _ _ False rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True False rst1 rst2 svrobjs soa -createFragmentHelper (h:t) l "" _ _ _ False rst1 rst2 svrobjs soa - | (fromEnum h)>=97||(fromEnum h)<=122 = createFragmentHelper t l [h] True True True False rst1 rst2 svrobjs soa - | otherwise = throw ParseFragmentException -createFragmentHelper (' ':t) l acc _ _ _ False rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True True rst1 acc svrobjs soa -createFragmentHelper ('{':t) l acc _ _ _ False rst1 rst2 svrobjs soa = createFragmentHelper t (l+1) "" True True True True rst1 acc svrobjs soa -createFragmentHelper (h:t) l acc _ _ _ False rst1 rst2 svrobjs soa - | isValidIdentifierChar h = createFragmentHelper t l (acc++[h]) True True True False rst1 rst2 svrobjs soa - | otherwise = throw ParseFragmentException -createFragmentHelper (' ':t) 0 acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t 0 "" True True True True rst1 rst2 svrobjs soa -createFragmentHelper ('{':t) 0 acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t 1 "" True True True True rst1 rst2 svrobjs soa -createFragmentHelper _ 0 _ _ _ _ _ _ _ _ _ = throw ParseFragmentException -createFragmentHelper ('{':t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t (l+1) (acc++"{") True True True True rst1 rst2 svrobjs soa -createFragmentHelper ('}':t) l acc _ _ _ _ rst1 rst2 svrobjs soa = createFragmentHelper t (l-1) (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 ('(':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 ('@':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 = 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 +createFragmentHelper (_:_) _ _ False _ _ _ _ _ _ _ = throw ParseFragmentException +createFragmentHelper (' ':t) l "" True True False o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True False o rst1 rst2 svrobjs soa +createFragmentHelper (' ':t) l "on" True True False o rst1 rst2 svrobjs soa = createFragmentHelper t l "" True True True o rst1 rst2 svrobjs soa +createFragmentHelper (' ':_) _ _ True True False _ _ _ _ _ = throw ParseFragmentException +createFragmentHelper ('o':t) l acc True True False o rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"o") True True False o rst1 rst2 svrobjs soa +createFragmentHelper ('n':t) l acc True True False o rst1 rst2 svrobjs soa = createFragmentHelper t l (acc++"n") True True False o rst1 rst2 svrobjs soa +createFragmentHelper (_:_) _ _ True True False _ _ _ _ _ = throw ParseFragmentException +createFragmentHelper "" l acc d n a o rst1 rst2 svrobjs soa = if (l==1&&d==True&&n==True&&a==True&&o==True) then Fragment { name=rst1,targetObject=(readServerObject rst2 svrobjs soa),replacement=acc } else 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) @@ -179,12 +179,12 @@ -- call after infering types on nested objects -- get block in this scope splitSubject :: String -> String -> Int -> (String,String) -splitSubject "" acc _ = (acc,"") splitSubject (h:t) acc l | l<0 = (acc,h:t) splitSubject ('{':t) acc l = splitSubject t (acc++"{") (l+1) splitSubject ('}':t) acc l = splitSubject t (acc++"}") (l-1) splitSubject (h:t) acc l = splitSubject t (acc++[h]) l +splitSubject "" acc _ = (acc,"") -- -- substitute target string with replacement string within subject string...return result -- parse provided string to obtain query {- @@ -198,9 +198,9 @@ 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 +composeObjectsHelper "" _ _ _ _ _ _ = throw EmptyQueryException -- ...separate and determine operation -- TODO: implement operations -- determineOperation :: String -> (Operation,String) @@ -217,22 +217,22 @@ 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 (',':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 +separateRootObjectsHelper "" _ _ _ _ _ _ = [] -- 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])] -> [(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 sos soa sobj createNestedObjectHelper (h:t) acc svrobjs sos soa vars fmts sobj = createNestedObjectHelper t (acc++[h]) svrobjs sos soa vars fmts sobj +createNestedObjectHelper "" _ _ _ _ _ _ _ = throw InvalidObjectException -- we should not encounter this since we already checked against empty brackets -- given object header without any braces, we want a name. parseServerObject :: String -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> Maybe ServerObject -> ServerObject parseServerObject "" svrobjs sos soa Nothing = readServerObject "" svrobjs soa @@ -259,23 +259,26 @@ | (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 parseSubSelection (h:t) = parseSubSelection t +parseSubSelection "" = Nothing :: SubSelection -- 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])] -> [(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 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 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 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 (':':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 @@ -292,16 +295,6 @@ | (length acc2)>0 = parseSubFieldsHelper selectTail (acc2++"("++subselect) "" svrobjs sos soa inc vars fmts sobj where (subselect,selectTail) = getSubSelection t -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 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 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 @@ -322,18 +315,24 @@ (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment ('.':t) (fragmentName,fragmentTail) = findFragment ('.':t) fContents = expandFragment fragmentName sobj fmts -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 - +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 _ _ _ = [] + checkInlinefragment :: String -> (Bool,String,String,String) checkInlinefragment str = checkInlinefragmentHelper str "" False "" checkInlinefragmentHelper :: String -> String -> Bool -> String -> (Bool,String,String,String) -checkInlinefragmentHelper "" _ _ _ = (False,"","","") checkInlinefragmentHelper ('.':t) "" sobj obj = checkInlinefragmentHelper t "." False "" checkInlinefragmentHelper _ "" _ _ = throw ParseFragmentException checkInlinefragmentHelper ('.':t) "." sobj obj = checkInlinefragmentHelper t ".." False "" @@ -359,7 +358,8 @@ checkInlinefragmentHelper (' ':t) acc _ obj = checkInlinefragmentHelper t acc True obj checkInlinefragmentHelper ('{':t) acc _ obj = (True,obj,contents,tail) where - (contents,tail) = splitSubject t "" 0 + (contents,tail) = splitSubject t "" 0 +checkInlinefragmentHelper "" _ _ _ = (False,"","","") checkInlinefragmentHelper _ _ _ _ = throw ParseFragmentException createInlinefragmentObject :: String -> String -> [(String,String,String)] -> [Fragment] -> [(String,[String])] -> [(String,[(String,[String])])] -> [(String,[String],[String])] -> InlinefragmentObject @@ -369,44 +369,40 @@ findFragment "" = throw ParseFragmentException findFragment str = findFragmentHelper str "" findFragmentHelper :: String -> String -> (String,String) -findFragmentHelper "" acc = (acc,"") +findFragmentHelper (h:t) ('.':'.':'.':acc) + | isValidFragmentNameChar h = findFragmentHelper t (('.':'.':'.':acc)++[h]) findFragmentHelper ('.':t) "" = findFragmentHelper t "." -findFragmentHelper _ "" = throw ParseFragmentException +findFragmentHelper (_:_) "" = throw ParseFragmentException findFragmentHelper ('.':t) "." = findFragmentHelper t ".." -findFragmentHelper _ "." = throw ParseFragmentException +findFragmentHelper (_:_) "." = throw ParseFragmentException findFragmentHelper ('.':t) ".." = findFragmentHelper t "..." -findFragmentHelper _ ".." = throw ParseFragmentException -findFragmentHelper (h:t) "..." - | isValidFragmentNameChar h = findFragmentHelper t ("..."++[h]) - | otherwise = throw ParseFragmentException +findFragmentHelper (_:_) ".." = throw ParseFragmentException findFragmentHelper (' ':t) acc = (acc,t) -findFragmentHelper (h:t) acc - | isValidFragmentNameChar h = findFragmentHelper t (acc++[h]) +findFragmentHelper "" acc = (acc,"") findFragmentHelper _ _ = throw ParseFragmentException expandFragment :: String -> ServerObject -> [Fragment] -> String -expandFragment _ _ [] = throw ParseFragmentException expandFragment fnm sobj (h:t) = if (targetObject h)==sobj&&fnm==("..."++(name h)) then replacement h else expandFragment fnm sobj t +expandFragment _ _ [] = throw ParseFragmentException removeLeadingSpaces :: String -> String -removeLeadingSpaces "" = "" removeLeadingSpaces (' ':t) = removeLeadingSpaces t removeLeadingSpaces str = str -- EFFECTS: return subselection and String remainder getSubSelection :: String -> (String,String) getSubSelection str = getSubSelectionHelper str "" getSubSelectionHelper :: String -> String -> (String,String) -getSubSelectionHelper "" acc = ("","") getSubSelectionHelper (')':t) acc = (acc++")", t) getSubSelectionHelper (h:t) acc = getSubSelectionHelper t (acc++[h]) +getSubSelectionHelper "" acc = ("","") -- split level at and without uneven brace. splitLevel :: String -> String -> Int -> (String,String) -splitLevel "" acc _ = (acc,[]) splitLevel (h:t) acc l | l<0 = (acc,(h:t)) splitLevel ('{':t) acc l = splitLevel t (acc++"{") (l+1) splitLevel ('}':t) acc l = splitLevel t (acc++"}") (l-1) splitLevel (h:t) acc l = splitLevel t (acc++[h]) l +splitLevel "" acc _ = (acc,[]) -- determine if directive result is to include or exclude checkDirective :: String -> [(String,String,String)] -> (Bool, String) checkDirective qry vars = if (isDirective qry)==False then (True,qry) else checkDirectiveHelper (getDirective qry) vars @@ -421,9 +417,8 @@ directive = toLowercase dir value = if h=='$' then toLowercase $ getVariableValue vars (h:t) else toLowercase (h:t) isDirective :: String -> Bool -isDirective "" = False -isDirective ('@':_) = True isDirective (' ':t) = isDirective t +isDirective ('@':_) = True isDirective _ = False getDirective :: String -> (String,String,String) getDirective (' ':t) = getDirective t @@ -433,30 +428,30 @@ val = removeSideSpaces $ foldl' (\y x -> if x==':' then "" else y++[x]) "" $ getPrefix t ')' tail = getSuffix t ')' getPrefix :: String -> Char -> String -getPrefix "" _ = "" getPrefix (h:t) chr = if h==chr then "" else h:getPrefix t chr +getPrefix "" _ = "" getSuffix :: String -> Char -> String -getSuffix "" _ = "" getSuffix (h:t) chr = if h==chr then t else getSuffix t chr +getSuffix "" _ = "" toLowercase :: String -> String toLowercase str = [toLower c | c <- str] getVariableValue :: [(String,String,String)] -> String -> String -getVariableValue [] _ = throw InvalidVariableNameException getVariableValue ((name,"Bool",val):t) var | (name==var) = val getVariableValue ((name,typ,val):t) var | (name==var) = throw MismatchedVariableTypeException | otherwise = getVariableValue t var +getVariableValue [] _ = throw InvalidVariableNameException -- pull level and leave out closing brace. extractLevel :: String -> String extractLevel "" = "" extractLevel str = extractLevelHelper str 0 extractLevelHelper :: String -> Int -> String -extractLevelHelper "" _ = "" extractLevelHelper ('{':t) l = '{':extractLevelHelper t (l+1) extractLevelHelper ('}':t) 0 = "" extractLevelHelper ('}':t) l = '}':extractLevelHelper t (l-1) extractLevelHelper (h:t) l = h:extractLevelHelper t l +extractLevelHelper "" _ = "" -- -- remove level and leave out closing brace -- removeLevel :: String -> String -- removeLevel [] = [] diff --git a/src/Components/Parsers/ServerSchemaJsonParser.hs b/src/Components/Parsers/ServerSchemaJsonParser.hs --- a/src/Components/Parsers/ServerSchemaJsonParser.hs +++ b/src/Components/Parsers/ServerSchemaJsonParser.hs @@ -52,12 +52,12 @@ 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 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]) 1 +parseParentsIterator soa [] = soa getObjects :: Result [JSObject JSValue] -> [JSObject JSValue] getObjects (Error _) = throw ImportSchemaException getObjects (Ok objects) = objects @@ -88,19 +88,19 @@ name = getString (valFromObj "Name" h :: Result String) 1 options = getScalarArgumentOptions (getObjects (valFromObj "Options" h :: Result [JSObject JSValue])) getScalarArgumentOptions :: [JSObject JSValue] -> [(String,String,String,String)] -getScalarArgumentOptions [] = [] getScalarArgumentOptions (h:t) = (name,typ,prefix,suffix):getScalarArgumentOptions t where name = getString (valFromObj "Name" h :: Result String) 1 typ = getType (valFromObj "Type" h :: Result String) prefix = getString (valFromObj "Prefix" h :: Result String) 1 suffix = getString (valFromObj "Suffix" h :: Result String) 1 +getScalarArgumentOptions [] = [] 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 +getObjectFields [] = [] getType :: Result String -> String getType (Ok "Text") = "Text" getType (Ok "ByteString") = "ByteString" @@ -125,40 +125,38 @@ 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) = (elem nm rst==False)&&isNoDupsNames rst +isNoDupsNames [] = True isNoDupsScalars :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool 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) = (foldr' (\(x,_,_) y->name/=x&&y) True rst)&&(isNoDupsScalarArguments args)&&isNoDupsScalarNames rst +isNoDupsScalarNames [] = True isNoDupsScalarArguments :: [(String,[(String,String,String,String)])] -> Bool -isNoDupsScalarArguments [] = True isNoDupsScalarArguments ((name,opts):rst) = (foldr' (\(n,o) y->name/=n&&y&&isNoDupsArgumentOptions o) True rst)&&isNoDupsScalarArguments rst +isNoDupsScalarArguments [] = True isNoDupsArgumentOptions :: [(String,String,String,String)] -> Bool -isNoDupsArgumentOptions [] = True isNoDupsArgumentOptions ((name,_,_,_):rst) = (foldr' (\(n,_,_,_) y->name/=n&&y) True rst)&&isNoDupsArgumentOptions rst +isNoDupsArgumentOptions [] = True isNoDupsNestedObjects :: [(String,[(String,[String])])] -> Bool -isNoDupsNestedObjects [] = True isNoDupsNestedObjects ((_,[]):rst) = isNoDupsNestedObjects 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 +isNoDupsNestedObjects [] = True isNoDupsRelationships :: [(String,String,[String])] -> Bool -isNoDupsRelationships [] = True isNoDupsRelationships ((from,to,_):rst) = (foldr' (\(a,b,_) y->(from/=a||to/=b)&&y) True rst)&&isNoDupsRelationships rst +isNoDupsRelationships [] = True -- shared scalars are same type isValidParentScalars :: [(String,[String],[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool -isValidParentScalars [] _ = True isValidParentScalars ((_,_,[]):t) sss = isValidParentScalars t sss isValidParentScalars ((_,_,_:[]):t) sss = isValidParentScalars t sss isValidParentScalars ((_,_,(h:cld)):t) sss = (isValidScalarsType (getPrimitiveScalars h sss) cld sss)&&isValidParentScalars t sss +isValidParentScalars [] _ = True getPrimitiveScalars :: String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -getPrimitiveScalars _ [] = throw ImportSchemaChildrenException getPrimitiveScalars name ((nm,st):t) = if name==nm then foldr' (\(n,tp,_) y->(n,tp):y) [] st else getPrimitiveScalars name t +getPrimitiveScalars _ [] = throw ImportSchemaChildrenException isValidScalarsType :: [(String,String)] -> [String] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool -isValidScalarsType _ [] _ = True -isValidScalarsType [] _ _ = True 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 - +isValidScalarsType [] _ _ = True diff --git a/src/Components/Parsers/VariablesParser.hs b/src/Components/Parsers/VariablesParser.hs --- a/src/Components/Parsers/VariablesParser.hs +++ b/src/Components/Parsers/VariablesParser.hs @@ -14,23 +14,23 @@ ) --- with a variables string and query string, we want the query variables, the type, and the value +-- from a variables string and query string to the query variables, the type, and the value parseVariables :: String -> String -> [(String,String,String)] parseVariables var qry = filterToDesired (parseVariableValuePairs var) (getVariableTypePairs qry) --- with variable-values and variable-types, we want query variable-type-values +-- from variable-values and variable-types to query variable-type-values filterToDesired :: [(String,String)] -> [(String,String,Maybe String)] -> [(String,String,String)] filterToDesired _ [] = [] filterToDesired [] tvar = if (anyMaybeMissingValues tvar)==True then throw MissingVariableValueException else getDefaultValues tvar filterToDesired vvar tvars = [findVariableValue tvar vvar | tvar<-tvars] findVariableValue :: (String,String,Maybe String) -> [(String,String)] -> (String,String,String) -findVariableValue (vname,vtype,Nothing) [] = throw MissingVariableValueException -findVariableValue (vname,vtype,Just vval) [] = (vname,vtype,vval :: String) findVariableValue (vname1,vtype,vval1) ((vname2,vval2):t) = if vname1==vname2 then (vname1,vtype,vval2) else findVariableValue (vname1,vtype,vval1) t +findVariableValue (vname,vtype,Just vval) [] = (vname,vtype,vval :: String) +findVariableValue (vname,vtype,Nothing) [] = throw MissingVariableValueException anyMaybeMissingValues :: [(String,String,Maybe String)] -> Bool anyMaybeMissingValues vars = foldr (\(nam,typ,val) y -> val==Nothing||y) False vars getDefaultValues :: [(String,String,Maybe String)] -> [(String,String,String)] getDefaultValues vars = [(nam,typ,val) | (nam,typ,Just val)<-vars] --- from given variables argument, we want variable-values +-- from given variables argument to variable-values parseVariableValuePairs :: String -> [(String,String)] parseVariableValuePairs [] = [] parseVariableValuePairs vars = castValues $ fromJSObject $ checkVariables (decode vars :: Result (JSObject JSValue)) @@ -52,8 +52,8 @@ where epilogue = getQueryEpilogue qry getQueryEpilogue :: String -> String -getQueryEpilogue [] = throw EmptyQueryException getQueryEpilogue (h:t) = if h=='{' then [] else h:(getQueryEpilogue t) +getQueryEpilogue [] = throw EmptyQueryException removeLeadingSpaces :: String -> String removeLeadingSpaces (h:t) = if h==' ' then removeLeadingSpaces t else (h:t) separateVariables :: Bool -> String -> Bool -> String -> String -> String -> [(String,String,Maybe String)] diff --git a/src/Components/QueryComposers/SQLQueryComposer.hs b/src/Components/QueryComposers/SQLQueryComposer.hs --- a/src/Components/QueryComposers/SQLQueryComposer.hs +++ b/src/Components/QueryComposers/SQLQueryComposer.hs @@ -35,44 +35,68 @@ ) -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],[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)]) +makeSqlQueries :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> ([[[(Int,Bool,String)]]],[[[String]]]) +makeSqlQueries rojs sss sodn sor soa = unzip [makeSqlQuerySet sss sodn sor soa robj | robj<-rojs] +makeSqlQuerySet :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> RootObject -> ([[(Int,Bool,String)]],[[String]]) -- [([(Int,String)],[String])] ([[(Int,String)]],[[String]]) +makeSqlQuerySet sss sodn sor soa obj = if (length dbNames)==1 then firstResult else (foldl' (\(tbls,qrs) (ntbls,nqrs) -> (tbls++ntbls,qrs++nqrs)) firstResult [(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 0 True [] [] [] []) | (xIds,x)<-(tail dbNames), let xName=x++(show 1)]) where dbNames = translateServerObjectToDBName (getServerObject obj) sodn soa (firstIds,firstTable) = head dbNames firstTableName = firstTable++(show 1) + firstResult = 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 0 True [] [] [] [] -- 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],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++";")] -addSqlQueryFields [] counts select from order (_:b) (h:t) sss sodn sor soa tbls = addSqlQueryFields h counts select from order b t sss sodn sor soa tbls -addSqlQueryFields (_:t) _ _ _ _ [] _ _ _ _ _ _ = throw CreatingSqlQueryObjectsException -- fields without objects -addSqlQueryFields ((Left (ScalarType _ "__typename" _ _)):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 -addSqlQueryFields ((Left (ScalarType _ name Nothing _)):t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls = addSqlQueryFields t counts (select++ltable++(show ltableNo)++"."++name++",") from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls -addSqlQueryFields ((Left (ScalarType _ name (Just trans) arg)):t) counts select from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls = addSqlQueryFields t counts (select++prefix++ltable++(show ltableNo)++"."++name++suffix++",") from order ((ltable,ltableNo):names) fields sss sodn sor soa tbls + numStr = show number +-- make queries for object of one table (most common is first - PCA example) +addSqlQueryFields :: SubFields -> Map String Int -> String -> String -> String -> String -> [(String,Int)] -> [SubFields] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> Int -> Bool -> [(Int,Bool,String)] -> [(Int,Bool,String)] -> [(String,String,String,String)] -> [(String,String,String,String)] -> ([[(Int,Bool,String)]],[[String]]) -- [[((Int,String),String)]] +addSqlQueryFields ((Left (ScalarType _ "__typename" _ _)):t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs = addSqlQueryFields t counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs +addSqlQueryFields ((Left (ScalarType _ name Nothing _)):t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs = addSqlQueryFields t counts ids (select++ltable++(show ltableNo)++"."++name++",") from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs +addSqlQueryFields ((Left (ScalarType _ name (Just trans) arg)):t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs = addSqlQueryFields t counts ids (select++prefix++ltable++(show ltableNo)++"."++name++suffix++",") from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs where (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++(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) +-- since only difference is table name, I should remove repeated computations by changing only name. +addSqlQueryFields ((Right (Left h)):t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs + | tablesLen>1 = foldl' (\(info,qrs) (xIds,x)-> let + newCounts=calcNewCounts ltable x counts sor + xNum=(!) newCounts x + xName=x++(show xNum) + (nInfo,nQrs) = addSqlQueryFields objSfs newCounts (ids++(makeTableIdentifier xName xIds "")) "" (from++(makeTransitions newCounts (getDBObjectRelationships ltable x sor) h)) (order++(makeTableIdentifier xName xIds " asc")) ((x,xNum):(ltable,ltableNo):names) emptiedFlds sss sodn sor soa newLvl True flsRcds [] [] [] + in + (info++nInfo,qrs++nQrs) + ) firstResult (tail tables) + | tablesLen==1 = firstResult where tables = translateServerObjectToDBName (getServerObject h) sodn soa + tablesLen = length tables (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 + newLvl = lvl+1 + objSfs = getSubFields h + firstResult = addSqlQueryFields objSfs firstTableNewCounts (ids++(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 newLvl True (li++[(lvl,True,ltable)]++ri) [] (lqs++[(ids,select,from,order)]++rqs) [] + emptiedFlds = ([]:[[] | _<-fields]) + flsRcds = (map (\(nlvl,_,ntbl)->(nlvl,False,ntbl)) li)++[(lvl,False,ltable)]++(map (\(nlvl,_,ntbl)->(nlvl,False,ntbl)) ri) +addSqlQueryFields [] _ ids select from order ((ltbl,_):_) [] _ _ _ _ lvl True li ri lqs rqs = ([li++((lvl,True,ltbl):ri)],[lQrs++(((removeLastChar (ids++select))++from++(removeLastChar order)++";"):rQrs)]) + where + lQrs = [(removeLastChar (nids++sel))++frm++(removeLastChar ord)++";" | (nids,sel,frm,ord)<-lqs] + rQrs = [(removeLastChar (nids++sel))++frm++(removeLastChar ord)++";" | (nids,sel,frm,ord)<-rqs] +addSqlQueryFields [] counts ids select from order ((ltbl,_):b) (h:t) sss sodn sor soa lvl True li ri lqs rqs = addSqlQueryFields h counts nids sel frm ord b t sss sodn sor soa nlvl nfst nli nri (init lqs) nrqs + where + (nlvl,nfst,_) = last li + (nids,sel,frm,ord) = last lqs + nrqs = (ids,select,from,order):rqs + nli = init li + nri = (lvl,True,ltbl):ri +addSqlQueryFields _ _ _ _ _ _ ((ltable,_):_) _ _ _ _ _ lvl False li ri _ rqs = ([li++((lvl,False,ltable):ri)],[rQrs]) + where + rQrs = [(removeLastChar (nids++sel))++frm++(removeLastChar ord)++";" | (nids,sel,frm,ord)<-rqs] +addSqlQueryFields ((Right (Right (InlinefragmentObject ifo sfs))):t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs + | isServerObjectTable ltable ifo sodn soa = addSqlQueryFields (sfs++t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl True li ri lqs rqs +addSqlQueryFields (_:t) counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl fst li ri lqs rqs = addSqlQueryFields t counts ids select from order ((ltable,ltableNo):names) fields sss sodn sor soa lvl fst li ri lqs rqs +addSqlQueryFields _ _ _ _ _ _ [] _ _ _ _ _ _ _ _ _ _ _ = throw CreatingSqlQueryObjectFieldsException -- fields without objects calcNewCounts :: String -> String -> Map String Int -> [(String,String,[String])] -> Map String Int calcNewCounts from to pcnt sor = foldl' (\y x-> insertWith (+) x 1 y) pcnt $ getNewTables $ getDBObjectRelationships from to sor removeLastChar :: String -> String @@ -82,11 +106,11 @@ getNewTables :: [String] -> [String] getNewTables lnk = getNewTablesHelper (tail $ tail lnk) 0 getNewTablesHelper :: [String] -> Int -> [String] -getNewTablesHelper [] _ = [] getNewTablesHelper (h:t) 0 = h:getNewTablesHelper (tail t) 3 getNewTablesHelper (h:t) idx | ((mod idx 3)==0) = h:getNewTablesHelper t (idx+1) | otherwise = getNewTablesHelper t (idx+1) +getNewTablesHelper [] _ = [] makeTransitions :: Map String Int -> [String] -> NestedObject -> String makeTransitions counts (h1:h2:h3:h4:h5:h6:h7:t) nobj = " left join "++h5++" as "++h5++table5NumStr++" on "++(makeEqColumns (h1++(show $ (!) counts h1)) h2 (h5++table5NumStr) h6)++(completeTransition counts (h3:h4:h5:h6:h7:t) nobj) where @@ -96,12 +120,12 @@ table3NumStr = show $ (!) counts h3 makeTransitions _ _ _ = throw RelationshipConfigurationException completeTransition :: Map String Int -> [String] -> NestedObject -> String -completeTransition counts (h1:h2:h3:h4:h5:[]) nobj = " left join "++(if (withSubSelection nobj)==True then "(select * from "++h1++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")" else h1)++" as "++h1++table1NumStr++" on "++(makeEqColumns (h3++(show $ (!) counts h3)) h5 (h1++table1NumStr) h2) - where - table1NumStr = show $ (!) counts h1 completeTransition counts (h1:h2:h3:h4:h5:h6:h7:h8:t) nobj = " left join "++h6++" as "++h6++table6NumStr++" on "++(makeEqColumns (h3++(show $ (!) counts h3)) h5 (h6++table6NumStr) h7)++(completeTransition counts (h1:h2:h6:h7:h8:t) nobj) where table6NumStr = show $ (!) counts h6 +completeTransition counts (h1:h2:h3:h4:h5:[]) nobj = " left join "++(if (withSubSelection nobj)==True then "(select * from "++h1++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")" else h1)++" as "++h1++table1NumStr++" on "++(makeEqColumns (h3++(show $ (!) counts h3)) h5 (h1++table1NumStr) h2) + where + table1NumStr = show $ (!) counts h1 completeTransition counts _ _ = throw RelationshipConfigurationException makeEqColumns :: String -> String -> String -> String -> String makeEqColumns tb1 col1 tb2 col2 = if (elem ' ' col1)==False&&(elem ' ' col2)==False then tb1++"."++col1++"="++tb2++"."++col2 else makeEqColumnsHelper "" tb1 col1 tb2 col2 @@ -119,32 +143,31 @@ getFirstColumn :: String -> (String,String) getFirstColumn str = getFirstColumnHelper "" str getFirstColumnHelper :: String -> String -> (String,String) -getFirstColumnHelper _ "" = ("","") getFirstColumnHelper acc (' ':t) = (acc,t) getFirstColumnHelper acc (h:t) = getFirstColumnHelper (acc++[h]) t +getFirstColumnHelper _ "" = ("","") getPrimitiveScalarTypeArgumentOptions :: ServerObject -> String -> String -> Argument -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> (String,String) -getPrimitiveScalarTypeArgumentOptions _ _ _ _ [] = throw InvalidObjectException getPrimitiveScalarTypeArgumentOptions obj st trans arg ((h,sts):rst) | h==obj = getScalarTypeArgumentsOptions st trans arg sts | otherwise = getPrimitiveScalarTypeArgumentOptions obj st trans arg rst +getPrimitiveScalarTypeArgumentOptions _ _ _ _ [] = throw InvalidObjectException getScalarTypeArgumentsOptions :: String -> String -> Argument -> [(String,String,[(String,[(String,String,String,String)])])] -> (String,String) -getScalarTypeArgumentsOptions _ _ _ [] = throw InvalidScalarException getScalarTypeArgumentsOptions st trans arg ((name,_,args):t) | st==name = getArgumentOptions trans arg args | otherwise = getScalarTypeArgumentsOptions st trans arg t +getScalarTypeArgumentsOptions _ _ _ [] = throw InvalidScalarException getArgumentOptions :: String -> Argument -> [(String,[(String,String,String,String)])] -> (String,String) -getArgumentOptions _ _ [] = throw InvalidArgumentException getArgumentOptions trans arg ((aname,opts):rst) | trans==aname = getArgumentOption arg opts | otherwise = getArgumentOptions trans arg rst +getArgumentOptions _ _ [] = throw InvalidArgumentException getArgumentOption :: Argument -> [(String,String,String,String)] -> (String,String) -getArgumentOption _ [] = throw InvalidArgumentException getArgumentOption Nothing ((_,_,prefix,suffix):_) = (prefix,suffix) getArgumentOption (Just opt) ((name,_,prefix,suffix):rst) | opt==name = (prefix,suffix) | otherwise = getArgumentOption (Just opt) rst +getArgumentOption _ [] = throw InvalidArgumentException makeTableIdentifier :: String -> [String] -> String -> String +makeTableIdentifier tbl (fid:ids) ins = foldl' (\y x->y++tbl++"."++x++ins++",") [] (fid:ids) makeTableIdentifier _ [] _ = [] -makeTableIdentifier tbl (h:[]) ins = tbl++"."++h++ins -makeTableIdentifier tbl (h:t) ins = tbl++"."++h++ins++","++(makeTableIdentifier tbl t ins) diff --git a/src/GraphQLdbi.hs b/src/GraphQLdbi.hs --- a/src/GraphQLdbi.hs +++ b/src/GraphQLdbi.hs @@ -571,7 +571,7 @@ processQueryString :: SchemaSpecs -- ^ This is the data about your schema -> String -- ^ This is the GraphQL query -> String -- ^ This is the variables string - -> (QueryData,[[String]]) -- ^ The return value is a tuple with package objects and list with grouped sql query strings. + -> (QueryData,[[[String]]]) -- ^ The return value is a tuple with package objects and list with grouped sql query strings. processQueryString (svrobjs,sss,sos,sodn,sor,soa) qry vars = let dvars = parseVariables vars qry str = processString qry @@ -603,7 +603,7 @@ -} processQueryData :: SchemaSpecs -- ^ This is the schema data from the first method -> QueryData -- ^ This is the package objects that is from processQueryString function. - -> [[[[Text]]]] -- ^ This is the database query results value in the same order and after casting to Text values. + -> [[[[[Text]]]]] -- ^ This is the database query results value in the same order and after casting to Text values. -> String -- ^ The return value is a string type to describe the GraphQL-organized return values. processQueryData (_,sss,_,sodn,_,soa) cc dt = let (ro,tb) = unzip cc diff --git a/src/Model/ServerExceptions.hs b/src/Model/ServerExceptions.hs --- a/src/Model/ServerExceptions.hs +++ b/src/Model/ServerExceptions.hs diff --git a/src/Model/ServerObjectTypes.hs b/src/Model/ServerObjectTypes.hs --- a/src/Model/ServerObjectTypes.hs +++ b/src/Model/ServerObjectTypes.hs @@ -41,4 +41,4 @@ 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]])] +type QueryData = [(RootObject,[[(Int,Bool,String)]])]