graphql-w-persistent 0.5.0.0 → 0.6.0.0

raw patch · 15 files changed

+2094/−1851 lines, 15 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- GraphQLdbi: InvalidObjectScalarFieldException :: QueryException

- GraphQLdbi: InvalidObjectSubFieldException :: QueryException

+ GraphQLdbi: ImportSchemaDuplicateException :: QueryException

+ GraphQLdbi: InvalidObjectSubfieldException :: QueryException

+ GraphQLdbi: processSchema :: MonadIO m => FilePath -> m SchemaSpecs

- GraphQLdbi: processQueryData :: MonadIO m => FilePath -> [(RootObject, [[String]])] -> [[[[Text]]]] -> m String

+ GraphQLdbi: processQueryData :: SchemaSpecs -> QueryData -> [[[[Text]]]] -> String

- GraphQLdbi: processQueryString :: MonadIO m => FilePath -> String -> String -> m ([(RootObject, [[String]])], [[String]])

+ GraphQLdbi: processQueryString :: SchemaSpecs -> String -> String -> (QueryData, [[String]])

Files

ChangeLog.md +72/−68
LICENSE +13/−13
Setup.hs +2/−2
graphql-w-persistent.cabal +90/−90
src/Components/DataProcessors/ListDataProcessor.hs +174/−158
src/Components/ObjectHandlers/ObjectsHandler.hs +131/−143
src/Components/ObjectHandlers/ServerObjectTrimmer.hs +86/−108
src/Components/ObjectHandlers/ServerObjectValidator.hs +106/−79
src/Components/Parsers/QueryParser.hs +491/−459
src/Components/Parsers/ServerSchemaJsonParser.hs +153/−103
src/Components/Parsers/VariablesParser.hs +93/−81
src/Components/QueryComposers/SQLQueryComposer.hs +145/−85
src/GraphQLdbi.hs +454/−386
src/Model/ServerExceptions.hs +43/−43
src/Model/ServerObjectTypes.hs +41/−33

ChangeLog.md view

@@ -1,69 +1,73 @@-# Revision history for graphql-w-persistent--## 0.5.0.0 -- 2019-08-08--* update join for maximizing data retrieval, add meta-fields, fix a problem with subsequent nested object fields--## 0.4.0.0 -- 2019-06-17--* add inline fragments and comment lines--## 0.3.2.1 -- 2019-05-18--* fix variables bug (now supporting multiple variables), database query bug (translating correctly nested objects), fragments bug (within variables are now supported), and added include and skip directives support--## 0.3.1.2 -- 2019-04-21--* bug fix: nested objects are now supporting filters on attribute--## 0.3.1.1 -- 2018-11-07--* bug fix: processing sql data was incorrect from object to nested object with generalized database entities, though this is now fixed.--## 0.3.1.0 -- 2018-11-07--* Give thrown exceptions--## 0.3.0.0 -- 2018-11-06--* Bug-fix to reenable relationship queries and casting returned values with Int, Rationals/Decimals, and Doubles...api change is arguments change to processing data function--## 0.2.0.1 -- 2018-11-05--* Fix to accept empty variable arguments and default values--## 0.2.0.0 -- 2018-11-05--* Variables are available...api change is schema changes--## 0.1.0.7 -- 2018-10-26 [stable release]--* Json file schema--## 0.1.0.6 -- 2018-10-24--* Revise documentation--## 0.1.0.5 -- 2018-10-22--* Add duplicated queries feature--## 0.1.0.4 -- 2018-10-19--* Fix type heirarchies and arguments--## 0.1.0.3 -- 2018-10-18--* Revise documentation and Bug fix--## 0.1.0.2 -- 2018-10-18--* Bug fixes--## 0.1.0.1 -- 2018-10-18--* Added documentation--## 0.1.0.0 -- 2018-10-18-+# Revision history for graphql-w-persistent
+
+## 0.6.0.0 -- 2019-08-31
+
+* reduce computations, fix bug on variables to parent object arguments, fix bug when querying parental objects, add scalar argument feature
+
+## 0.5.0.0 -- 2019-08-08
+
+* update join to maximize data retrieval, add meta-fields, fix a problem with subsequent nested object fields
+
+## 0.4.0.0 -- 2019-06-17
+
+* add inline fragments and comment lines
+
+## 0.3.2.1 -- 2019-05-18
+
+* fix variables bug (now supporting multiple variables), database query bug (translating correctly nested objects), fragments bug (within variables are now supported), and added include and skip directives support
+
+## 0.3.1.2 -- 2019-04-21
+
+* bug fix: nested objects are now supporting filters on attribute
+
+## 0.3.1.1 -- 2018-11-07
+
+* bug fix: processing sql data was incorrect from object to nested object with generalized database entities, though this is now fixed.
+
+## 0.3.1.0 -- 2018-11-07
+
+* Give thrown exceptions
+
+## 0.3.0.0 -- 2018-11-06
+
+* Bug-fix to reenable relationship queries and casting returned values with Int, Rationals/Decimals, and Doubles...api change is arguments change to processing data function
+
+## 0.2.0.1 -- 2018-11-05
+
+* Fix to accept empty variable arguments and default values
+
+## 0.2.0.0 -- 2018-11-05
+
+* Variables are available...api change is schema changes
+
+## 0.1.0.7 -- 2018-10-26 [stable release]
+
+* Json file schema
+
+## 0.1.0.6 -- 2018-10-24
+
+* Revise documentation
+
+## 0.1.0.5 -- 2018-10-22
+
+* Add duplicated queries feature
+
+## 0.1.0.4 -- 2018-10-19
+
+* Fix type heirarchies and arguments
+
+## 0.1.0.3 -- 2018-10-18
+
+* Revise documentation and Bug fix
+
+## 0.1.0.2 -- 2018-10-18
+
+* Bug fixes
+
+## 0.1.0.1 -- 2018-10-18
+
+* Added documentation
+
+## 0.1.0.0 -- 2018-10-18
+
 * First version. Released on an unsuspecting world.

LICENSE view

@@ -1,13 +1,13 @@-Copyright (c) 2018 JASON CHAU--Permission to use, copy, modify, and/or distribute this software for any purpose-with or without fee is hereby granted, provided that the above copyright notice-and this permission notice appear in all copies.--THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH-REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,-INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS-OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER-TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF-THIS SOFTWARE.+Copyright (c) 2018 JASON CHAU
+
+Permission to use, copy, modify, and/or distribute this software for any purpose
+with or without fee is hereby granted, provided that the above copyright notice
+and this permission notice appear in all copies.
+
+THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
+OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
+TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
+THIS SOFTWARE.

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

graphql-w-persistent.cabal view

@@ -1,90 +1,90 @@--- Initial graphql-w-persistent.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/---- The name of the package.-name:                graphql-w-persistent---- The package version.  See the Haskell package versioning policy (PVP)--- for standards guiding when and how versions should be incremented.--- https://wiki.haskell.org/Package_versioning_policy--- PVP summary:      +-+------- breaking API changes---                   | | +----- non-breaking API additions---                   | | | +--- code changes with no API change-version:             0.5.0.0---- A short (one-line) description of the package.-synopsis:            GraphQL interface middleware for (SQL) databases.---- A longer description of the package.-description:         This is a Haskell GraphQL query parser and interpreter for databases. There is data processing to return GraphQL object formats. The query parser and interpreter are always applicable (on available database query types which is only SQL for now). It is accepting any string query, and it is returning a list of string database-queries. The data processing function is designed about the return values from the Persistent library (casted as Text data values from PersistValue). With another database package with same data structure on the returned values from the database, this whole package is applicable. Examples are odbc package query function and HDBC package quickQuery. To read more detailed information, you should go to the below module page.---- URL for the project homepage or repository.-homepage:            https://github.com/jasonsychau/graphql-w-persistent---- The license under which the package is released.-license:             ISC---- The file containing the license text.-license-file:        LICENSE---- The package author(s).-author:              JASON CHAU---- An email address to which users can send suggestions, bug reports, and--- patches.-maintainer:          jasonsychau@live.ca---- A copyright notice.--- copyright:--category:            Development, Database, Graphs, Language, Data--build-type:          Simple---- Extra files to be distributed with the package, such as examples or a--- README.-extra-source-files:  ChangeLog.md---- Constraint on the version of Cabal needed to build this package.-cabal-version:       >=1.10--tested-with:         GHC==8.4.3-stability:           provisional-bug-reports:         https://github.com/jasonsychau/graphql-w-persistent/issues---- source-repository head---   type:                git---   location:            git://github.com/jasonsychau/graphql-w-persistent.git--library-  -- Modules exported by the library.-  exposed-modules:     GraphQLdbi--  -- Modules included in this library but not exported.-  other-modules:       Components.DataProcessors.ListDataProcessor,-                       Components.ObjectHandlers.ObjectsHandler,-                       Components.ObjectHandlers.ServerObjectValidator,-                       Components.ObjectHandlers.ServerObjectTrimmer,-                       Components.Parsers.VariablesParser,-                       Components.Parsers.ServerSchemaJsonParser,-                       Components.Parsers.QueryParser,-                       Components.QueryComposers.SQLQueryComposer,-                       Model.ServerObjectTypes,-                       Model.ServerExceptions--  -- LANGUAGE extensions used by modules in this package.-  --other-extensions:--  -- Other library packages from which modules are imported.-  build-depends:       base >=4.11 && <4.13,-                       containers >=0.5 && <0.7,-                       json >=0.9 && <0.10,-                       text >=1.2 && <1.3---  -- Directories containing source files.-  hs-source-dirs:      src--  -- Base language which the package is written in.-  default-language:    Haskell2010-+-- Initial graphql-w-persistent.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+-- The name of the package.
+name:                graphql-w-persistent
+
+-- The package version.  See the Haskell package versioning policy (PVP)
+-- for standards guiding when and how versions should be incremented.
+-- https://wiki.haskell.org/Package_versioning_policy
+-- PVP summary:      +-+------- breaking API changes
+--                   | | +----- non-breaking API additions
+--                   | | | +--- code changes with no API change
+version:             0.6.0.0
+
+-- A short (one-line) description of the package.
+synopsis:            GraphQL interface middleware for (SQL) databases.
+
+-- A longer description of the package.
+description:         This is a Haskell GraphQL query parser and interpreter for databases. There is data processing to return GraphQL object formats. The query parser and interpreter are always applicable (on available database query types which is only SQL for now). It is accepting any string query, and it is returning a list of string database-queries. The data processing function is designed about the return values from the Persistent library (casted as Text data values from PersistValue). With another database package with same data structure on the returned values from the database, this whole package is applicable. Examples are odbc package query function and HDBC package quickQuery. To read more detailed information, you should go to the below module page.
+
+-- URL for the project homepage or repository.
+homepage:            https://github.com/jasonsychau/graphql-w-persistent
+
+-- The license under which the package is released.
+license:             ISC
+
+-- The file containing the license text.
+license-file:        LICENSE
+
+-- The package author(s).
+author:              JASON CHAU
+
+-- An email address to which users can send suggestions, bug reports, and
+-- patches.
+maintainer:          jasonsychau@live.ca
+
+-- A copyright notice.
+-- copyright:
+
+category:            Development, Database, Graphs, Language, Data
+
+build-type:          Simple
+
+-- Extra files to be distributed with the package, such as examples or a
+-- README.
+extra-source-files:  ChangeLog.md
+
+-- Constraint on the version of Cabal needed to build this package.
+cabal-version:       >=1.10
+
+tested-with:         GHC==8.6.5
+stability:           provisional
+bug-reports:         https://github.com/jasonsychau/graphql-w-persistent/issues
+
+-- source-repository head
+--   type:                git
+--   location:            git://github.com/jasonsychau/graphql-w-persistent.git
+
+library
+  -- Modules exported by the library.
+  exposed-modules:     GraphQLdbi
+
+  -- Modules included in this library but not exported.
+  other-modules:       Components.DataProcessors.ListDataProcessor,
+                       Components.ObjectHandlers.ObjectsHandler,
+                       Components.ObjectHandlers.ServerObjectValidator,
+                       Components.ObjectHandlers.ServerObjectTrimmer,
+                       Components.Parsers.VariablesParser,
+                       Components.Parsers.ServerSchemaJsonParser,
+                       Components.Parsers.QueryParser,
+                       Components.QueryComposers.SQLQueryComposer,
+                       Model.ServerObjectTypes,
+                       Model.ServerExceptions
+
+  -- LANGUAGE extensions used by modules in this package.
+  --other-extensions:
+
+  -- Other library packages from which modules are imported.
+  build-depends:       base >=4.11 && <4.13,
+                       containers >=0.5 && <0.7,
+                       json >=0.9 && <0.10,
+                       text >=1.2 && <1.3
+
+
+  -- Directories containing source files.
+  hs-source-dirs:      src
+
+  -- Base language which the package is written in.
+  default-language:    Haskell2010
+

src/Components/DataProcessors/ListDataProcessor.hs view

@@ -1,158 +1,174 @@-module Components.DataProcessors.ListDataProcessor (processReturnedValues) where---import Model.ServerExceptions (-        QueryException(-            InvalidObjectException,-            InvalidScalarException,-            InvalidArgumentException,-            EOFDataProcessingException,-            InvalidVariableTypeException,-            InvalidObjectScalarFieldException-        )-    )-import Model.ServerObjectTypes (NestedObject(..),Field,RootObject)-import Components.ObjectHandlers.ObjectsHandler (-        getSubFields,-        getServerObject,-        getInlinefragmentFields,-        getInlinefragmentObject,-        translateServerObjectToDBName,-        isServerObjectTable,-        getNestedObjectFieldLabel,-        getScalarName,-        getScalarFieldLabel,-        getServerObjectScalars,-        translateTableToObject-    )-import Data.Maybe (Maybe(Nothing),fromJust)-import Data.Either (fromRight,fromLeft,isLeft)-import Data.Text (Text,unpack,pack)-import Text.JSON (showJSON,showJSONs,JSValue,JSObject,toJSObject,encodeStrict)-import Control.Exception (throw)----- with root objects we want one json representation of separate graphql results...-processReturnedValues :: [(String,[(String,String)])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> String-processReturnedValues sss sodn soa robjs tbls rlts = encodeStrict $ processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts-processReturnedValuesToJsonObject :: [(String,[(String,String)])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> JSObject (JSObject JSValue)-processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts = toJSObject [("data", toJSObject [processReturnedValue sss sodn soa x y z | (x,y,z) <- zip3 robjs tbls rlts])]--- with qraphql query object and sql return data, we want json representation on graphql query results...-processReturnedValue :: [(String,[(String,String)])] -> [(String,String)] -> [(String,[String],[String])] -> RootObject -> [[String]] -> [[[Text]]] -> (String, JSValue)-processReturnedValue sss sodn soa (NestedObject alias name sobj _ sfs) tbls rlts = (if (alias==Nothing) then name else (fromJust 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]] -> [Field] -> [[[Text]]] -> [JSValue]-processSubFields _ _ _ _ _ _ [] = []-processSubFields _ _ _ _ _ [] _ = []--- are the query results from unique objects to make separate objects--- assume that if last table is same, fetchNextRow is same object instance-processSubFields sss sodn soa sobj tbls sfs rlts-    | (null $ foldr (++) [] rlts)==True = []-    | sameTables&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts])-    | sameTables = processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts]-    | otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts])-  where-    sameTables = (foldr (\x y->(last x)==(last $ head tbls)&&y) True tbls)-    object = makeOneGQLObject sss sodn soa sobj tbls sfs [fetchGraphQlRow x | x<-rlts]-    -- 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)) [] $ zip tbls [fetchGraphQlRow x | x<-rlts]-    objects = foldr (\x y -> (makeOneGQLObject sss sodn soa sobj [i | (i,_)<-x] sfs [j | (_,j)<-x]):y) [] groupedData--- 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]] -> [Field] -> [[[Text]]] -> [(String,JSValue)]-makeOneGQLObject _ _ _ _ _ [] (([]:_):_) = []  -- done-makeOneGQLObject _ _ _ _ _ _ ([]:_) = []  -- no data-makeOneGQLObject _ _ _ _ _ _ [] = []  -- no queries (unusual)-makeOneGQLObject _ _ _ _ _ [] _ = throw EOFDataProcessingException  -- columns and no fields-makeOneGQLObject _ _ _ _ [] _ _ = throw EOFDataProcessingException  -- no reference tables (unusual)-makeOneGQLObject _ sodn soa sobj tbls (f:[]) (([]:_):_)  -- field and no result columns-    | (isLeft f)==True&&scalarName=="__typename" = (getScalarFieldLabel scalarField, showJSON $ pack $ translateTableToObject (last $ head $ tbls) sodn):[]-    | (isLeft f)==True||(isLeft fo)==True||(isServerObjectTable (last $ head tbls) (getInlinefragmentObject ifo) sodn soa)==False = []-    | otherwise = throw EOFDataProcessingException-  where-    scalarField = fromLeft (throw InvalidScalarException) f-    scalarName = getScalarName scalarField-    fo = fromRight (throw InvalidObjectException) f-    ifo = fromRight (throw InvalidObjectException) fo-makeOneGQLObject _ _ _ _ _ _ (([]:_):_) = throw EOFDataProcessingException  -- fields and no result columns-makeOneGQLObject sss sodn soa sobj tbls (a:b) (((i:j):k):l)  -- (((:fld):ist):qry)-    | (isLeft a)==True&&(scalarName=="__typename") = ((getScalarFieldLabel scalarField, showJSON $ pack $ translateTableToObject (last $ head $ tbls) sodn):(makeOneGQLObject sss sodn soa sobj tbls b (((i:j):k):l)))-    | (isLeft a)==True = ((getScalarFieldLabel scalarField, castJSType (getServerObjectScalars sobj sss soa) scalarName i):(makeOneGQLObject sss sodn soa sobj tbls b [removeNDataColumns 1 x | x<-(((i:j):k):l)]))-    | (isLeft fo)==True = (((getNestedObjectFieldLabel no), showJSONs (processSubFields sss sodn soa (getServerObject no) nxtTbls (getSubFields no) [pullNDataColumns x y | (x,y)<-zip nestedObjectFieldCounts (((i:j):k):l)])):(makeOneGQLObject sss sodn soa sobj [updateTables (countNOTables sodn soa no x) x | x<-tbls] b [removeNDataColumns x y | (x,y)<-zip nestedObjectFieldCounts (((i:j):k):l)]))-    | (isServerObjectTable (last $ head tbls) (getInlinefragmentObject ifo) sodn soa)==True = makeOneGQLObject sss sodn soa sobj tbls ((getInlinefragmentFields ifo)++b) (((i:j):k):l)-    | otherwise = makeOneGQLObject sss sodn soa sobj tbls b (((i:j):k):l)-  where-    nxtTbls = map init tbls-    nestedObjectFieldCounts = map (\x -> countNOQueriedFields sodn soa no x) nxtTbls-    scalarField = (fromLeft (throw InvalidScalarException) a)-    scalarName = getScalarName scalarField-    fo = fromRight (throw InvalidObjectException) a-    no = fromLeft (throw InvalidObjectException) fo-    ifo = fromRight (throw InvalidObjectException) fo -fetchGraphQlRow :: [[Text]] -> [[Text]]-fetchGraphQlRow rlts = if (head $ head rlts)==(pack "Unexpected null") then [] else [t | (h:t)<-rlts, (h==(head $ head rlts))&&((head t)==(head $ tail $ head rlts))]-removeDataRow :: [[Text]] -> [[Text]]-removeDataRow rlts = [x | x<-rlts, (head x)/=(head $ head rlts)||((head $ tail x)/=(head $ tail $ head rlts))]-pullNDataColumns :: Int -> [[Text]] -> [[Text]]-pullNDataColumns _ [] = []-pullNDataColumns cnt rslt-    | (cnt<0) = throw InvalidArgumentException-    | otherwise = map (\x -> if (length x)<cnt then (throw EOFDataProcessingException) else (take cnt x)) rslt--- count how many columns are added to sql data result for this nested object including the nested object id-countNOQueriedFields :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int-countNOQueriedFields sodn soa (NestedObject alias name sobj ss sfs) tbls = 1+(countNOQueriedSubFields sodn soa sfs tbls)-countNOQueriedSubFields :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int-countNOQueriedSubFields _ _ [] _ = 0-countNOQueriedSubFields sodn soa (h:t) tbls-    | (isLeft h)==True&&scalarName=="__typename" = countNOQueriedSubFields sodn soa t tbls-    | (isLeft h)==True = 1+(countNOQueriedSubFields sodn soa t tbls)-    | (isLeft fo)==True = (countNOQueriedFields sodn soa no $ init tbls)+(countNOQueriedSubFields sodn soa t tbls)-    | (isServerObjectTable (last tbls) (getInlinefragmentObject ifo) sodn soa)==True = countNOQueriedSubFields sodn soa ((getInlinefragmentFields ifo)++t) tbls-    | otherwise = countNOQueriedSubFields sodn soa t tbls-  where-    scalarName = getScalarName $ fromLeft (throw InvalidScalarException) h-    fo = fromRight (throw InvalidObjectException) h-    no = fromLeft (throw InvalidObjectException) fo-    ifo = fromRight (throw InvalidObjectException) fo--- 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 _ [[]] = [[]]-removeNDataColumns _ ([]:t) = throw EOFDataProcessingException-removeNDataColumns cnt rslt = removeNDataColumns (cnt-1) [t | (h:t)<-rslt]-castJSType :: [(String,String)] -> String -> Text -> JSValue-castJSType [] fld val = throw InvalidObjectScalarFieldException-castJSType ((nam,typ):t) fld val-    | (nam==fld)&&(typ=="Text") = showJSON val-    | (nam==fld)&&(typ=="ByteString") = showJSON val-    | (nam==fld)&&(typ=="Int") = showJSON (Prelude.read $ unpack val :: Int)-    | (nam==fld)&&(typ=="Double") = showJSON (Prelude.read $ unpack val :: Double)-    | (nam==fld)&&(typ=="Rational") = showJSON (Prelude.read $ unpack val :: Double)-    | (nam==fld)&&(typ=="Bool") = showJSON (Prelude.read $ unpack val :: Int)-    | (nam==fld)&&(typ=="Day") = showJSON val-    | (nam==fld)&&(typ=="TimeOfDay") = showJSON val-    | (nam==fld)&&(typ=="UTCTime") = showJSON val-    | (nam==fld) = throw InvalidVariableTypeException-    | otherwise = castJSType t fld val-countNOTables :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int-countNOTables sodn soa (NestedObject alias name sobj ss sfs) tbls = 1+(countSubfieldsTables sodn soa sfs tbls)-countSubfieldsTables :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int-countSubfieldsTables _ _ [] _ = 0-countSubfieldsTables sodn soa (h:t) tbls-    | (isLeft h)==True = countSubfieldsTables sodn soa t tbls-    | (isLeft fo)==True = foCount+(countSubfieldsTables sodn soa t (updateTables foCount tbls))-    | (isServerObjectTable (last tbls) (getInlinefragmentObject ifo) sodn soa)==True = countSubfieldsTables sodn soa ((getInlinefragmentFields ifo)++t) tbls-    | otherwise = countSubfieldsTables sodn soa t tbls-  where-    fo = fromRight (throw InvalidObjectException) h-    no = fromLeft (throw InvalidObjectException) fo-    foCount = countNOTables sodn soa no (init tbls)-    ifo = fromRight (throw InvalidObjectException) fo-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] )+module Components.DataProcessors.ListDataProcessor (processReturnedValues) where
+
+import Data.Text (Text,unpack,pack)
+import Text.JSON (showJSON,showJSONs,JSValue,JSObject,toJSObject,encodeStrict)
+import Control.Exception (throw)
+import Data.List (foldl')
+import Model.ServerExceptions (
+        QueryException(
+            InvalidObjectException,
+            InvalidScalarException,
+            InvalidArgumentException,
+            EOFDataProcessingException,
+            InvalidVariableTypeException
+        )
+    )
+import Model.ServerObjectTypes (
+    NestedObject(..),
+    Field,
+    RootObject,
+    ServerObject,
+    ScalarType(..),
+    Transformation,
+    Argument,
+    InlinefragmentObject(..)
+  )
+import Components.ObjectHandlers.ObjectsHandler (
+      isServerObjectTable,
+      getNestedObjectFieldLabel,
+      getScalarFieldLabel,
+      translateTableToObject
+  )
+
+
+-- with root objects we want one json representation of separate graphql results...
+processReturnedValues :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> String
+processReturnedValues sss sodn soa robjs tbls rlts = encodeStrict $ processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts
+processReturnedValuesToJsonObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> [RootObject] -> [[[String]]] -> [[[[Text]]]] -> JSObject (JSObject JSValue)
+processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts = toJSObject [("data", toJSObject [processReturnedValue sss sodn soa x y z | (x,y,z) <- zip3 robjs tbls rlts])]
+-- with qraphql query object and sql return data, we want json representation on graphql query results...
+processReturnedValue :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> RootObject -> [[String]] -> [[[Text]]] -> (String, JSValue)
+processReturnedValue sss sodn soa (NestedObject Nothing name sobj _ sfs) tbls rlts = (name, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts)
+processReturnedValue sss sodn soa (NestedObject (Just alias) name sobj _ sfs) tbls rlts = (alias, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts)
+-- with SubFields and data rows, we want json representation on qraphql query data
+processSubFields :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [JSValue]
+processSubFields _ _ _ _ _ _ [] = []
+processSubFields _ _ _ _ _ [] _ = []
+-- are the query results from unique objects to make separate objects
+-- assume that if last table is same, fetchNextRow is same object instance
+processSubFields sss sodn soa sobj tbls sfs rlts
+    | (null $ foldr (++) [] rlts)==True = []
+    | sameTables&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts])
+    | sameTables = processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts]
+    | otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls sfs [removeDataRow x | x<-rlts])
+  where
+    sameTables = foldl' (\y x->(last x)==(last $ head tbls)&&y) True tbls
+    object = makeOneGQLObject sss sodn soa sobj tbls sfs [fetchGraphQlRow x | x<-rlts]
+    -- different tables is possibly different result rows. I should not assume that they are same.
+    notEmptyQueryResults = [(x,y) | (x,y)<-zip tbls rlts, null y==False]
+    -- assume tbls are segmented from last table
+    -- groupedData :: [[([String],[[Text]])]]
+    groupedData = foldr (\(x,y) z -> if (null z)==True then [[(x,y)]] else if (last x)==(last $ fst $ head $ head z) then (((x,y):(head z)):(tail z)) else ([(x,y)]:z)) [] $ [(x,fetchGraphQlRow y) | (x,y)<-notEmptyQueryResults]
+    labeledData = [unzip x | x<-groupedData]
+    objects = foldr (\(x,y) z -> (makeOneGQLObject sss sodn soa sobj x sfs y):z) [] labeledData
+-- assume all last elements are same in tbls
+-- assume all instances (ist) are same
+makeOneGQLObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,[String],[String])] -> String -> [[String]] -> [Field] -> [[[Text]]] -> [(String,JSValue)]
+makeOneGQLObject _ _ _ _ _ [] (([]:_):_) = []  -- done
+makeOneGQLObject _ _ _ _ _ _ ([]:_) = []  -- no column data
+makeOneGQLObject _ _ _ _ _ _ [] = []  -- no queries (unusual)
+makeOneGQLObject _ _ _ _ _ [] _ = throw EOFDataProcessingException  -- columns and no fields
+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)])
+  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)
+
+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
+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
+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
+findArgumentOptionType trans Nothing ((aname,((_,typ,_,_):_)):rst)
+ | trans==aname = typ
+ | otherwise = findArgumentOptionType trans Nothing rst
+findArgumentOptionType trans (Just arg) ((aname,opts):rst)
+ | trans==aname = findOptionType arg opts
+ | otherwise = findArgumentOptionType trans (Just arg) rst
+findOptionType :: String -> [(String,String,String,String)] -> String
+findOptionType _ [] = throw InvalidArgumentException
+findOptionType arg ((oname,typ,_,_):rst)
+ | arg==oname = typ
+ | otherwise = findOptionType arg rst
+
+fetchGraphQlRow :: [[Text]] -> [[Text]]
+fetchGraphQlRow rlts = if (head $ head rlts)==(pack "Unexpected null") then [] else [t | (h:t)<-rlts, h==(head $ head rlts)]
+removeDataRow :: [[Text]] -> [[Text]]
+removeDataRow rlts = [x | x<-rlts, (head x)/=(head $ head rlts)]
+pullNDataColumns :: Int -> [[Text]] -> [[Text]]
+pullNDataColumns _ [] = []
+pullNDataColumns cnt rslt
+ | (cnt<0) = throw InvalidArgumentException
+ | otherwise = [if (length x)<cnt then throw EOFDataProcessingException else take cnt x | x<-rslt]
+-- count how many columns are added to sql data result for this nested object including the nested object id
+countQueriedSubFields :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int
+countQueriedSubFields sodn soa (NestedObject alias name sobj ss sfs) tbls = countQueriedSubFieldsHelper sodn soa sfs tbls 1
+countQueriedSubFieldsHelper :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int
+countQueriedSubFieldsHelper _ _ [] _ acc = acc
+countQueriedSubFieldsHelper sodn soa ((Left (ScalarType _ "__typename" _ _)):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls acc
+countQueriedSubFieldsHelper sodn soa ((Left (ScalarType _ _ _ _)):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls (acc+1)
+countQueriedSubFieldsHelper sodn soa ((Right (Left (NestedObject _ _ _ _ sfs))):t) tbls acc = countQueriedSubFieldsHelper sodn soa t tbls (acc+(countQueriedSubFieldsHelper sodn soa sfs (init tbls) 1))
+countQueriedSubFieldsHelper sodn soa ((Right (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
+
+-- 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
+castJSType "Int" val = showJSON (Prelude.read $ unpack val :: Int)
+castJSType "Double" val = showJSON (Prelude.read $ unpack val :: Double)
+castJSType "Rational" val = showJSON (Prelude.read $ unpack val :: Double)
+castJSType "Bool" val = showJSON (Prelude.read $ unpack val :: Int)
+castJSType "Day" val = showJSON val
+castJSType "TimeOfDay" val = showJSON val
+castJSType "UTCTime" val = showJSON val
+castJSType _ val = throw InvalidVariableTypeException
+countNOTables :: [(String,String)] -> [(String,[String],[String])] -> NestedObject -> [String] -> Int
+countNOTables sodn soa (NestedObject alias name sobj ss sfs) tbls = countSubfieldsTables sodn soa sfs tbls 1
+countSubfieldsTables :: [(String,String)] -> [(String,[String],[String])] -> [Field] -> [String] -> Int -> Int
+countSubfieldsTables _ _ [] _ 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])

src/Components/ObjectHandlers/ObjectsHandler.hs view

@@ -1,144 +1,132 @@-module Components.ObjectHandlers.ObjectsHandler where---import Model.ServerExceptions (-        QueryException(-            InvalidObjectException,-            RelationshipConfigurationException,-            NullArgumentException-        )-    )-import Model.ServerObjectTypes (-        NestedObject(..),-        ServerObject,-        ScalarType(..),-        Alias,-        SubSelection,-        SubFields,-        Field,-        InlinefragmentObject(..),-        Argument,-        Transformation-    )-import Data.Maybe (fromJust,Maybe(Nothing))-import Control.Exception (throw)--{--parsing frontend query to server query-- A valid argument is any string that is provided to reference database objects--}-readServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject-readServerObject str [] [] = throw InvalidObjectException-readServerObject str ((a,b):t) c = if (elem str b)==True then (a :: ServerObject) else readServerObject str t c-readServerObject str [] ((a,b,_):t) = if (elem str b)==True then (a :: ServerObject) else readServerObject str [] t--{--checking server type attributes--}--- EFFECT: 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])] -> Bool-isValidServerObjectScalarField _ _ [] _ = False  -- throw InvalidObjectException-isValidServerObjectScalarField sobj name pvs ((pnt,_,cdn):t) = if sobj==pnt then (foldr (\x y->(isValidServerObjectScalarField x name pvs [])&&y) True cdn)||(isValidServerObjectScalarField sobj name pvs t) else isValidServerObjectScalarField sobj name pvs t-isValidServerObjectScalarField sobj name ((ptv,fds):t) _-    | sobj==ptv&&(elem name $ getScalarNames fds)==True = True-    | otherwise = isValidServerObjectScalarField sobj name t [] -getScalarNames :: [(String,String)] -> [String]-getScalarNames lst = [a | (a,b) <- lst]---- 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 (elem name $ getParentObjects cdn pvo)||(isValidServerObjectNestedObjectField sobj name pvo t) else isValidServerObjectNestedObjectField sobj name pvo t-isValidServerObjectNestedObjectField _ _ [] _ = False -- throw InvalidObjectException-isValidServerObjectNestedObjectField sobj name ((a,b):t) _ -    | sobj==a&&(elem name b)==True = True-    | otherwise = isValidServerObjectNestedObjectField sobj name t []---- split server object to sql query--- EFFECTS: returns the database table references for the server object.-translateServerObjectToDBName :: ServerObject -> [(String,String)] -> [(String,[String],[String])] -> [String]-translateServerObjectToDBName sobj pdn ((so,_,cdn):t) = if sobj==so then (foldr (\x y -> (translateServerObjectToDBName x pdn [])++y) [] cdn)++(translateServerObjectToDBName sobj pdn t) else translateServerObjectToDBName sobj pdn t-translateServerObjectToDBName _ [] _ = []  -- throw InvalidObjectException-translateServerObjectToDBName sobj ((a,b):t) _-    | sobj==a = [b]-    | otherwise = translateServerObjectToDBName sobj t []--- TODO: list all server objects and their associated entities--- EFFECT: with serverobject and serverobject attribute, we want the identity table, identity field, reference table, reference field, and triple elements if present of identity-to-reference-tables-order intermediate table, to-intermediate field, and from-itermediate field--- You can define direct relationships (around only one link) or indirect (but you'll code the database query by yourself...)-getDBObjectRelationships :: String -> String -> [(String,String,[String])] -> [String]-getDBObjectRelationships _ _ [] = throw RelationshipConfigurationException-getDBObjectRelationships from to ((a,b,c):t)-    | from==a&&to==b = c+module Components.ObjectHandlers.ObjectsHandler where
+
+
+import Control.Exception (throw)
+import Data.List (foldl')
+import Model.ServerExceptions (
+        QueryException(
+            InvalidObjectException,
+            RelationshipConfigurationException,
+            NullArgumentException,
+            InvalidArgumentException,
+            InvalidScalarException
+        )
+    )
+import Model.ServerObjectTypes (
+        NestedObject(..),
+        ServerObject,
+        ScalarType(..),
+        Alias,
+        SubSelection,
+        SubFields,
+        Field,
+        InlinefragmentObject(..),
+        Argument,
+        Transformation
+    )
+
+
+-- SCALAR FIELDS
+-- getScalarArgument :: ScalarType -> String
+-- getScalarArgument (ScalarType _ _ _ Nothing) = throw NullArgumentException
+-- getScalarArgument (ScalarType _ _ _ (Just arg)) = arg
+getScalarFieldLabel :: ScalarType -> String
+getScalarFieldLabel (ScalarType Nothing name _ _) = name
+getScalarFieldLabel (ScalarType (Just alias) _ _ _) = alias
+
+-- NESTED OBJECTS
+getServerObject :: NestedObject -> ServerObject
+getServerObject (NestedObject _ _ sobj _ _) = sobj
+withSubSelection :: NestedObject -> Bool
+withSubSelection (NestedObject _ _ _ ss _) = (ss/=Nothing)
+getSubSelectionField :: NestedObject -> String
+getSubSelectionField (NestedObject _ _ _ (Just (ScalarType _ name _ _)) _) = name
+getSubSelectionField _ = throw NullArgumentException
+getSubSelectionArgument :: NestedObject -> String
+getSubSelectionArgument (NestedObject _ _ _ (Just (ScalarType _ _ _ (Just arg))) _) = arg
+getSubSelectionArgument _ = throw NullArgumentException
+getSubFields :: NestedObject -> SubFields
+getSubFields (NestedObject _ _ _ _ sf) = sf
+isSameNObjectReference :: NestedObject -> NestedObject -> Bool
+isSameNObjectReference (NestedObject alias1 name1 sobj1 _ _) (NestedObject alias2 name2 sobj2 _ _) = alias1==alias2&&name1==name2&&sobj1==sobj2
+isSameObjectSubSelection :: NestedObject -> NestedObject -> Bool
+isSameObjectSubSelection (NestedObject _ _ _ ss1 _) (NestedObject _ _ _ ss2 _) = ss1==ss2
+getNestedObjectFieldLabel :: NestedObject -> String
+getNestedObjectFieldLabel (NestedObject Nothing name _ _ _) = name
+getNestedObjectFieldLabel (NestedObject (Just alias) _ _ _ _) = alias
+
+-- BASIC
+getIntersection :: Eq a => [[a]] -> [a]
+getIntersection [] = []
+getIntersection ([]:t) = []
+getIntersection ((h:t1):t2) = if foldl' (\y x -> (elem h x)&&y) True t2 then h:getIntersection (t1:t2) else getIntersection (t1:t2)
+
+-- REFERENCE SCHEMA
+{-
+parsing frontend query to server query
+- 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) c = if (elem str b)==True then (a :: ServerObject) else readServerObject str t c
+readServerObject str [] ((a,b,_):t) = if (elem str b)==True then (a :: ServerObject) else readServerObject str [] t
+-- 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
+-- SCHEMA HEIRARCHY
+isServerObjectTable :: String -> ServerObject -> [(String,String)] -> [(String,[String],[String])] -> Bool
+isServerObjectTable tbl soj sodn soa = elem tbl $ translateServerObjectToDBName soj sodn soa
+translateTableToObject :: String -> [(String,String)] -> String
+translateTableToObject _ [] = throw InvalidObjectException
+translateTableToObject tbl ((pObj,pTbl):rst) = if tbl==pTbl then pObj else translateTableToObject tbl rst
+{-
+checking server type attributes
+-}
+-- EFFECT: 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 foldl' (\y x->(isValidServerObjectScalarField x name pvs [])&&y) True cdn else isValidServerObjectScalarField sobj name pvs t
+isValidServerObjectScalarField sobj name ((ptv,fds):t) _
+ | sobj==ptv = foldl' (\y (n,_,_)->(name==n)||y) False fds
+ | otherwise = isValidServerObjectScalarField sobj name t []
+-- If no transformation is present, I allow different types for different children objects of the same scalar field.
+-- If there is a transformation, I require same type and transformation values since I cannot infer which child transformation before making queries while I can deduce types after queries with tables.
+isValidScalarTransformation :: ServerObject -> String -> Transformation -> Argument -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool
+isValidScalarTransformation _ _ Nothing _ _ _ = True
+isValidScalarTransformation _ _ _ _ [] _ = throw InvalidObjectException
+isValidScalarTransformation sobj name trans arg pvs ((pnt,_,cdn):t) = if sobj==pnt then foldl' (\y x->(isValidScalarTransformation x name trans arg pvs [])&&y) True cdn else isValidScalarTransformation sobj name trans arg pvs t
+isValidScalarTransformation sobj name (Just trans) arg ((ptv,fds):t) _
+ | sobj==ptv = findAndCheckScalarTransformation name trans arg fds
+ | otherwise = isValidScalarTransformation sobj name (Just trans) arg t []
+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
+findAndCheckTransformationOption :: String -> Argument -> [(String,[(String,String,String,String)])] -> Bool
+findAndCheckTransformationOption _ Nothing _ = True
+findAndCheckTransformationOption _ _ [] = throw InvalidArgumentException
+findAndCheckTransformationOption trans (Just arg) ((name,opts):t) = if trans==name then foldl' (\y (n,_,_,_)->(arg==n)||y) False opts else findAndCheckTransformationOption trans (Just arg) t
+-- you can create as many relationships as you want with your server...
+isValidServerObjectNestedObjectField :: ServerObject -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool
+isValidServerObjectNestedObjectField sobj name pvo ((so,_,cdn):t) = if sobj==so then foldl' (\y x->(isValidServerObjectNestedObjectField x name pvo [])&&y) True cdn else isValidServerObjectNestedObjectField sobj name pvo t
+isValidServerObjectNestedObjectField _ _ [] _ = throw InvalidObjectException
+isValidServerObjectNestedObjectField sobj name ((a,b):t) _ 
+ | sobj==a = elem name b
+ | otherwise = isValidServerObjectNestedObjectField sobj name t []
+-- split server object to sql query
+-- EFFECTS: returns the database table references for the server object.
+translateServerObjectToDBName :: ServerObject -> [(String,String)] -> [(String,[String],[String])] -> [String]
+translateServerObjectToDBName sobj pdn ((so,_,cdn):t) = if sobj==so then foldl' (\y x-> (translateServerObjectToDBName x pdn [])++y) [] cdn else translateServerObjectToDBName sobj pdn t
+translateServerObjectToDBName _ [] _ = throw InvalidObjectException
+translateServerObjectToDBName sobj ((a,b):t) _
+ | sobj==a = [b]
+ | otherwise = translateServerObjectToDBName sobj t []
+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---- SCALAR FIELDS-getScalarName :: ScalarType -> String-getScalarName (ScalarType alias name trans arg) = name-getScalarArgument :: ScalarType -> String-getScalarArgument (ScalarType alias name trans arg) = if arg==Nothing then (throw NullArgumentException) else (fromJust arg)-getTransformation :: ScalarType -> (Transformation,Argument)-getTransformation (ScalarType alias name trans arg) = (trans,arg)-getScalarFieldLabel :: ScalarType -> String-getScalarFieldLabel (ScalarType alias name trans arg) = if (alias/=Nothing) then (fromJust alias) else name---- NESTED OBJECTS-getObjectName :: NestedObject -> String-getObjectName (NestedObject alias name sobj ss sf) = name-getObjectAlias :: NestedObject -> Alias-getObjectAlias (NestedObject alias name sobj ss sf) = alias-getServerObject :: NestedObject -> ServerObject-getServerObject (NestedObject alias name sobj ss sf) = sobj-getObjectSubSelection :: NestedObject -> SubSelection-getObjectSubSelection (NestedObject alias name sobj ss sf) = ss-withSubSelection :: NestedObject -> Bool-withSubSelection (NestedObject alias name sobj ss sf) = (ss/=Nothing)-getSubSelectionField :: NestedObject -> String-getSubSelectionField (NestedObject alias name sobj ss sf) = getScalarName $ fromJust ss-getSubSelectionArgument :: NestedObject -> String-getSubSelectionArgument (NestedObject alias name sobj ss sf) = getScalarArgument $ fromJust ss-getSubFields :: NestedObject -> SubFields-getSubFields (NestedObject alias name sobj ss sf) = sf-isSameNObjectReference :: NestedObject -> NestedObject -> Bool-isSameNObjectReference (NestedObject alias1 name1 sobj1 ss1 sfs1) (NestedObject alias2 name2 sobj2 ss2 sfs2) = alias1==alias2&&name1==name2&&sobj1==sobj2-isSameObjectSubSelection :: NestedObject -> NestedObject -> Bool-isSameObjectSubSelection (NestedObject alias1 name1 sobj1 ss1 sfs1) (NestedObject alias2 name2 sobj2 ss2 sfs2) = ss1==ss2-getNestedObjectFieldLabel :: NestedObject -> String-getNestedObjectFieldLabel (NestedObject alias name sobj ss sfs) = if (alias/=Nothing) then (fromJust alias) else name---- INLINE-FRAGMENTS-isSameIFObjectReference :: InlinefragmentObject -> InlinefragmentObject -> Bool-isSameIFObjectReference (InlinefragmentObject obj1 sf1) (InlinefragmentObject obj2 sf2) = obj1==obj2-getInlinefragmentObject :: InlinefragmentObject -> ServerObject-getInlinefragmentObject (InlinefragmentObject obj sf) = obj-getInlinefragmentFields :: InlinefragmentObject -> [Field]-getInlinefragmentFields (InlinefragmentObject obj sf) = sf---- SERVER OBJECTS-isValidServerObjectChild :: ServerObject -> ServerObject -> [(String,[String],[String])] -> Bool-isValidServerObjectChild _ _ [] = False-isValidServerObjectChild pnt cld ((so,_,cdn):t) = if pnt==so then (elem cld cdn)||(isValidServerObjectChild pnt cld t) else isValidServerObjectChild pnt cld t-getServerObjectScalars :: ServerObject -> [(String,[(String,String)])] -> [(String,[String],[String])] -> [(String,String)]-getServerObjectScalars _ [] _ = throw InvalidObjectException-getServerObjectScalars sobj sss ((pnt,_,cdn):t) = if (sobj==pnt) then getIntersection [getServerObjectScalars x sss [] | x<-cdn] else getServerObjectScalars sobj sss t-getServerObjectScalars sobj ((cld,fds):t) _ = if (sobj==cld) then fds else getServerObjectScalars sobj t []---- BASIC-getIntersection :: Eq a => [[a]] -> [a]-getIntersection [] = []-getIntersection ([]:t) = []-getIntersection ((h:t1):t2) = if (foldr (\x y -> (elem h x)&&y) True t2) then (h:(getIntersection (t1:t2))) else (getIntersection (t1:t2))---- SCHEMA HEIRARCHY-getParentObjects :: [String] -> [(String,[String])] -> [String]-getParentObjects cdn sos = getIntersection $ getChildrenObjects cdn sos-getChildrenObjects :: [String] -> [(String,[String])] -> [[String]]-getChildrenObjects [] _ = []-getChildrenObjects (h:t) sos = (getChildObjects h sos):(getChildrenObjects t sos)-getChildObjects :: String -> [(String,[String])] -> [String]-getChildObjects _ [] = []-getChildObjects cld ((so,obs):t) = if cld==so then obs++(getChildObjects cld t) else getChildObjects cld t-isServerObjectTable :: String -> ServerObject -> [(String,String)] -> [(String,[String],[String])] -> Bool-isServerObjectTable tbl soj sodn soa = elem tbl $ translateServerObjectToDBName soj sodn soa-translateTableToObject :: String -> [(String,String)] -> String-translateTableToObject _ [] = throw InvalidObjectException-translateTableToObject tbl ((pObj,pTbl):rst) = if tbl==pTbl then pObj else translateTableToObject tbl rst

src/Components/ObjectHandlers/ServerObjectTrimmer.hs view

@@ -1,108 +1,86 @@-module Components.ObjectHandlers.ServerObjectTrimmer (mergeDuplicatedRootObjects) where--import Model.ServerObjectTypes (-    RootObject,-    RootObjects,-    NestedObject(..),-    ScalarType,-    Field,-    FieldObject,-    InlinefragmentObject(..)-  )-import Model.ServerExceptions (-    QueryException(-      InvalidObjectException,-      InvalidScalarException,-      DuplicateRootObjectsException,-      FailedObjectEqualityException-    )-  )-import Components.ObjectHandlers.ObjectsHandler (-    isSameNObjectReference,-    isSameIFObjectReference,-    isSameObjectSubSelection-  )-import Data.Either (-    fromLeft,-    fromRight,-    isLeft,-    isRight,-    Either(Left,Right)-  )-import Control.Exception (throw)---mergeDuplicatedRootObjects :: [RootObject] -> [RootObject]-mergeDuplicatedRootObjects [] = []--- 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-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)--- merge together valid (same referene and same subselection) RootObjects-mergeDuplicates :: RootObject -> [RootObject] -> RootObject-mergeDuplicates robj [] = (mergeSubFields robj)-mergeDuplicates (NestedObject alias name sobj ss sf1) ((NestedObject _ _ _ _ sf2):t) = mergeDuplicates (NestedObject alias name sobj ss (mergeFields sf1 sf2)) t--- merge SubFields in one RootObject-mergeSubFields :: RootObject -> RootObject-mergeSubFields (NestedObject alias name sobj ss sfs) = (NestedObject alias name sobj ss (compressSubSelections sfs))--- with a list of Fields, we want to merge duplicate Fields-compressSubSelections :: [Field] -> [Field]-compressSubSelections [] = []-compressSubSelections lst = compressSubSelectionsHelper lst []--- We want a removed-duplicate set with a list of Fields, and empty list.-compressSubSelectionsHelper :: [Field] -> [Field] -> [Field]-compressSubSelectionsHelper [] rst = rst-compressSubSelectionsHelper (h:t) rst-    | (isLeft h) = compressSubSelectionsHelper t (combineScalarTypeWithPresent rst st)-    | otherwise = compressSubSelectionsHelper t (combineFieldObjectWithPresent rst fo)-  where-    st = (fromLeft (throw InvalidScalarException) h)-    fo = (fromRight (throw InvalidObjectException) h)--- with two sets of fields, we want a union that is no duplicates-mergeFields :: [Field] -> [Field] -> [Field]-mergeFields lst [] = lst-mergeFields lst (h:t)-    | (isLeft h)==True = mergeFields (combineScalarTypeWithPresent lst (fromLeft (throw InvalidScalarException) h)) t-    | otherwise = mergeFields (combineFieldObjectWithPresent lst (fromRight (throw InvalidObjectException) h)) t--- with list of Field and one ScalarType, we want a union set of list and new ScalarType-combineScalarTypeWithPresent :: [Field] -> ScalarType -> [Field]-combineScalarTypeWithPresent [] st = (Left st):[]-combineScalarTypeWithPresent (h:t) st-    | (isLeft h)&&(fromLeft (throw InvalidScalarException) h)==st = h:t-    | otherwise = h:(combineScalarTypeWithPresent t st)--- with list of Field and one NestedObject, we want a union set of list and new NestedObject-combineFieldObjectWithPresent :: [Field] -> FieldObject -> [Field]-combineFieldObjectWithPresent [] fo = (Right fo):[]-combineFieldObjectWithPresent (h:t) fo-    | (isLeft h) = h:(combineFieldObjectWithPresent t fo)-    | (isLeft fobj)&&(isRight fo) = h:(combineFieldObjectWithPresent t fo)-    | (isLeft fo)&&(isRight fobj) = h:(combineFieldObjectWithPresent t fo)-    | (isLeft fobj)&&(isSameNObjectReference nobj lnobj)&&(isSameObjectSubSelection nobj lnobj) = (Right $ Left $ mergeNObjects nobj lnobj):t-    | (isLeft fobj)&&(isSameNObjectReference nobj lnobj) = throw DuplicateRootObjectsException-    | (isLeft fobj) = h:(combineFieldObjectWithPresent t fo)-    | (isSameIFObjectReference ifobj lifobj) = (Right $ Right $ mergeIFObjects ifobj lifobj):t-    | otherwise = h:(combineFieldObjectWithPresent t fo)-  where-    fobj = fromRight (throw InvalidObjectException) h-    lnobj = fromLeft (throw InvalidObjectException) fobj-    lifobj = fromRight (throw InvalidObjectException) fobj-    nobj = fromLeft (throw InvalidObjectException) fo-    ifobj = fromRight (throw InvalidObjectException) fo--- 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.-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 (mergeFields 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)-mergeIFObjects :: InlinefragmentObject -> InlinefragmentObject -> InlinefragmentObject-mergeIFObjects (InlinefragmentObject sobj1 sfs1) (InlinefragmentObject sobj2 sfs2) = if (sobj1==sobj2) then (InlinefragmentObject sobj1 (mergeFields sfs1 sfs2)) else (throw FailedObjectEqualityException)+module Components.ObjectHandlers.ServerObjectTrimmer (mergeDuplicatedRootObjects) where
+
+import Control.Exception (throw)
+import Model.ServerObjectTypes (
+    RootObject,
+    NestedObject(..),
+    ScalarType,
+    Field,
+    InlinefragmentObject(..)
+  )
+import Model.ServerExceptions (
+    QueryException(
+      DuplicateRootObjectsException,
+      FailedObjectEqualityException
+    )
+  )
+import Components.ObjectHandlers.ObjectsHandler (
+    isSameNObjectReference,
+    isSameIFObjectReference,
+    isSameObjectSubSelection
+  )
+
+
+mergeDuplicatedRootObjects :: [RootObject] -> [RootObject]
+mergeDuplicatedRootObjects [] = []
+-- 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
+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)
+-- 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
+compressSubFields :: [Field] -> [Field]
+compressSubFields [] = []
+compressSubFields lst = compressSubFieldsHelper lst []
+-- We 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
+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
+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)
+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.
+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)
+mergeIFObjects :: InlinefragmentObject -> InlinefragmentObject -> InlinefragmentObject
+mergeIFObjects (InlinefragmentObject sobj1 sfs1) (InlinefragmentObject sobj2 sfs2) = if sobj1==sobj2 then InlinefragmentObject sobj1 (compressSubFields (sfs1++sfs2)) else throw FailedObjectEqualityException

src/Components/ObjectHandlers/ServerObjectValidator.hs view

@@ -1,79 +1,106 @@-module Components.ObjectHandlers.ServerObjectValidator (checkObjectsAttributes,replaceObjectsVariables) where---import Model.ServerObjectTypes (-        ServerObject,-        RootObject,-        ScalarType(..),-        SubSelection,-        Field,-        FieldObject,-        InlinefragmentObject(..),-        NestedObject(..)-    )-import Model.ServerExceptions (-        QueryException(-            InvalidObjectException,-            InvalidVariableNameException,-            InvalidObjectScalarFieldException,-            MismatchedVariableTypeException-        )-    )-import Components.ObjectHandlers.ObjectsHandler (-        getObjectName,-        getInlinefragmentFields,-        getInlinefragmentObject,-        isValidServerObjectChild,-        isValidServerObjectNestedObjectField,-        getScalarName,-        isValidServerObjectScalarField-    )-import Control.Exception (throw)-import Data.Maybe (fromJust,Maybe(Just,Nothing))-import Data.Either (Either(Right,Left))---- check that all nested objects are with valid properties-checkObjectsAttributes :: [RootObject] -> [(String,[(String,String)])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool-checkObjectsAttributes objs sss sos soa = foldr (\x y -> (hasValidAttributes x sss sos soa)&&y) True objs-hasValidAttributes :: NestedObject -> [(String,[(String,String)])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool-hasValidAttributes (NestedObject alias name sobject ss sfs) sss sos soa = (if ss==Nothing then True else isValidSubSelection sobject (fromJust ss) sss soa)&&(isValidSubFields sobject sfs sss sos soa)-isValidSubSelection :: ServerObject -> ScalarType -> [(String,[(String,String)])] -> [(String,[String],[String])] -> Bool-isValidSubSelection obj (ScalarType alias name trans arg) sss soa = (isValidServerObjectScalarField obj name sss soa)  -- &&(isValidScalarTransformation obj name trans arg)-isValidSubFields :: ServerObject -> [Field] -> [(String,[(String,String)])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool-isValidSubFields _ [] _ _ _ = True  -- we should not get an empty query-isValidSubFields obj sfs sss sos soa = foldr (\x y -> (isValidSubField obj x sss sos soa)&&y) True sfs-isValidSubField :: ServerObject -> Field -> [(String,[(String,String)])]-> [(String,[String])] -> [(String,[String],[String])] -> Bool-isValidSubField obj (Left sf) sss sos soa = ((getScalarName sf)=="__typename")||(isValidServerObjectScalarField obj (getScalarName sf) sss soa)  -- &&(isValidScalarTransformation obj sname trans arg)-isValidSubField obj (Right (Left no)) sss sos soa = (isValidServerObjectNestedObjectField obj (getObjectName no) sos soa)&&(hasValidAttributes no sss sos soa)-isValidSubField obj (Right (Right ifo)) sss sos soa = (isValidServerObjectChild obj soj soa)&&(isValidSubFields soj (getInlinefragmentFields ifo) sss sos soa)-                                                      where soj = getInlinefragmentObject ifo--- replace variables with values and do type checking--- ASSUME: variables are prefixed with $-replaceObjectsVariables :: [(String,[(String,String)])] -> [RootObject] -> [(String,String,String)] -> [RootObject]-replaceObjectsVariables _ [] _ = []-replaceObjectsVariables sss objs vars = [replaceObjectVariables sss obj vars | obj<-objs]-replaceObjectVariables :: [(String,[(String,String)])] -> RootObject -> [(String,String,String)] -> RootObject-replaceObjectVariables sss (NestedObject alias name sobject ss sfs) vars = NestedObject alias name sobject (if ss/=Nothing then (replaceScalarVariable (findScalars sss sobject) vars $ fromJust ss) else Nothing) [replaceSubfieldVariables sss sobject vars sf | sf<-sfs]-findScalars :: [(String,[(String,String)])] -> String -> [(String,String)]-findScalars [] _ = throw InvalidObjectException-findScalars ((name,sclrs):t) sobj = if (sobj==name) then sclrs else (findScalars t sobj)-replaceScalarVariable :: [(String,String)] -> [(String,String,String)] -> ScalarType -> SubSelection-replaceScalarVariable sclrs vars (ScalarType alias name trans arg) = if (isValue arg)&&(elem '$' $ getValue arg) then (Just $ ScalarType alias name trans (Just $ findReplacement (findScalarType sclrs name) (getValue arg) vars)) else (Just $ ScalarType alias name trans arg)-findScalarType :: [(String,String)] -> String -> String-findScalarType [] _ = throw InvalidObjectScalarFieldException-findScalarType ((name,typ):t) sname = if sname==name then typ else (findScalarType t sname) -findReplacement :: String -> String -> [(String,String,String)] -> String-findReplacement styp arg [] = throw InvalidVariableNameException-findReplacement styp arg ((name,typ,val):t)-    | (name==arg)&&(typ==styp) = val-    | (name==arg) = throw MismatchedVariableTypeException-    | otherwise = findReplacement styp arg t-replaceSubfieldVariables :: [(String,[(String,String)])] -> String -> [(String,String,String)] -> Field -> Field-replaceSubfieldVariables sss sobj vars (Left (ScalarType alias name trans arg)) = if (isValue arg)&&(elem '$' $ getValue arg) then (Left (ScalarType alias name trans (Just $ findReplacement (findScalarType (findScalars sss sobj) name) (getValue arg) vars)) :: Field) else (Left (ScalarType alias name trans arg) :: Field)-replaceSubfieldVariables sss sobj vars (Right (Left (NestedObject alias name nsobj ss sfs))) = (Right (Left $ NestedObject alias name nsobj (if ss/=Nothing then (replaceScalarVariable (findScalars sss nsobj) vars $ fromJust ss) else Nothing) [replaceSubfieldVariables sss nsobj vars sf | sf<-sfs] :: FieldObject) :: Field)-replaceSubfieldVariables sss sobj vars (Right (Right (InlinefragmentObject ifsobj sfs))) = (Right (Right $ InlinefragmentObject ifsobj [replaceSubfieldVariables sss ifsobj vars sf | sf<-sfs] :: FieldObject) :: Field)-isValue :: Maybe String -> Bool-isValue Nothing = False-isValue _ = True-getValue :: Maybe String -> String-getValue arg = fromJust arg+module Components.ObjectHandlers.ServerObjectValidator (checkObjectsAttributes,replaceObjectsVariables) where
+
+
+import Control.Exception (throw)
+import Data.List (foldl')
+import Model.ServerObjectTypes (
+        ServerObject,
+        RootObject,
+        ScalarType(..),
+        Field,
+        InlinefragmentObject(..),
+        NestedObject(..)
+    )
+import Model.ServerExceptions (
+        QueryException(
+            InvalidObjectException,
+            InvalidScalarException,
+            MismatchedVariableTypeException
+        )
+    )
+import Components.ObjectHandlers.ObjectsHandler (
+        isValidServerObjectChild,
+        isValidServerObjectNestedObjectField,
+        isValidServerObjectScalarField,
+        isValidScalarTransformation
+    )
+
+-- check that all nested objects are with valid properties
+checkObjectsAttributes :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool
+checkObjectsAttributes objs sss sos soa = foldl' (\y x-> (hasValidAttributes x sss sos soa)&&y) True objs
+hasValidAttributes :: NestedObject -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool
+hasValidAttributes (NestedObject alias name sobject Nothing sfs) sss sos soa = isValidSubFields sobject sfs sss sos soa
+hasValidAttributes (NestedObject alias name sobject (Just ss) sfs) sss sos soa = (isValidSubSelection sobject ss sss soa)&&isValidSubFields sobject sfs sss sos soa
+isValidSubSelection :: ServerObject -> ScalarType -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> Bool
+isValidSubSelection obj (ScalarType alias name trans arg) sss soa = (isValidServerObjectScalarField obj name sss soa)&&isValidScalarTransformation obj name trans arg sss soa
+isValidSubFields :: ServerObject -> [Field] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,[String],[String])] -> Bool
+isValidSubFields _ [] _ _ _ = True  -- we should not get an empty query
+isValidSubFields obj sfs sss sos soa = foldl' (\y x-> (isValidSubField obj x sss sos soa)&&y) True sfs
+isValidSubField :: ServerObject -> Field -> [(String,[(String,String,[(String,[(String,String,String,String)])])])]-> [(String,[String])] -> [(String,[String],[String])] -> Bool
+isValidSubField obj (Left (ScalarType alias "__typename" trans arg)) sss sos soa = True
+isValidSubField obj (Left (ScalarType alias name trans arg)) sss sos soa = (isValidServerObjectScalarField obj name sss soa)&&isValidScalarTransformation obj name trans arg sss soa
+isValidSubField obj (Right (Left (NestedObject alias name sobject ss sfs))) sss sos soa = (isValidServerObjectNestedObjectField obj name sos soa)&&hasValidAttributes (NestedObject alias name sobject ss sfs) sss sos soa
+isValidSubField obj (Right (Right (InlinefragmentObject ifo sfs))) sss sos soa = (isValidServerObjectChild obj ifo soa)&&isValidSubFields ifo sfs sss sos soa
+-- 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]
+replaceObjectVariables sss soa (NestedObject alias name sobject (Just (ScalarType sAlias sName trans (Just arg))) sfs) vars = NestedObject alias name sobject newScalar [replaceSubfieldVariables sss soa sobject vars sf | sf<-sfs]
+  where
+    newScalar = Just $ ScalarType sAlias sName trans $ Just newValue
+    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) _
+ | h==obj = findScalarType st sts
+ | otherwise = getScalarTypeForVariableReplacement obj st rst []
+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
+
+-- 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
+-- 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
+-- findReplacement :: String -> String -> [(String,String,String)] -> String
+-- findReplacement styp arg [] = throw InvalidVariableNameException
+-- findReplacement styp arg ((name,typ,val):t)
+--     | (name==arg)&&(typ==styp) = val
+--     | (name==arg) = throw MismatchedVariableTypeException
+--     | otherwise = findReplacement styp arg t
+
+replaceSubfieldVariables :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],[String])] -> String -> [(String,String,String)] -> Field -> Field
+replaceSubfieldVariables _ _ _ _ (Left (ScalarType alias name trans Nothing)) = Left $ ScalarType alias name trans Nothing
+replaceSubfieldVariables sss soa sobj vars (Left (ScalarType alias name trans (Just arg)))
+ | (isVariable arg)==False = Left $ ScalarType alias name trans $ Just arg
+ | otherwise = Left $ ScalarType alias name trans $ Just $ replaceScalarVariable (getScalarTypeForVariableReplacement sobj name sss soa) arg vars
+replaceSubfieldVariables sss soa sobj vars (Right (Left (NestedObject alias name nsobj Nothing sfs))) = Right $ Left $ NestedObject alias name nsobj Nothing [replaceSubfieldVariables sss soa nsobj vars sf | sf<-sfs]
+replaceSubfieldVariables sss soa sobj vars (Right (Left (NestedObject alias name nsobj (Just (ScalarType sAlias sName trans Nothing)) sfs))) = Right $ Left $ NestedObject alias name nsobj (Just $ ScalarType sAlias sName trans Nothing) [replaceSubfieldVariables sss soa nsobj vars sf | sf<-sfs]
+replaceSubfieldVariables sss soa sobj vars (Right (Left (NestedObject alias name nsobj (Just (ScalarType sAlias sName trans (Just arg))) sfs)))
+ | (isVariable arg)==False = Right $ Left $ NestedObject alias name nsobj (Just $ ScalarType sAlias sName trans $ Just arg) [replaceSubfieldVariables sss soa nsobj vars sf | sf<-sfs]
+ | otherwise = Right $ Left $ NestedObject alias name nsobj (Just $ ScalarType sAlias sName trans $ Just $ replaceScalarVariable (getScalarTypeForVariableReplacement nsobj name sss soa) arg vars) [replaceSubfieldVariables sss soa nsobj vars sf | sf<-sfs]
+replaceSubfieldVariables sss soa sobj vars (Right (Right (InlinefragmentObject ifsobj sfs))) = Right $ Right $ InlinefragmentObject ifsobj [replaceSubfieldVariables sss soa ifsobj vars sf | sf<-sfs]
+isVariable :: String -> Bool
+isVariable = elem '$'

src/Components/Parsers/QueryParser.hs view

@@ -1,459 +1,491 @@-module Components.Parsers.QueryParser (processString,validateQuery,parseStringToObjects) where--import Model.ServerExceptions (-        QueryException(-            SyntaxException,-            InvalidScalarException,-            InvalidObjectException,-            InvalidVariableNameException,-            EmptyQueryException,-            ParseFragmentException,-            MismatchedVariableTypeException-        )-    )-import Model.ServerObjectTypes (-        NestedObject(..),-        ServerObject,-        Alias,-        Argument,-        Transformation,-        ScalarType(..),-        RootObjects,-        RootObject,-        Name,-        SubFields,-        InlinefragmentObject(..),-        Field,-        FieldObject,-        SubSelection-    )-import Components.ObjectHandlers.ObjectsHandler (readServerObject)-import Control.Exception (throw)-import Data.Char (toLower)---{-----Step 1. PROCESSING-----}-processString :: String -> String-processString str = removeComments $ removeLinebreaks str--- REQUIREMENTS: Windows and Mac are one of \r\n, \n, or \r to make a new line break. Another OS is maybe different.-removeComments :: String -> String-removeComments str = removeCommentsHelper str False-removeCommentsHelper :: String -> Bool -> String-removeCommentsHelper [] _ = []-removeCommentsHelper (h:[]) _ = h:[]-removeCommentsHelper (h:t) mde- | h=='#' = removeCommentsHelper t True- | h=='\r' = '\r':removeCommentsHelper t False- | h=='\n' = '\n':removeCommentsHelper t False- | mde==True = removeCommentsHelper t mde- | otherwise = h:(removeCommentsHelper t mde)--- NOTE: this is used with only the textarea field of forms since they are giving line breaks these combinations...-removeLinebreaks :: String -> String-removeLinebreaks [] = []-removeLinebreaks (h:t)- | h=='\n'   = ' ':removeLinebreaks t- | h=='\r'   = ' ':removeLinebreaks t- | otherwise = h:removeLinebreaks t---{-----Step 2. VALIDATION-----}-validateQuery :: String -> Bool-validateQuery [] = False-validateQuery str = (validateBracketLocationQuery str)&&(validateNoEmptyBrackets str)--- this is first validation to check that we have equal opening/closing brackets, and we do not close before opening-validateBracketLocationQuery :: String -> Bool-validateBracketLocationQuery str = validateBracketLocationQueryHelper str 0 0-validateBracketLocationQueryHelper :: String -> Int -> Int -> Bool-validateBracketLocationQueryHelper [] x y = (x==y)-validateBracketLocationQueryHelper (h:t) o c- | h=='{'       = validateBracketLocationQueryHelper t (o+1) c- | h=='}'&&o<=c = False- | h=='}'       = validateBracketLocationQueryHelper t o (c+1)- | otherwise    = validateBracketLocationQueryHelper t o c-validateNoEmptyBrackets :: String -> Bool-validateNoEmptyBrackets str = validateNoEmptyBracketsHelper str "" []-validateNoEmptyBracketsHelper :: String -> String -> [String] -> Bool-validateNoEmptyBracketsHelper [] acc nst = (length nst)<1-validateNoEmptyBracketsHelper (a:b) acc []- | a=='{' = validateNoEmptyBracketsHelper b [] [acc]- | a=='}' = False- | a==' ' = validateNoEmptyBracketsHelper b acc []- | otherwise = validateNoEmptyBracketsHelper b (acc++[a]) []-validateNoEmptyBracketsHelper (a:b) acc (i:j)- | a==' ' = validateNoEmptyBracketsHelper b acc (i:j)- | a=='{'&&(length acc)==0 = False- | a=='{'                  = validateNoEmptyBracketsHelper b [] (acc:i:j)- | a=='}'&&(length acc)==0 = False- | a=='}'                  = validateNoEmptyBracketsHelper b i j- | otherwise               = validateNoEmptyBracketsHelper b (acc++[a]) (i:j)---{-----Step 3. PARSING-----}-parseStringToObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> RootObjects-parseStringToObjects [] _ _ _ = throw EmptyQueryException-parseStringToObjects str svrobjs soa vars = composeObjects qry svrobjs soa vars fragments-  where-    (qry,fmts) = getQueryAndFragments str-    fragments = parseFragments fmts svrobjs soa-    -- query = substituteFragments qry fragments svrobjs vars--- REQUIRES: curly braces are in correct order-getQueryAndFragments :: String -> (String, String)-getQueryAndFragments str = getQueryAndFragmentsHelper str 0 False "" ""-getQueryAndFragmentsHelper :: String -> Int -> Bool -> String -> String -> (String, String)-getQueryAndFragmentsHelper [] _ _ x y = (x, y)-getQueryAndFragmentsHelper (h:t) l m q f- | h=='{'&&m==False = getQueryAndFragmentsHelper t (l+1) m (q++[h]) f- | h=='}'&&l==1&&m==False = getQueryAndFragmentsHelper t (l-1) True (q++[h]) f- | h=='}'&&m==False = getQueryAndFragmentsHelper t (l-1) m (q++[h]) f- | m==False = getQueryAndFragmentsHelper t l m (q++[h]) f- | otherwise = getQueryAndFragmentsHelper t l m q (f++[h])-data Fragment = Fragment-    { name :: String-    , targetObject :: ServerObject-    , replacement :: String-    } deriving Show-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 (h:t) acc l rslt svrobjs soa- | h=='{' = parseFragmentsHelper t (acc++[h]) (l+1) rslt svrobjs soa- | h=='}'&&l==1 = parseFragmentsHelper t [] (l-1) ((createFragment acc svrobjs soa):rslt) svrobjs soa -- completed one fragment- | h=='}' = parseFragmentsHelper t (acc++[h]) (l-1) rslt svrobjs soa  -- closed a nested object- | otherwise = parseFragmentsHelper t (acc++[h]) l rslt svrobjs soa--- 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-{--    d is for declaration-    n is for name-    a is for arrangement-    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 (h:t) l acc d n a o rst1 rst2 svrobjs soa- | d==False&&(h=='f'||h=='r'||h=='a'||h=='g'||h=='m'||h=='e'||h=='n'||h=='t') = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | d==False&&h==' '&&(length acc)>0&&acc=="fragment" = createFragmentHelper t l [] True n a o rst1 rst2 svrobjs soa- | d==False&&h==' '&&(length acc)>0 = throw ParseFragmentException- | d==False&&h==' '&&(length acc)<1 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs soa- | d==False = throw ParseFragmentException- | n==False&&h==' '&&(length acc)==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs soa- | n==False&&h==' '&&(length acc)>0 = createFragmentHelper t l [] d True a o acc rst2 svrobjs soa- | n==False&&(isValidFragmentNameChar h)==False = throw ParseFragmentException- | n==False = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | a==False&&h==' '&&(length acc)==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs soa- | a==False&&h==' '&&(length acc)>0&&(acc=="on") = createFragmentHelper t l [] d n True o rst1 rst2 svrobjs soa- | a==False&&h==' '&&(length acc)>0 = throw ParseFragmentException- | a==False&&(h=='o'||h=='n') = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | a==False = throw ParseFragmentException- | o==False&&((length acc)==0)&&((fromEnum h)>=97||(fromEnum h)<=122) = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | o==False&&((length acc)==0)&&(h==' ') = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs soa- | o==False&&((length acc)==0) = throw ParseFragmentException- | o==False&&h==' ' = createFragmentHelper t l [] d n a True rst1 acc svrobjs soa- | o==False&&h=='{' = createFragmentHelper t (l+1) [] d n a True rst1 acc svrobjs soa- | o==False&&(isValidIdentifierChar h) = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | o==False = throw ParseFragmentException- | h==' '&&l==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs soa- | h=='{'&&l==0 = createFragmentHelper t (l+1) [] d n a o rst1 rst2 svrobjs soa- | l==0 = throw ParseFragmentException- | (isValidIdentifierChar h)||h==' '||h==')'||h=='('||h==':'||h=='$'||h=='@' = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs soa- | h=='{' = createFragmentHelper t (l+1) (acc++[h]) d n a o rst1 rst2 svrobjs soa- | h=='}' = createFragmentHelper t (l-1) (acc++[h]) d n a o rst1 rst2 svrobjs soa- | otherwise = throw ParseFragmentException-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)-isValidIdentifierChar :: Char -> Bool-isValidIdentifierChar c = ((fromEnum c)>=65&&(fromEnum c)<=90)||((fromEnum c)>=97&&(fromEnum c)<=122)||((fromEnum c)>=48&&(fromEnum c)<=57)||((fromEnum c)==95)||((fromEnum c)==36)---  -- call after infering types on nested objects--- get block in this scope-splitSubject :: String -> String -> Int -> (String,String)-splitSubject [] acc _ = (acc,"")-splitSubject (h:t) acc l- | l<0 = (acc,h:t)- | h=='{' = splitSubject t (acc++[h]) (l+1)- | h=='}' = splitSubject t (acc++[h]) (l-1)- | otherwise = splitSubject t (acc++[h]) l--- -- substitute target string with replacement string within subject string...return result--- parse provided string to obtain query-{--REQUIRES: Query is balanced and ordered brackets.-input is whole query string with opening and closing brackets-EFFECTS: Return value is list of desired objects with specifications-passing code block to separateRootObjects() where code block is not including query opening and closing brackets-TODO: change Bool to Either with exceptions--}-composeObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects-composeObjects [] _ _ _ _ = throw EmptyQueryException-composeObjects str svrobjs soa vars fmts = composeObjectsHelper str 0 svrobjs soa vars fmts-composeObjectsHelper :: String -> Int -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects-composeObjectsHelper [] _ _ _ _ _ = throw EmptyQueryException-composeObjectsHelper (h:t) l svrobjs soa vars fmts- | h=='{'&&l==0 = separateRootObjects (extractLevel t) svrobjs soa vars fmts -- find and separate every root object- | otherwise = composeObjectsHelper t l svrobjs soa vars fmts--- ...separate and determine operation--- TODO: implement operations--- determineOperation :: String -> (Operation,String)--- determineOperation str = determineOperationHelper str ""--- determineOperationHelper :: String -> String -> String--- determineOperationHelper [] acc = ((parseOperation acc1),[]) -- TODO: throw exception on empty query--- determineOperationHelper (h:t) acc---  | h=='{' = ((parseOperation acc), (removeLevel t))---  | otherwise = determineOperationHelper t (acc++[h])--- ...create several RootObjects from query blocks--- REQUIRES: brackets are balanced and ordered--- NOTE: only querying is first supported; mutations are later--- EFFECTS: passing block to createNestedObject where block is including opening and closing curly brackets-separateRootObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject]-separateRootObjects str svrobjs soa vars fmts = separateRootObjectsHelper str "" svrobjs soa vars fmts-separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject]-separateRootObjectsHelper [] _ _ _ _ _ = []-separateRootObjectsHelper (h:t) acc svrobjs soa vars fmts-    | h=='{' = (((createNestedObject (acc++[h]++level) svrobjs soa vars fmts) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs soa vars fmts)-    | otherwise = separateRootObjectsHelper t (acc++[h]) svrobjs soa vars fmts-  where-    (level,levelTail) = splitLevel t "" 0--- create root object from block--- EFFECTS: passing code block to parseSubFields where block is not including root object opening and closing curly brackets.-createNestedObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject-createNestedObject str svrobjs soa vars fmts = createNestedObjectHelper str "" svrobjs soa vars fmts-createNestedObjectHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject-createNestedObjectHelper [] _ _ _ _ _ = throw InvalidObjectException  -- we should not encounter this since we already checked against empty brackets-createNestedObjectHelper (h:t) acc svrobjs soa vars fmts-    | h=='{' = (NestedObject ((parseAlias acc) :: Alias) ((parseName acc) :: Name) serverObj ((parseSubSelection acc) :: SubSelection) ((parseSubFields (extractLevel t) svrobjs soa vars fmts serverObj) :: SubFields)) :: RootObject-    | otherwise = createNestedObjectHelper t (acc++[h]) svrobjs soa vars fmts-  where-    serverObj = ((parseServerObject acc svrobjs soa) :: ServerObject)--- given object header without any braces, we want a name.-parseServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject-parseServerObject [] svrobjs soa = readServerObject "" svrobjs soa-parseServerObject str svrobjs soa- | (elem ':' str)==True&&(elem '(' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then [] else (y++[x])) "" (foldr (\x y -> if x=='(' then [] else x:y) "" str)) svrobjs soa- | (elem ':' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then [] else (y++[x])) "" str) svrobjs soa- | otherwise = readServerObject (removeSpaces str) svrobjs soa--- given object header without any braces, we want the alias if there is one.-parseAlias :: String -> Alias-parseAlias [] = Nothing :: Alias-parseAlias str-    | (elem ':' str)&&(elem '(' str) = parseAlias $ foldr (\x y -> if x=='(' then [] else x:y) "" str-    | (elem ':' str) = Just $ removeSpaces $ foldr (\x y -> if x==':' then [] else x:y) "" str-    | otherwise = Nothing :: Alias-parseName :: String -> Name-parseName [] = []-parseName str- | (elem ':' str)==True&&(elem '(' str)==True = removeSpaces $ foldl (\y x -> if x==':' then [] else (y++[x])) [] (foldr (\x y -> if x=='(' then [] else x:y) "" str)- | (elem ':' str)==True = removeSpaces $ foldl (\y x -> if x==':' then [] else (y++[x])) "" str- | otherwise = removeSpaces str-parseSubSelection :: String -> SubSelection-parseSubSelection [] = Nothing :: SubSelection-parseSubSelection (h:t)- | h=='('&&(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- | otherwise = parseSubSelection t--- REQUIRES: code block on nested object subfields where nested object opening and closing curly brackets are not included-parseSubFields :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field]-parseSubFields [] _ _ _ _ _ = []-parseSubFields str svrobjs soa vars fmts sobj = parseSubFieldsHelper str [] [] svrobjs soa True vars fmts sobj-parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field]-parseSubFieldsHelper [] [] [] _ _ _ _ _ _ = []-parseSubFieldsHelper [] [] acc _ _ True _ _ _ = [Left $ createScalarType acc :: Field]-parseSubFieldsHelper [] [] acc _ _ False _ _ _ = []-parseSubFieldsHelper [] acc [] _ _ True _ _ _ = [Left $ createScalarType acc :: Field]-parseSubFieldsHelper [] acc [] _ _ False _ _ _ = []--- 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 (h:t) acc1 acc2 svrobjs soa inc vars fmts sobj-    | h==':' = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1++[h]) [] svrobjs soa inc vars fmts sobj-    | h==' '&&(length acc1)>0 = parseSubFieldsHelper t [] acc1 svrobjs soa inc vars fmts sobj-    | h==' ' = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj-    | h==','&&(length acc1)>0&&(inc==True) = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t [] [] svrobjs soa True vars fmts sobj-    | h==','&&(length acc1)>0 = parseSubFieldsHelper t [] [] svrobjs soa True vars fmts sobj-    | h==','&&(length acc2)>0&&(inc==True) = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t [] [] svrobjs soa True vars fmts sobj-    | h==','&&(length acc2)>0 = parseSubFieldsHelper t [] [] svrobjs soa True vars fmts sobj-    | h==',' = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj-    | h=='('&&(length acc1)>0 = parseSubFieldsHelper selectTail (acc1++[h]++subselect) [] svrobjs soa inc vars fmts sobj-    | h=='('&&(length acc2)>0 = parseSubFieldsHelper selectTail (acc2++[h]++subselect) [] svrobjs soa inc vars fmts sobj-    | h=='{'&&(length acc1)>0&&(inc==True) = (Right $ (Left $ (createNestedObject (acc1++[h]++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs soa True vars fmts sobj-    | h=='{'&&(length acc1)>0 = parseSubFieldsHelper levelTail [] [] svrobjs soa True vars fmts sobj-    | h=='{'&&(length acc2)>0&&(inc==True) = (Right $ (Left $ (createNestedObject (acc2++[h]++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs soa True vars fmts sobj-    | h=='{'&&(length acc2)>0 = parseSubFieldsHelper levelTail [] [] svrobjs soa True vars fmts sobj-    | h=='@'&&directive==True = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa True vars fmts sobj-    | h=='@' = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa False vars fmts sobj-    | h=='.'&&(length acc1)>0 = parseSubFieldsHelper t (acc1++[h]) [] svrobjs soa True vars fmts sobj-    | h=='.'&&(length acc2)>0&&inc==True = if isInlineFragment then (Left $ createScalarType acc2 :: Field):(Right (Right $ (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail [] [] svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) [] [] svrobjs soa inc vars fmts sobj-    | h=='.'&&(length acc2)>0 = if isInlineFragment then (Right (Right $ (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail [] [] svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) [] [] svrobjs soa inc vars fmts sobj-    | h=='.'&&isInlineFragment==True = (Right (Right $ (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail [] [] svrobjs soa True vars fmts sobj-    | h=='.' = parseSubFieldsHelper (fContents++fragmentTail) [] [] svrobjs soa inc vars fmts sobj-    | h=='}' = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj  -- this character is removed when I pull a level-    | (length acc2)>0&&inc==True = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) [] svrobjs soa True vars fmts sobj-    | (length acc2)>0 = parseSubFieldsHelper t (acc1++[h]) [] svrobjs soa True vars fmts sobj-    | otherwise = parseSubFieldsHelper t (acc1++[h]) [] svrobjs soa inc vars fmts sobj-  where-    (level,levelTail) = splitLevel t "" 0-    (subselect,selectTail) = getSubSelection t-    (directive,directiveTail) = checkDirective (h:t) vars-    (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment (h:t)-    (fragmentName,fragmentTail) = findFragment (h:t)-    fContents = expandFragment fragmentName sobj fmts--checkInlinefragment :: String -> (Bool,String,String,String)-checkInlinefragment str = checkInlinefragmentHelper str [] False []-checkInlinefragmentHelper :: String -> String -> Bool -> String -> (Bool,String,String,String)-checkInlinefragmentHelper [] _ _ _ = (False,[],[],[])-checkInlinefragmentHelper (h:t) acc sobj obj-    | (length acc)<3&&h=='.' = checkInlinefragmentHelper t (acc++[h]) False []-    | (length acc)<3 = throw ParseFragmentException-    | (length acc)==3&&h/=' ' = (False,[],[],(acc++(h:t)))-    | (length acc)==3 = checkInlinefragmentHelper t (acc++[h]) False []-    | (length acc)==4&&h==' ' = checkInlinefragmentHelper t acc False []-    | (length acc)==4&&h=='o' = checkInlinefragmentHelper t (acc++[h]) False []-    | (length acc)==4 = throw ParseFragmentException-    | (length acc)==5&&h=='n' = checkInlinefragmentHelper t (acc++[h]) False []-    | (length acc)==5 = throw ParseFragmentException-    | (length acc)==6&&h==' ' = checkInlinefragmentHelper t (acc++[h]) False []-    | (length acc)==6 = throw ParseFragmentException-    | (length acc)==7&&h==' ' = checkInlinefragmentHelper t acc False []-    | (length acc)==7&&((fromEnum h)>=97||(fromEnum h)<=122) = checkInlinefragmentHelper t (acc++[h]) False [h]-    | (length acc)==7 = throw ParseFragmentException-    | (length acc)>7&&sobj==False&&(isValidIdentifierChar h) = checkInlinefragmentHelper t acc False (obj++[h])-    | (length acc)>7&&sobj==False&&h==' ' = checkInlinefragmentHelper t acc True obj-    | (length acc)>7&&h==' ' = checkInlinefragmentHelper t acc True obj-    | (length acc)>7&&h/='{' = throw ParseFragmentException-    | (length acc)>7 = (True,obj,contents,tail)-    | otherwise = throw ParseFragmentException-  where-    (contents,tail) = splitSubject t [] 0 -createInlinefragmentObject :: String -> String -> [(String,String,String)] -> [Fragment] -> [(String,[String])] -> [(String,[String],[String])] -> InlinefragmentObject-createInlinefragmentObject bdy obj vars fmts svrobjs soa = (InlinefragmentObject (readServerObject obj svrobjs soa) ((parseSubFields bdy svrobjs soa vars fmts obj) :: SubFields))--findFragment :: String -> (String,String)-findFragment [] = throw ParseFragmentException-findFragment str = findFragmentHelper str []-findFragmentHelper :: String -> String -> (String,String)-findFragmentHelper [] acc = (acc,[])-findFragmentHelper (h:t) acc-  | (length acc)<3&&h=='.' = findFragmentHelper t (acc++[h])-  | (length acc)<3 = throw ParseFragmentException-  | (length acc)==3&&(isValidFragmentNameChar h) = findFragmentHelper t (acc++[h])-  | (length acc)==3 = throw ParseFragmentException-  | (length acc)>3&&(isValidFragmentNameChar h) = findFragmentHelper t (acc++[h])-  | (length acc)>3&&h==' ' = (acc,t)-  | otherwise = 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--removeLeadingSpaces :: String -> String-removeLeadingSpaces [] = []-removeLeadingSpaces (h:t) = if h==' ' then removeLeadingSpaces t else (h:t)--- EFFECTS: return subselection and String remainder-getSubSelection :: String -> (String,String)-getSubSelection str = getSubSelectionHelper str ""-getSubSelectionHelper :: String -> String -> (String,String)-getSubSelectionHelper [] acc = ([],[])-getSubSelectionHelper (h:t) acc -    | h==')' = (acc++[h], t)-    | otherwise = getSubSelectionHelper t (acc++[h])--- 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))-    | h=='{' = splitLevel t (acc++[h]) (l+1)-    | h=='}' = splitLevel t (acc++[h]) (l-1)-    | otherwise = splitLevel t (acc++[h]) l--- 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-checkDirectiveHelper :: (String,String,String) -> [(String,String,String)] -> (Bool,String)-checkDirectiveHelper (dir,(h:t),tail) vars-    | directive=="include"&&value=="true"=(True,tail)-    | directive=="include"&&value=="false"=(False,tail)-    | directive=="skip"&&value=="true"=(False,tail)-    | directive=="skip"&&value=="false"=(True,tail)-    | otherwise = throw InvalidScalarException-  where-    directive = toLowercase dir-    value = if h=='$' then toLowercase $ getVariableValue vars (h:t) else toLowercase (h:t)-isDirective :: String -> Bool-isDirective [] = False-isDirective (h:t)-    | h=='@' = True-    | h==' ' = isDirective t-    | otherwise = False-getDirective :: String -> (String,String,String)-getDirective (h:t)-    | h==' ' = getDirective t-    | h=='@' = (dir,val,tail)-  where-    dir = removeSideSpaces $ foldl (\y x -> if x=='@' then [] else y++[x]) "" $ getPrefix (h:t) '('-    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-getSuffix :: String -> Char -> String-getSuffix [] _ = []-getSuffix (h:t) chr = if h==chr then t else getSuffix t chr-toLowercase :: String -> String-toLowercase str = [toLower c | c <- str]-getVariableValue :: [(String,String,String)] -> String -> String-getVariableValue [] _ = throw InvalidVariableNameException-getVariableValue ((name,typ,val):t) var-    | (name==var)&&(typ=="Bool") = val-    | (name==var) = throw MismatchedVariableTypeException-    | otherwise = getVariableValue t var--- pull level and leave out closing brace.-extractLevel :: String -> String-extractLevel [] = []-extractLevel str = extractLevelHelper str 0-extractLevelHelper :: String -> Int -> String-extractLevelHelper [] _ = []-extractLevelHelper (h:t) l- | h=='{' = h:extractLevelHelper t (l+1)- | h=='}'&&l==0 = []- | h=='}' = '}':extractLevelHelper t (l-1)- | otherwise = h:extractLevelHelper t l--- -- remove level and leave out closing brace--- removeLevel :: String -> String--- removeLevel [] = []--- removeLevel str = removeLevelHelper str 0--- removeLevelHelper :: String -> Int -> String--- removeLevelHelper [] _ = []--- removeLevelHelper (h:t) l---  | l<0 = h:t---  | h=='{' = removeLevelHelper t (l+1)---  | h=='}' = removeLevelHelper t (l-1)---  | otherwise = removeLevelHelper t l-removeSpaces :: String -> String-removeSpaces str = [x | x <- str, x/=' ']-createScalarType :: String -> ScalarType-createScalarType [] = throw InvalidScalarException-createScalarType str = ScalarType (parseAlias str :: Alias) (parseName str :: Name) (parseTransformation str :: Transformation) (parseArgument str :: Argument)-parseTransformation :: String -> Transformation-parseTransformation [] = Nothing :: Transformation-parseTransformation str-    | (elem '(' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==':' then [] else x:y) "" $ foldl (\y x -> if x=='(' then [] else y++[x]) "" str) :: Transformation-    | (elem '(' str) = throw SyntaxException-    | otherwise = Nothing :: Transformation-parseArgument :: String -> Argument-parseArgument [] = Nothing :: Argument-parseArgument str-    | (elem ')' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==')' then [] else x:y) "" $ foldl (\y x -> if x==':' then [] else y++[x]) "" str) :: Argument-    | (elem ')' str) = throw SyntaxException-    | otherwise = Nothing :: Argument-removeSideSpaces :: String -> String-removeSideSpaces str = foldl (\y x -> if (x==' '&&(length y)==0) then [] else y++[x]) "" $ foldr (\x y -> if (x==' '&&(length y)==0) then [] else x:y) "" str--- parseOperation :: String -> Operation--- TODO: support mutations---{-----Step 4. CROSS-CHECKING-----}--- done by ServerObjectValidator.hs--{-----Step 5. MAKE QUERY-----}--- done by SQLQueryComposer.hs for sql queries--{-----Step 6. PROCESS RESULTS-----}--- done by PersistentDataProcessor.hs+module Components.Parsers.QueryParser (processString,validateQuery,parseStringToObjects) where
+
+import Components.ObjectHandlers.ObjectsHandler (readServerObject)
+import Control.Exception (throw)
+import Data.Char (toLower)
+import Model.ServerExceptions (
+    QueryException(
+      SyntaxException,
+      InvalidScalarException,
+      InvalidObjectException,
+      InvalidVariableNameException,
+      EmptyQueryException,
+      ParseFragmentException,
+      MismatchedVariableTypeException
+    )
+  )
+import Model.ServerObjectTypes (
+    NestedObject(..),
+    ServerObject,
+    Alias,
+    Name,
+    Argument,
+    Transformation,
+    ScalarType(..),
+    RootObjects,
+    RootObject,
+    SubFields,
+    InlinefragmentObject(..),
+    Field,
+    FieldObject,
+    SubSelection,
+    Fragment(..)
+  )
+
+
+{-----Step 1. PROCESSING-----}
+processString :: String -> String
+processString str = removeComments $ removeLinebreaks str
+-- REQUIREMENTS: Windows and Mac are one of \r\n, \n, or \r to make a new line break. Another OS is maybe different.
+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
+-- 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 (h:t) = h:removeLinebreaks t
+
+
+{-----Step 2. VALIDATION-----}
+validateQuery :: String -> Bool
+validateQuery "" = False
+validateQuery str = (validateBracketLocationQuery str)&&(validateNoEmptyBrackets str)
+-- this is first validation to check that we have equal opening/closing brackets, and we do not close before opening
+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
+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 [] = 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)
+validateNoEmptyBracketsHelper ('}':b) acc (i:j)
+ | (length acc)==0 = False
+ | otherwise = validateNoEmptyBracketsHelper b i j
+validateNoEmptyBracketsHelper (a:b) acc (i:j) = validateNoEmptyBracketsHelper b (acc++[a]) (i:j)
+
+
+{-----Step 3. PARSING-----}
+parseStringToObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> RootObjects
+parseStringToObjects [] _ _ _ = throw EmptyQueryException
+parseStringToObjects str svrobjs soa vars = composeObjects qry svrobjs soa vars fragments
+  where
+    (qry,fmts) = getQueryAndFragments str
+    fragments = parseFragments fmts svrobjs soa
+    -- query = substituteFragments qry fragments svrobjs vars
+-- REQUIRES: curly braces are in correct order
+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])
+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
+-- 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
+{-
+    d is for declaration
+    n is for name
+    a is for arrangement
+    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 ('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
+createFragmentHelper ('g':t) l "fra" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "frag" False n a o rst1 rst2 svrobjs soa
+createFragmentHelper ('m':t) l "frag" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fragm" False n a o rst1 rst2 svrobjs soa
+createFragmentHelper ('e':t) l "fragm" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fragme" False n a o rst1 rst2 svrobjs soa
+createFragmentHelper ('n':t) l "fragme" False n a o rst1 rst2 svrobjs soa = createFragmentHelper t l "fragmen" False n a o rst1 rst2 svrobjs soa
+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  
+ | isValidIdentifierChar h = createFragmentHelper t l (acc++[h]) True True True True rst1 rst2 svrobjs soa
+ | otherwise = throw ParseFragmentException
+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)
+isValidIdentifierChar :: Char -> Bool
+isValidIdentifierChar c = ((fromEnum c)>=65&&(fromEnum c)<=90)||((fromEnum c)>=97&&(fromEnum c)<=122)||((fromEnum c)>=48&&(fromEnum c)<=57)||((fromEnum c)==95)||((fromEnum c)==36)
+-- call after infering types on nested objects
+-- 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
+-- -- substitute target string with replacement string within subject string...return result
+-- parse provided string to obtain query
+{-
+REQUIRES: Query is balanced and ordered brackets.
+input is whole query string with opening and closing brackets
+EFFECTS: Return value is list of desired objects with specifications
+passing code block to separateRootObjects() where code block is not including query opening and closing brackets
+TODO: change Bool to Either with exceptions
+-}
+composeObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects
+composeObjects "" _ _ _ _ = throw EmptyQueryException
+composeObjects str svrobjs soa vars fmts = composeObjectsHelper str 0 svrobjs soa vars fmts
+composeObjectsHelper :: String -> Int -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> RootObjects
+composeObjectsHelper "" _ _ _ _ _ = throw EmptyQueryException
+composeObjectsHelper ('{':t) 0 svrobjs soa vars fmts = separateRootObjects (extractLevel t) svrobjs soa vars fmts -- find and separate every root object
+composeObjectsHelper (_:t) l svrobjs soa vars fmts = composeObjectsHelper t l svrobjs soa vars fmts
+-- ...separate and determine operation
+-- TODO: implement operations
+-- determineOperation :: String -> (Operation,String)
+-- determineOperation str = determineOperationHelper str ""
+-- determineOperationHelper :: String -> String -> String
+-- determineOperationHelper [] acc = ((parseOperation acc1),[]) -- TODO: throw exception on empty query
+-- determineOperationHelper (h:t) acc
+--  | h=='{' = ((parseOperation acc), (removeLevel t))
+--  | otherwise = determineOperationHelper t (acc++[h])
+-- ...create several RootObjects from query blocks
+-- REQUIRES: brackets are balanced and ordered
+-- NOTE: only querying is first supported; mutations are later
+-- EFFECTS: passing block to createNestedObject where block is including opening and closing curly brackets
+separateRootObjects :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject]
+separateRootObjects str svrobjs soa vars fmts = separateRootObjectsHelper str "" svrobjs soa vars fmts
+separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> [RootObject]
+separateRootObjectsHelper "" _ _ _ _ _ = []
+separateRootObjectsHelper ('{':t) acc svrobjs soa vars fmts = (((createNestedObject (acc++"{"++level) svrobjs soa vars fmts) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs soa vars fmts)
+  where
+    (level,levelTail) = splitLevel t "" 0
+separateRootObjectsHelper (h:t) acc svrobjs soa vars fmts = separateRootObjectsHelper t (acc++[h]) svrobjs soa vars fmts
+-- create root object from block
+-- EFFECTS: passing code block to parseSubFields where block is not including root object opening and closing curly brackets.
+createNestedObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject
+createNestedObject str svrobjs soa vars fmts = createNestedObjectHelper str "" svrobjs soa vars fmts
+createNestedObjectHelper :: String -> String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> NestedObject
+createNestedObjectHelper "" _ _ _ _ _ = throw InvalidObjectException  -- we should not encounter this since we already checked against empty brackets
+createNestedObjectHelper ('{':t) acc svrobjs soa vars fmts = NestedObject (parseAlias acc) (parseName acc) serverObj (parseSubSelection acc) ((parseSubFields (extractLevel t) svrobjs soa vars fmts serverObj) :: SubFields) :: RootObject
+  where
+    serverObj = parseServerObject acc svrobjs soa
+createNestedObjectHelper (h:t) acc svrobjs soa vars fmts = createNestedObjectHelper t (acc++[h]) svrobjs soa vars fmts
+-- given object header without any braces, we want a name.
+parseServerObject :: String -> [(String,[String])] -> [(String,[String],[String])] -> ServerObject
+parseServerObject "" svrobjs soa = readServerObject "" svrobjs soa
+parseServerObject str svrobjs soa
+ | (elem ':' str)==True&&(elem '(' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str)) svrobjs soa
+ | (elem ':' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" str) svrobjs soa
+ | otherwise = readServerObject (removeSpaces str) svrobjs soa
+-- given object header without any braces, we want the alias if there is one.
+parseAlias :: String -> Alias
+parseAlias "" = Nothing :: Alias
+parseAlias str
+    | (elem ':' str)&&(elem '(' str) = parseAlias $ foldr (\x y -> if x=='(' then "" else x:y) "" str
+    | (elem ':' str) = Just $ removeSpaces $ foldr (\x y -> if x==':' then "" else x:y) "" str
+    | otherwise = Nothing :: Alias
+parseName :: String -> Name
+parseName "" = ""
+parseName str
+ | (elem ':' str)==True&&(elem '(' str)==True = removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" (foldr (\x y -> if x=='(' then "" else x:y) "" str)
+ | (elem ':' str)==True = removeSpaces $ foldl (\y x -> if x==':' then "" else (y++[x])) "" str
+ | 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
+-- REQUIRES: code block on nested object subfields where nested object opening and closing curly brackets are not included
+parseSubFields :: String -> [(String,[String])] -> [(String,[String],[String])] -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field]
+parseSubFields "" _ _ _ _ _ = []
+parseSubFields str svrobjs soa vars fmts sobj = parseSubFieldsHelper str "" "" svrobjs soa True vars fmts sobj
+parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> [(String,[String],[String])] -> Bool -> [(String,String,String)] -> [Fragment] -> ServerObject -> [Field]
+parseSubFieldsHelper "" "" "" _ _ _ _ _ _ = []
+parseSubFieldsHelper "" "" acc _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field]
+parseSubFieldsHelper "" "" acc _ _ False _ _ _ = []
+parseSubFieldsHelper "" acc "" _ _ True _ _ _ = [(Left $ createScalarType acc) :: Field]
+parseSubFieldsHelper "" acc "" _ _ False _ _ _ = []
+-- There is not a case where both acc1 and acc2 are not empty, but I'll catch anyway
+parseSubFieldsHelper "" acc1 acc2 _ _ True _ _ _ = (Left $ createScalarType (acc2++acc1)):[]
+parseSubFieldsHelper "" acc1 acc2 _ _ False _ _ _ = []
+parseSubFieldsHelper (':':t) acc1 acc2 svrobjs soa inc vars fmts sobj = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1++":") "" svrobjs soa inc vars fmts sobj
+parseSubFieldsHelper (' ':t) acc1 acc2 svrobjs soa inc vars fmts sobj
+ | (length acc1)>0 = parseSubFieldsHelper t "" acc1 svrobjs soa inc vars fmts sobj
+ | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj
+parseSubFieldsHelper (',':t) acc1 acc2 svrobjs soa True vars fmts sobj
+ | (length acc1)>0 = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj
+ | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj  -- if acc is not empty, I assume that acc1 is empty
+parseSubFieldsHelper (',':t) acc1 acc2 svrobjs soa inc vars fmts sobj
+ | (length acc1)>0 = parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj
+ | (length acc2)>0 = parseSubFieldsHelper t "" "" svrobjs soa True vars fmts sobj
+ | otherwise = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj
+parseSubFieldsHelper ('(':t) acc1 acc2 svrobjs soa inc vars fmts sobj
+    | (length acc1)>0 = parseSubFieldsHelper selectTail (acc1++"("++subselect) "" svrobjs soa inc vars fmts sobj
+    | (length acc2)>0 = parseSubFieldsHelper selectTail (acc2++"("++subselect) "" svrobjs soa inc vars fmts sobj
+  where
+    (subselect,selectTail) = getSubSelection t
+parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs soa True vars fmts sobj
+    | (length acc1)>0 = (Right (Left (createNestedObject (acc1++"{"++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj
+    | (length acc2)>0 = (Right (Left (createNestedObject (acc2++"{"++level) svrobjs soa vars fmts) :: FieldObject) :: Field):parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj    
+  where
+    (level,levelTail) = splitLevel t "" 0
+parseSubFieldsHelper ('{':t) acc1 acc2 svrobjs soa _ vars fmts sobj
+    | (length acc1)>0 = parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj    
+    | (length acc2)>0 = parseSubFieldsHelper levelTail "" "" svrobjs soa True vars fmts sobj
+  where
+    (level,levelTail) = splitLevel t "" 0
+parseSubFieldsHelper ('@':t) acc1 acc2 svrobjs soa _ vars fmts sobj
+    | directive==True = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa True vars fmts sobj
+    | otherwise = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs soa False vars fmts sobj
+  where
+    (directive,directiveTail) = checkDirective ('@':t) vars  
+parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs soa True vars fmts sobj
+    | (length acc2)>0 = if isInlineFragment then (Left $ createScalarType acc2 :: Field):(Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa True vars fmts sobj
+  where
+    (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment ('.':t)
+    (fragmentName,fragmentTail) = findFragment ('.':t)
+    fContents = expandFragment fragmentName sobj fmts
+parseSubFieldsHelper ('.':t) acc1 acc2 svrobjs soa inc vars fmts sobj
+    | (length acc1)>0 = parseSubFieldsHelper t (acc1++".") "" svrobjs soa True vars fmts sobj
+    | (length acc2)>0 = if isInlineFragment then (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj else parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa inc vars fmts sobj
+    | isInlineFragment==True = (Right (Right (createInlinefragmentObject inlinefragmentBody inlinefragmentObj vars fmts svrobjs soa) :: FieldObject) :: Field):parseSubFieldsHelper inlinefragmentTail "" "" svrobjs soa True vars fmts sobj
+    | otherwise = parseSubFieldsHelper (fContents++fragmentTail) "" "" svrobjs soa inc vars fmts sobj
+  where
+    (isInlineFragment,inlinefragmentObj,inlinefragmentBody,inlinefragmentTail) = checkInlinefragment ('.':t)
+    (fragmentName,fragmentTail) = findFragment ('.':t)
+    fContents = expandFragment fragmentName sobj fmts
+parseSubFieldsHelper ('}':t) acc1 acc2 svrobjs soa inc vars fmts sobj = parseSubFieldsHelper t acc1 acc2 svrobjs soa inc vars fmts sobj  -- this character is removed when I pull a level
+parseSubFieldsHelper (h:t) acc1 acc2 svrobjs soa True vars fmts sobj
+ | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa True vars fmts sobj   
+parseSubFieldsHelper (h:t) acc1 acc2 svrobjs soa inc vars fmts sobj
+ | (length acc2)>0 = parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa True vars fmts sobj
+ | otherwise = parseSubFieldsHelper t (acc1++[h]) "" svrobjs soa inc vars fmts sobj
+    
+
+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 ""
+checkInlinefragmentHelper _ "." _ _ = throw ParseFragmentException
+checkInlinefragmentHelper ('.':t) ".." sobj obj = checkInlinefragmentHelper t "..." False ""
+checkInlinefragmentHelper _ ".." _ _ = throw ParseFragmentException
+checkInlinefragmentHelper (' ':t) "..." sobj obj = checkInlinefragmentHelper t "... " False ""
+checkInlinefragmentHelper (h:t) "..." sobj obj = (False,"","","..."++(h:t))
+checkInlinefragmentHelper (' ':t) "... " sobj obj = checkInlinefragmentHelper t "... " False ""
+checkInlinefragmentHelper ('o':t) "... " sobj obj = checkInlinefragmentHelper t "... o" False ""
+checkInlinefragmentHelper _ "... " _ _ = throw ParseFragmentException
+checkInlinefragmentHelper ('n':t) "... o" sobj obj = checkInlinefragmentHelper t "... n" False ""
+checkInlinefragmentHelper _ "... o" _ _ = throw ParseFragmentException
+checkInlinefragmentHelper (' ':t) "... on" sobj obj = checkInlinefragmentHelper t "... on " False ""
+checkInlinefragmentHelper _ "... on" _ _ = throw ParseFragmentException
+checkInlinefragmentHelper (' ':t) "... on " sobj obj = checkInlinefragmentHelper t "... on " False ""
+checkInlinefragmentHelper (h:t) "... on " sobj obj
+ | ((fromEnum h)>=97||(fromEnum h)<=122) = checkInlinefragmentHelper t ("... on "++[h]) False [h]
+ | otherwise = throw ParseFragmentException
+checkInlinefragmentHelper (h:t) acc False obj
+ | isValidIdentifierChar h = checkInlinefragmentHelper t acc False (obj++[h])
+checkInlinefragmentHelper (' ':t) acc False obj = checkInlinefragmentHelper t acc True obj
+checkInlinefragmentHelper (' ':t) acc _ obj = checkInlinefragmentHelper t acc True obj
+checkInlinefragmentHelper ('{':t) acc _ obj = (True,obj,contents,tail)
+  where
+    (contents,tail) = splitSubject t "" 0 
+checkInlinefragmentHelper _ _ _ _ = throw ParseFragmentException
+    
+createInlinefragmentObject :: String -> String -> [(String,String,String)] -> [Fragment] -> [(String,[String])] -> [(String,[String],[String])] -> InlinefragmentObject
+createInlinefragmentObject bdy obj vars fmts svrobjs soa = InlinefragmentObject (readServerObject obj svrobjs soa) ((parseSubFields bdy svrobjs soa vars fmts obj) :: SubFields)
+
+findFragment :: String -> (String,String)
+findFragment "" = throw ParseFragmentException
+findFragment str = findFragmentHelper str ""
+findFragmentHelper :: String -> String -> (String,String)
+findFragmentHelper "" acc = (acc,"")
+findFragmentHelper ('.':t) "" = findFragmentHelper t "."
+findFragmentHelper _ "" = throw ParseFragmentException
+findFragmentHelper ('.':t) "." = findFragmentHelper t ".."
+findFragmentHelper _ "." = throw ParseFragmentException
+findFragmentHelper ('.':t) ".." = findFragmentHelper t "..."
+findFragmentHelper _ ".." = throw ParseFragmentException
+findFragmentHelper (h:t) "..."
+ | isValidFragmentNameChar h = findFragmentHelper t ("..."++[h])
+ | otherwise = throw ParseFragmentException
+findFragmentHelper (' ':t) acc = (acc,t)
+findFragmentHelper (h:t) acc
+ | isValidFragmentNameChar h = findFragmentHelper t (acc++[h])
+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
+
+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])
+-- 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
+-- 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
+checkDirectiveHelper :: (String,String,String) -> [(String,String,String)] -> (Bool,String)
+checkDirectiveHelper (dir,(h:t),tail) vars
+    | directive=="include"&&value=="true"=(True,tail)
+    | directive=="include"&&value=="false"=(False,tail)
+    | directive=="skip"&&value=="true"=(False,tail)
+    | directive=="skip"&&value=="false"=(True,tail)
+    | otherwise = throw InvalidScalarException
+  where
+    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 _ = False
+getDirective :: String -> (String,String,String)
+getDirective (' ':t) = getDirective t
+getDirective ('@':t) = (dir,val,tail)
+  where
+    dir = removeSideSpaces $ foldl (\y x -> if x=='@' then "" else y++[x]) "" $ getPrefix ('@':t) '('
+    val = removeSideSpaces $ foldl (\y x -> if x==':' then "" else y++[x]) "" $ getPrefix t ')'
+    tail = getSuffix t ')'
+getPrefix :: String -> Char -> String
+getPrefix "" _ = ""
+getPrefix (h:t) chr = if h==chr then "" else h:getPrefix t chr
+getSuffix :: String -> Char -> String
+getSuffix "" _ = ""
+getSuffix (h:t) chr = if h==chr then t else getSuffix t chr
+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
+-- 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
+-- -- remove level and leave out closing brace
+-- removeLevel :: String -> String
+-- removeLevel [] = []
+-- removeLevel str = removeLevelHelper str 0
+-- removeLevelHelper :: String -> Int -> String
+-- removeLevelHelper [] _ = []
+-- removeLevelHelper (h:t) l
+--  | l<0 = h:t
+--  | h=='{' = removeLevelHelper t (l+1)
+--  | h=='}' = removeLevelHelper t (l-1)
+--  | otherwise = removeLevelHelper t l
+removeSpaces :: String -> String
+removeSpaces str = [x | x <- str, x/=' ']
+createScalarType :: String -> ScalarType
+createScalarType "" = throw InvalidScalarException
+createScalarType str = ScalarType (parseAlias str) (parseName str) (parseTransformation str) (parseArgument str)
+parseTransformation :: String -> Transformation
+parseTransformation "" = Nothing :: Transformation
+parseTransformation str
+    | (elem '(' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==':' then "" else x:y) "" $ foldl (\y x -> if x=='(' then "" else y++[x]) "" str) :: Transformation
+    | (elem '(' str) = throw SyntaxException
+    | otherwise = Nothing :: Transformation
+parseArgument :: String -> Argument
+parseArgument "" = Nothing :: Argument
+parseArgument str
+    | (elem ')' str)&&(elem ':' str) = (Just $ removeSideSpaces $ foldr (\x y -> if x==')' then "" else x:y) "" $ foldl (\y x -> if x==':' then "" else y++[x]) "" str) :: Argument
+    | (elem ')' str) = throw SyntaxException
+    | otherwise = Nothing :: Argument
+removeSideSpaces :: String -> String
+removeSideSpaces str = foldl (\y x -> if x==' '&&(length y)==0 then "" else y++[x]) "" $ foldr (\x y -> if x==' '&&(length y)==0 then "" else x:y) "" str
+-- parseOperation :: String -> Operation
+-- TODO: support mutations
+
+
+{-----Step 4. CROSS-CHECKING-----}
+-- done by ServerObjectValidator.hs
+
+{-----Step 5. MAKE QUERY-----}
+-- done by SQLQueryComposer.hs for sql queries
+
+{-----Step 6. PROCESS RESULTS-----}
+-- done by PersistentDataProcessor.hs

src/Components/Parsers/ServerSchemaJsonParser.hs view

@@ -1,103 +1,153 @@-module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where--import Control.Exception (throw)-import Text.JSON (-    JSValue(JSObject),-    JSObject,-    Result(Ok,Error),-    valFromObj,-    decode-  )-import Model.ServerExceptions (-    QueryException(-      ImportSchemaServerNameException,-      ImportSchemaException,-      ImportSchemaChildrenException,-      ImportSchemaPseudonymsException,-      ImportSchemaServerNameException,-      ImportSchemaScalarFieldsException,-      ImportSchemaDatabaseTablesException,-      ImportSchemaObjectFieldsException,-      ImportSchemaDatabaseRelationshipsException-    )-  )---fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])-fetchArguments fp = do -    schema <- Prelude.readFile fp-    return $ parseSchema schema-parseSchema :: String -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])-parseSchema str = parseHelper $ checkJSValueListValue (decode str :: Result (JSObject JSValue))-checkJSValueListValue :: Result (JSObject JSValue) -> (JSObject JSValue)-checkJSValueListValue (Error str) = throw ImportSchemaException-checkJSValueListValue (Ok a) = a-parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])-parseHelper json = (svrobjs,sss,sos,sdbn,sor,soa)-  where-    (svrobjs,sss,sos,sdbn,sor) = parsePrimitivesIterator [] [] [] [] [] $ getObjects (valFromObj "PrimitiveObjects" json :: Result [JSObject JSValue])-    soa = parseParentsIterator [] $ getObjects (valFromObj "ParentalObjects" json :: Result [JSObject JSValue])-parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String)])] -> [(String,[String])] -> [(String,String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])])-parsePrimitivesIterator svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor)-parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,table):sdbn) (sor++(processRelationships relationships)) t-  where-    name = getString (valFromObj "ServerName" obj :: Result String) 0-    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0-    scalars = checkScalars (valFromObj "ScalarFields" obj :: Result [JSValue])-    nestedobjects = getStringList (valFromObj "ObjectFields" obj :: Result [String]) 1-    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) = parseParentsIterator ((name,pseudonyms,children):soa) t-  where-    name = getString (valFromObj "ServerName" obj :: Result String) 0-    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0-    children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 2-getObjects :: Result [JSObject JSValue] -> [JSObject JSValue]-getObjects (Error _) = throw ImportSchemaServerNameException-getObjects (Ok objects) = objects-getString :: Result String -> Int -> String-getString (Ok str) _ = str-getString (Error str) t-  | t==0 = throw ImportSchemaServerNameException-  | t==1 = throw ImportSchemaScalarFieldsException-  | t==2 = throw ImportSchemaDatabaseTablesException-  | otherwise = throw ImportSchemaException-getStringList :: Result [String] -> Int -> [String]-getStringList (Ok rlt) _ = rlt-getStringList _ t-  | t==0 = throw ImportSchemaPseudonymsException-  | t==1 = throw ImportSchemaObjectFieldsException-  | t==2 = throw ImportSchemaChildrenException-  | otherwise = throw ImportSchemaException-getListStringList :: Result [[String]] -> [[String]]-getListStringList (Error str) = throw ImportSchemaDatabaseRelationshipsException-getListStringList (Ok rlt) = rlt-checkScalars :: Result [JSValue] -> [(String,String)]-checkScalars (Error str) = throw ImportSchemaScalarFieldsException-checkScalars (Ok a) = getScalars a-getScalars :: [JSValue] -> [(String,String)]-getScalars [] = []-getScalars ((JSObject obj):t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String)):(getScalars t)-getType :: Result String -> String-getType (Error str) = throw ImportSchemaScalarFieldsException-getType (Ok a)-    | a=="Text" = a-    | a=="ByteString" = a-    | a=="Int" = a-    | a=="Double" = a-    | a=="Rational" = a-    | a=="Bool" = a-    | a=="Day" = a-    | a=="TimeOfDay" = a-    | a=="UTCTime" = a-    | otherwise = throw ImportSchemaScalarFieldsException-processRelationships :: [[String]] -> [(String,String,[String])]-processRelationships lst = foldr (\x y -> (getFirst x,getThird x, x):y) [] lst-getFirst :: [String] -> String-getFirst (h:t) = h-getFirst _ = throw ImportSchemaException-getThird :: [String] -> String-getThird (h1:h2:h3:t) = h3-getThird _ = throw ImportSchemaException+module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where
+
+import Control.Exception (throw)
+import Data.List (foldl')
+import Text.JSON (
+    JSValue(JSObject),
+    JSObject,
+    Result(Ok,Error),
+    valFromObj,
+    decode
+  )
+import Model.ServerExceptions (
+    QueryException(
+      ImportSchemaServerNameException,
+      ImportSchemaException,
+      ImportSchemaChildrenException,
+      ImportSchemaPseudonymsException,
+      ImportSchemaScalarFieldsException,
+      ImportSchemaDatabaseTablesException,
+      ImportSchemaObjectFieldsException,
+      ImportSchemaDatabaseRelationshipsException,
+      ImportSchemaDuplicateException
+    )
+  )
+
+
+fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
+fetchArguments fp = do 
+    schema <- Prelude.readFile fp
+    return $ parseSchema schema
+parseSchema :: String -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
+parseSchema str = parseHelper $ checkJSValueListValue (decode str :: Result (JSObject JSValue))
+checkJSValueListValue :: Result (JSObject JSValue) -> (JSObject JSValue)
+checkJSValueListValue (Error str) = throw ImportSchemaException
+checkJSValueListValue (Ok a) = a
+parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
+parseHelper json = if (isValidParentScalars soa sss)&&(isWithoutDups svrobjs sss sos sor soa) then (svrobjs,sss,sos,sdbn,sor,soa) else throw ImportSchemaChildrenException
+  where
+    (svrobjs,sss,sos,sdbn,sor) = parsePrimitivesIterator [] [] [] [] [] $ getObjects (valFromObj "PrimitiveObjects" json :: Result [JSObject JSValue])
+    soa = parseParentsIterator [] $ getObjects (valFromObj "ParentalObjects" json :: Result [JSObject JSValue])
+parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])])
+parsePrimitivesIterator svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor)
+parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = if foldl' (\acc (prev,_)->(prev==name)||acc) False sdbn then throw ImportSchemaDuplicateException else parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,table):sdbn) (sor++(processRelationships relationships)) t
+  where
+    name = getString (valFromObj "ServerName" obj :: Result String) 0
+    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
+    scalars = checkScalars (valFromObj "ScalarFields" obj :: Result [JSValue])
+    nestedobjects = getStringList (valFromObj "ObjectFields" obj :: Result [String]) 1
+    table = getString (valFromObj "DatabaseTable" obj :: Result String) 2
+    relationships = getListStringList (valFromObj "DatabaseRelationships" obj :: Result [[String]])
+parseParentsIterator :: [(String,[String],[String])] -> [JSObject JSValue] -> [(String,[String],[String])]
+parseParentsIterator soa [] = soa
+parseParentsIterator soa (obj:t) = if foldl' (\acc (prev,_,_)->(prev==name)||acc) False soa then throw ImportSchemaDuplicateException else parseParentsIterator ((name,pseudonyms,children):soa) t
+  where
+    name = getString (valFromObj "ServerName" obj :: Result String) 0
+    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
+    children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 2
+getObjects :: Result [JSObject JSValue] -> [JSObject JSValue]
+getObjects (Error _) = throw ImportSchemaServerNameException
+getObjects (Ok objects) = objects
+getString :: Result String -> Int -> String
+getString (Ok str) _ = str
+getString (Error str) 0 = throw ImportSchemaServerNameException
+getString (Error str) 1 = throw ImportSchemaScalarFieldsException
+getString (Error str) 2 = throw ImportSchemaDatabaseTablesException
+getString _ _ = throw ImportSchemaException
+getStringList :: Result [String] -> Int -> [String]
+getStringList (Ok rlt) _ = rlt
+getStringList _ 0 = throw ImportSchemaPseudonymsException
+getStringList _ 1 = throw ImportSchemaObjectFieldsException
+getStringList _ 2 = throw ImportSchemaChildrenException
+getStringList _ _ = throw ImportSchemaException
+getListStringList :: Result [[String]] -> [[String]]
+getListStringList (Error str) = throw ImportSchemaDatabaseRelationshipsException
+getListStringList (Ok rlt) = rlt
+checkScalars :: Result [JSValue] -> [(String,String,[(String,[(String,String,String,String)])])]
+checkScalars (Error str) = throw ImportSchemaScalarFieldsException
+checkScalars (Ok a) = getScalars a
+getScalars :: [JSValue] -> [(String,String,[(String,[(String,String,String,String)])])]
+getScalars [] = []
+getScalars ((JSObject obj):t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String),getScalarArguments $ getObjects (valFromObj "Arguments" obj :: Result [JSObject JSValue])):getScalars t
+getScalarArguments :: [JSObject JSValue] -> [(String,[(String,String,String,String)])]
+getScalarArguments [] = []
+getScalarArguments (h:t) = (name,options):getScalarArguments t
+  where
+    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
+getType :: Result String -> String
+getType (Ok "Text") = "Text"
+getType (Ok "ByteString") = "ByteString"
+getType (Ok "Int") = "Int"
+getType (Ok "Double") = "Double"
+getType (Ok "Rational") = "Rational"
+getType (Ok "Bool") = "Bool"
+getType (Ok "Day") = "Day"
+getType (Ok "TimeOfDay") = "TimeOfDay"
+getType (Ok "UTCTime") = "UTCTime"
+-- getType (Error str) = throw ImportSchemaScalarFieldsException
+getType _ = throw ImportSchemaScalarFieldsException
+processRelationships :: [[String]] -> [(String,String,[String])]
+processRelationships lst = foldr (\x y -> (getFirst x,getThird x, x):y) [] lst
+getFirst :: [String] -> String
+getFirst (h:t) = h
+getFirst _ = throw ImportSchemaException
+getThird :: [String] -> String
+getThird (h1:h2:h3:t) = h3
+getThird _ = throw ImportSchemaException
+-- no duplicated names in schema
+isWithoutDups :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String])] -> [(String,String,[String])] -> [(String,[String],[String])] -> Bool
+isWithoutDups sobjs sss sos sor soa = (isNoDupsNames $ foldr (++) [] ([x | (_,x)<-sobjs]++[x | (_,x,_)<-soa]))&&(isNoDupsScalars sss)&&(isNoDupsNestedObjects sos)&&(isNoDupsRelationships sor)
+isNoDupsNames :: [String] -> Bool
+isNoDupsNames [] = True
+isNoDupsNames (nm:rst) = (foldl' (\y x->x/=nm&&y) True rst)&&isNoDupsNames rst
+isNoDupsScalars :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
+isNoDupsScalars sss = foldl' (\y (_,x)->y&&isNoDupsScalarNames x) True sss
+isNoDupsScalarNames :: [(String,String,[(String,[(String,String,String,String)])])] -> Bool
+isNoDupsScalarNames [] = True
+isNoDupsScalarNames ((name,_,args):rst) = (foldl' (\y (x,_,_)->name/=x&&y) True rst)&&(isNoDupsScalarArguments args)&&isNoDupsScalarNames rst
+isNoDupsScalarArguments :: [(String,[(String,String,String,String)])] -> Bool
+isNoDupsScalarArguments [] = True
+isNoDupsScalarArguments ((name,opts):rst) = (foldl' (\y (n,o)->name/=n&&y&&isNoDupsArgumentOptions o) True rst)&&isNoDupsScalarArguments rst
+isNoDupsArgumentOptions :: [(String,String,String,String)] -> Bool
+isNoDupsArgumentOptions [] = True
+isNoDupsArgumentOptions ((name,_,_,_):rst) = (foldl' (\y (n,_,_,_)->name/=n&&y) True rst)&&isNoDupsArgumentOptions rst
+isNoDupsNestedObjects :: [(String,[String])] -> Bool
+isNoDupsNestedObjects [] = True
+isNoDupsNestedObjects ((_,[]):rst) = isNoDupsNestedObjects rst
+isNoDupsNestedObjects ((obj,no:objs):rst) = (elem no objs)==False&&isNoDupsNestedObjects ((obj,objs):rst)
+isNoDupsRelationships :: [(String,String,[String])] -> Bool
+isNoDupsRelationships [] = True
+isNoDupsRelationships ((from,to,_):rst) = (foldl' (\y (a,b,_)->(from/=a||to/=b)&&y) True rst)&&isNoDupsRelationships rst
+-- shared scalars are same type
+isValidParentScalars :: [(String,[String],[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
+isValidParentScalars [] _ = True
+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
+getPrimitiveScalars :: String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)]
+getPrimitiveScalars _ [] = throw ImportSchemaChildrenException
+getPrimitiveScalars name ((nm,st):t) = if name==nm then foldl' (\y (n,tp,_)->(n,tp):y) [] st else getPrimitiveScalars name t
+isValidScalarsType :: [(String,String)] -> [String] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
+isValidScalarsType _ [] _ = True
+isValidScalarsType [] _ _ = True
+isValidScalarsType ((name,typ):t) cld sss = foldl' (\y x->foldl' (\b (n,tp)->if n==name then typ==tp&&y else y) True (getPrimitiveScalars x sss)) True cld
+

src/Components/Parsers/VariablesParser.hs view

@@ -1,81 +1,93 @@-module Components.Parsers.VariablesParser where--import Model.ServerExceptions (-        QueryException(-            MissingVariableValueException,-            ReadVariablesException,-            VariablesSyntaxException,-            EmptyQueryException,-            VariablesSyntaxException,-            InvalidVariableTypeException-        )-    )-import Control.Exception (throw)-import Text.JSON (JSValue,JSObject,fromJSObject,Result(Ok,Error),encode,decode)-import Data.Maybe (fromJust,Maybe(Nothing,Just))----- with a variables string and query string, we want 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-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,vval) [] = if vval==Nothing then throw MissingVariableValueException else (vname,vtype,fromJust vval :: String)-findVariableValue (vname1,vtype,vval1) ((vname2,vval2):t) = if (vname1==vname2) then (vname1,vtype,vval2) else (findVariableValue (vname1,vtype,vval1) t)-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,fromJust val) | (nam,typ,val)<-vars]--- from given variables argument, we want variable-values-parseVariableValuePairs :: String -> [(String,String)]-parseVariableValuePairs [] = []-parseVariableValuePairs vars = castValues $ fromJSObject $ checkVariables (decode vars :: Result (JSObject JSValue))-checkVariables :: Result (JSObject JSValue) -> JSObject JSValue-checkVariables (Error str) = throw ReadVariablesException-checkVariables (Ok vars) = vars-castValues :: [(String,JSValue)] -> [(String,String)]-castValues vars = [("$"++(removeQuotations name),encode val) | (name,val)<-vars]-removeQuotations :: String -> String-removeQuotations (h1:h2:t) = if (h1=='\\')&&(h2=='"') then (removeQuotations t) else h1:(removeQuotations (h2:t))-removeQuotations str = str-getVariableTypePairs :: String -> [(String,String,Maybe String)]-getVariableTypePairs [] = throw EmptyQueryException-getVariableTypePairs qry-    | (elem '(' epilogue)&&(elem ')' epilogue) = separateVariables False "" False "" "" $ removeLeadingSpaces $ foldl (\y x -> if x=='(' then [] else y++[x]) [] $ foldr (\x y -> if x==')' then [] else x:y) [] epilogue-    | (elem '(' epilogue) = throw VariablesSyntaxException-    | (elem ')' epilogue) = throw VariablesSyntaxException-    | otherwise = []-  where-    epilogue = getQueryEpilogue qry-getQueryEpilogue :: String -> String-getQueryEpilogue [] = throw EmptyQueryException-getQueryEpilogue (h:t) = if (h=='{') then [] else h:(getQueryEpilogue t)-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)]-separateVariables _ [] _ _ _ [] = []  -- no variables-separateVariables _ var _ [] _ [] = throw VariablesSyntaxException  -- variable without type-separateVariables _ var _ typ [] [] = if (isValidBaseType typ) then (var,typ,Nothing):[] else throw InvalidVariableTypeException  -- variable without default value-separateVariables _ var _ typ dval [] = if (isValidBaseType typ) then (var,typ,Just $ removeTailSpaces dval):[] else throw InvalidVariableTypeException  -- variable with default value-separateVariables var acc1 typ acc2 acc3 (h:t)-    | (var==False)&&(h/=':') = separateVariables var (acc1++[h]) typ acc2 acc3 t-    | (var==False) = separateVariables True (removeTailSpaces acc1) False [] [] (removeLeadingSpaces t)-    | (typ==False)&&(h==',') = if (isValidBaseType finalizedType)==True then (acc1,finalizedType,Nothing):(separateVariables False [] False [] [] (removeLeadingSpaces t)) else throw InvalidVariableTypeException-    | (typ==False)&&(h/='=') = separateVariables var acc1 typ (acc2++[h]) [] t-    | (typ==False)&&(isValidBaseType finalizedType) = separateVariables var acc1 True finalizedType [] (removeLeadingSpaces t)-    | (typ==False) = throw InvalidVariableTypeException-    | (h/=',') = separateVariables var acc1 typ acc2 (acc3++[h]) t-    | otherwise = (acc1,acc2,if (length finalizedValue)==0 then Nothing else (Just $ finalizedValue)):(separateVariables False [] False [] [] $ removeLeadingSpaces t)-  where-    finalizedType = removeTailSpaces acc2-    finalizedValue = removeTailSpaces acc3-removeTailSpaces :: String -> String-removeTailSpaces str = reverseString $ removeLeadingSpaces $ reverseString str-reverseString :: String -> String-reverseString str = foldl (\y x->x:y) [] str-isValidBaseType :: String -> Bool-isValidBaseType typ = elem typ ["Text","ByteString","Int","Double","Rational","Bool","Day","TimeOfDay","UTCTime"]+module Components.Parsers.VariablesParser (parseVariables) where
+
+import Control.Exception (throw)
+import Text.JSON (JSValue,JSObject,fromJSObject,Result(Ok,Error),encode,decode)
+import Data.List (foldl')
+import Model.ServerExceptions (
+        QueryException(
+            MissingVariableValueException,
+            ReadVariablesException,
+            EmptyQueryException,
+            VariablesSyntaxException,
+            InvalidVariableTypeException
+        )
+    )
+
+
+-- with a variables string and query string, we want 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
+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
+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
+parseVariableValuePairs :: String -> [(String,String)]
+parseVariableValuePairs [] = []
+parseVariableValuePairs vars = castValues $ fromJSObject $ checkVariables (decode vars :: Result (JSObject JSValue))
+checkVariables :: Result (JSObject JSValue) -> JSObject JSValue
+checkVariables (Error str) = throw ReadVariablesException
+checkVariables (Ok vars) = vars
+castValues :: [(String,JSValue)] -> [(String,String)]
+castValues vars = [("$"++(removeQuotations name),encode val) | (name,val)<-vars]
+removeQuotations :: String -> String
+removeQuotations (h1:h2:t) = if h1=='\\'&&h2=='"' then removeQuotations t else h1:(removeQuotations (h2:t))
+removeQuotations str = str
+getVariableTypePairs :: String -> [(String,String,Maybe String)]
+getVariableTypePairs [] = throw EmptyQueryException
+getVariableTypePairs qry
+    | (elem '(' epilogue)&&(elem ')' epilogue) = separateVariables False "" False "" "" $ removeLeadingSpaces $ foldl (\y x -> if x=='(' then [] else y++[x]) [] $ foldr (\x y -> if x==')' then [] else x:y) [] epilogue
+    | (elem '(' epilogue) = throw VariablesSyntaxException
+    | (elem ')' epilogue) = throw VariablesSyntaxException
+    | otherwise = []
+  where
+    epilogue = getQueryEpilogue qry
+getQueryEpilogue :: String -> String
+getQueryEpilogue [] = throw EmptyQueryException
+getQueryEpilogue (h:t) = if h=='{' then [] else h:(getQueryEpilogue t)
+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)]
+separateVariables _ [] _ _ _ [] = []  -- no variables
+separateVariables _ var _ [] _ [] = throw VariablesSyntaxException  -- variable without type
+separateVariables _ var _ typ [] [] = if (isValidBaseType typ) then (var,typ,Nothing):[] else throw InvalidVariableTypeException  -- variable without default value
+separateVariables _ var _ typ dval [] = if (isValidBaseType typ) then (var,typ,Just $ removeTailSpaces dval):[] else throw InvalidVariableTypeException  -- variable with default value
+separateVariables False acc1 typ acc2 acc3 (':':t) = separateVariables True (removeTailSpaces acc1) False [] [] $ removeLeadingSpaces t
+separateVariables False acc1 typ acc2 acc3 (h:t) = separateVariables False (acc1++[h]) typ acc2 acc3 t
+separateVariables var acc1 False acc2 acc3 (',':t) = if (isValidBaseType finalizedType)==True then (acc1,finalizedType,Nothing):separateVariables False [] False [] [] (removeLeadingSpaces t) else throw InvalidVariableTypeException
+  where
+    finalizedType = removeTailSpaces acc2
+separateVariables var acc1 False acc2 acc3 ('=':t)
+    | isValidBaseType finalizedType = separateVariables var acc1 True finalizedType [] $ removeLeadingSpaces t
+    | otherwise = throw InvalidVariableTypeException
+  where
+    finalizedType = removeTailSpaces acc2
+separateVariables var acc1 False acc2 acc3 (h:t) = separateVariables var acc1 False (acc2++[h]) [] t
+separateVariables var acc1 typ acc2 acc3 (',':t) = (acc1,acc2,if (length finalizedValue)==0 then Nothing else Just $ finalizedValue):(separateVariables False [] False [] [] $ removeLeadingSpaces t)
+  where
+    finalizedValue = removeTailSpaces acc3
+separateVariables var acc1 typ acc2 acc3 (h:t) = separateVariables var acc1 typ acc2 (acc3++[h]) t
+removeTailSpaces :: String -> String
+removeTailSpaces str = reverseString $ removeLeadingSpaces $ reverseString str
+reverseString :: String -> String
+reverseString str = foldl (\y x->x:y) [] str
+isValidBaseType :: String -> Bool
+isValidBaseType "Text" = True
+isValidBaseType "ByteString" = True
+isValidBaseType "Int" = True
+isValidBaseType "Double" = True
+isValidBaseType "Rational" = True
+isValidBaseType "Bool" = True
+isValidBaseType "Day" = True
+isValidBaseType "TimeOfDay" = True
+isValidBaseType "UTCTime" = True
+isValidBaseType _ = False

src/Components/QueryComposers/SQLQueryComposer.hs view

@@ -1,85 +1,145 @@-module Components.QueryComposers.SQLQueryComposer (makeSqlQueries) where--import Model.ServerObjectTypes (RootObject,NestedObject,SubFields)-import Model.ServerExceptions (QueryException(CreatingSqlQueryObjectsException,CreatingSqlQueryObjectFieldsException,InvalidObjectException,InvalidScalarException,RelationshipConfigurationException))-import Components.ObjectHandlers.ObjectsHandler (translateServerObjectToDBName,getSubSelectionArgument,getSubSelectionField,withSubSelection,getDBObjectRelationships,getServerObject,getInlinefragmentObject,getInlinefragmentFields,isServerObjectTable,getSubFields,getScalarName,isServerObjectTable)-import Data.Either (fromLeft,fromRight,isRight,isLeft)-import Data.Map.Strict (fromList,Map,(!),insertWith)-import Control.Exception (throw)---makeSqlQueries :: [RootObject] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> ([[[String]]],[[String]])-makeSqlQueries [] _ _ _ = ([],[])-makeSqlQueries rojs sodn sor soa = unzip $ map unzip $ map (makeSqlQuerySet sodn sor soa) rojs-makeSqlQuerySet :: [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> RootObject -> [([String],String)]-makeSqlQuerySet sodn sor soa obj = if (length dbNames)==1 then (addSqlQueryFields (getSubFields obj) (fromList [(firstTable,1)]) ("select "++firstTable++(show 1)++".id,") (" from"++(makeSqlTablePhrase obj firstTable 1)) (" order by "++firstTable++(show 1)++".id asc") (((firstTable,1):[])) [] sodn sor soa (firstTable:[])) else (foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields obj) (fromList [(x,1)]) ("select "++x++(show 1)++".id,") (" from"++(makeSqlTablePhrase obj x 1)) (" order by "++x++(show 1)++".id asc") ((x,1):[]) [] sodn sor soa (x:[])) | x<-dbNames])-                           where-                             dbNames = translateServerObjectToDBName (getServerObject obj) sodn soa-                             firstTable = head dbNames--- 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++(show number) else " "++name++" as "++name++(show number)-addSqlQueryFields :: SubFields -> Map String Int -> String -> String -> String -> [(String,Int)] -> [SubFields] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> [String] -> [([String],String)]-addSqlQueryFields [] counts select from order [] [] _ _ _ tbls = [(tbls,(removeLastChar select)++from++order++";")]-addSqlQueryFields [] counts select from order [] _ _ _ _ _ = throw CreatingSqlQueryObjectFieldsException-addSqlQueryFields [] counts select from order _ [] _ _ _ tbls = [(tbls,(removeLastChar select)++from++order++";")]-addSqlQueryFields [] counts select from order (_:b) (h:t) sodn sor soa tbls = addSqlQueryFields h counts select from order b t sodn sor soa tbls-addSqlQueryFields (h:t) counts select from order [] _ _ _ _ _ = throw CreatingSqlQueryObjectsException  -- fields without objects-addSqlQueryFields (h:t) counts select from order ((ltable,ltableNo):names) fields sodn sor soa tbls-    | (isLeft h)==True&&scalarName=="__typename" = addSqlQueryFields t counts select from order ((ltable,ltableNo):names) fields sodn sor soa tbls-    | (isLeft h)==True = addSqlQueryFields t counts (select++(ltable++(show ltableNo))++"."++(getScalarName $ fromLeft (throw InvalidScalarException) h)++",") from order ((ltable,ltableNo):names) fields sodn sor soa tbls-    -- since only difference is table name, I should remove repeated computations by changing only name...-    | (isLeft fobj)&&(length tables)>1 = foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields nobj) (calcNewCounts ltable x counts sor) (select++x++(show $ (!) (calcNewCounts ltable x counts sor) x)++".id,") (from++(makeTransitions (calcNewCounts ltable x counts sor) (getDBObjectRelationships ltable x sor) nobj)) (order++","++x++(show $ (!) (calcNewCounts ltable x counts sor) x)++".id asc") ((x,((calcNewCounts ltable x counts sor) ! x)):(ltable,ltableNo):names) (t:fields) sodn sor) soa (x:tbls) | x<-tables]-    | (isLeft fobj)&&(length tables)>0 = addSqlQueryFields (getSubFields nobj) firstTableNewCounts (select++firstSubfieldTable++(show $ (!) firstTableNewCounts firstSubfieldTable)++".id,") (from++(makeTransitions firstTableNewCounts (getDBObjectRelationships ltable firstSubfieldTable sor) nobj)) (order++","++firstSubfieldTable++(show $ (!) firstTableNewCounts firstSubfieldTable)++".id asc") ((firstSubfieldTable,firstTableNewCounts ! firstSubfieldTable):(ltable,ltableNo):names) (t:fields) sodn sor soa (firstSubfieldTable:tbls)-    | (isRight fobj)&&(isServerObjectTable ltable (getInlinefragmentObject ifobj) sodn soa) = addSqlQueryFields ((getInlinefragmentFields ifobj)++t) counts select from order ((ltable,ltableNo):names) fields sodn sor soa tbls-    | otherwise = addSqlQueryFields t counts select from order ((ltable,ltableNo):names) fields sodn sor soa tbls-  where-    scalarName = getScalarName $ fromLeft (throw InvalidScalarException) h-    fobj = fromRight (throw InvalidObjectException) h-    nobj = fromLeft (throw InvalidObjectException) fobj-    ifobj = fromRight (throw InvalidObjectException) fobj    -    tables = translateServerObjectToDBName (getServerObject nobj) sodn soa-    firstSubfieldTable = head tables-    firstTableNewCounts = calcNewCounts ltable firstSubfieldTable counts sor-calcNewCounts :: String -> String -> Map String Int -> [(String,String,[String])] -> Map String Int-calcNewCounts from to pcnt sor = foldr (\x y -> insertWith (+) x 1 y) pcnt (getNewTables $ getDBObjectRelationships from to sor)-removeLastChar :: String -> String-removeLastChar [] = []-removeLastChar str = init str--- get the tables where we need to increment the tables counter-getNewTables :: [String] -> [String]-getNewTables lnk = getNewTablesHelper (tail $ tail lnk) 0-getNewTablesHelper :: [String] -> Int -> [String]-getNewTablesHelper [] _ = []-getNewTablesHelper (h:t) idx-    | (idx==0) = h:getNewTablesHelper (tail t) 3-    | ((mod idx 3)==0) = h:getNewTablesHelper t (idx+1)-    | otherwise = getNewTablesHelper t (idx+1)-makeTransitions :: Map String Int -> [String] -> NestedObject -> String-makeTransitions counts (h1:h2:h3:h4:h5:h6:h7:t) nobj = " left join "++h5++" as "++h5++(show $ (!) counts h5)++" on "++(makeEqColumns (h1++(show $ (!) counts h1)) h2 (h5++(show $ (!) counts h5)) h6)++(completeTransition counts (h3:h4:h5:h6:h7:t) nobj)-makeTransitions counts (h1:h2:h3:h4:t) nobj = " left join "++(if (withSubSelection nobj)==True then ("(select * from "++h3++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")") else h3)++" as "++h3++(show $ (!) counts h3)++" on "++(makeEqColumns (h1++(show $ (!) counts h1)) h2 (h3++(show $ (!) counts h3)) h4)-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++(show $ (!) counts h1)++" on "++(makeEqColumns (h3++(show $ (!) counts h3)) h5 (h1++(show $ (!) counts h1)) h2)-completeTransition counts (h1:h2:h3:h4:h5:h6:h7:h8:t) nobj = " left join "++h6++" as "++h6++(show $ (!) counts h6)++" on "++(makeEqColumns (h3++(show $ (!) counts h3)) h5 (h6++(show $ (!) counts h6)) h7)++(completeTransition counts (h1:h2:h6:h7:h8:t) nobj)-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-makeEqColumnsHelper :: String -> String -> String -> String -> String -> String-makeEqColumnsHelper rlt tb1 col1 tb2 col2-    | (elem ' ' col1)&&(elem ' ' col2)&&((length rlt)>0) = makeEqColumnsHelper (rlt++" and "++tb1++"."++fst++"="++tb2++"."++snd) tb1 rmd1 tb2 rmd2-    | (elem ' ' col1)&&(elem ' ' col2) = makeEqColumnsHelper (tb1++"."++fst++"="++tb2++"."++snd) tb1 rmd1 tb2 rmd2-    | (elem ' ' col1) = throw RelationshipConfigurationException-    | (elem ' ' col2) = throw RelationshipConfigurationException-    | ((length rlt)>0) = rlt++" and "++(tb1++"."++col1++"="++tb2++"."++col2)-    | otherwise = (tb1++"."++col1++"="++tb2++"."++col2)-  where-    (fst, rmd1) = getFirstColumn col1-    (snd, rmd2) = getFirstColumn col2-getFirstColumn :: String -> (String,String)-getFirstColumn str = getFirstColumnHelper "" str-getFirstColumnHelper :: String -> String -> (String,String)-getFirstColumnHelper _ [] = ([],[])-getFirstColumnHelper acc (h:t)-    | (h==' ') = (acc,t)-    | otherwise = getFirstColumnHelper (acc++[h]) t+module Components.QueryComposers.SQLQueryComposer (makeSqlQueries) where
+
+import Data.Map.Strict (fromList,Map,(!),insertWith)
+import Control.Exception (throw)
+import Data.List (foldl')
+import Model.ServerObjectTypes (
+    RootObject,
+    NestedObject,
+    SubFields,
+    Argument,
+    ServerObject,
+    ScalarType(..),
+    InlinefragmentObject(..)
+  )
+import Model.ServerExceptions (
+    QueryException (
+      CreatingSqlQueryObjectsException,
+      CreatingSqlQueryObjectFieldsException,
+      InvalidObjectException,
+      InvalidScalarException,
+      RelationshipConfigurationException,
+      InvalidArgumentException
+    )
+  )
+import Components.ObjectHandlers.ObjectsHandler (
+    translateServerObjectToDBName,
+    getSubSelectionArgument,
+    getSubSelectionField,
+    withSubSelection,
+    getDBObjectRelationships,
+    getServerObject,
+    isServerObjectTable,
+    getSubFields,
+    translateTableToObject
+  )
+
+
+makeSqlQueries :: [RootObject] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> ([[[String]]],[[String]])
+makeSqlQueries [] _ _ _ _ = ([],[])
+makeSqlQueries rojs sss sodn sor soa = unzip [unzip y | y<-[makeSqlQuerySet sss sodn sor soa x | x<-rojs]]
+makeSqlQuerySet :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> RootObject -> [([String],String)]
+makeSqlQuerySet sss sodn sor soa obj = if (length dbNames)==1 then addSqlQueryFields (getSubFields obj) (fromList [(firstTable,1)]) ("select "++firstTable++"1.id,") (" from"++(makeSqlTablePhrase obj firstTable 1)) (" order by "++firstTable++"1.id asc") (((firstTable,1):[])) [] sss sodn sor soa (firstTable:[]) else foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields obj) (fromList [(x,1)]) ("select "++x++"1.id,") (" from"++(makeSqlTablePhrase obj x 1)) (" order by "++x++"1.id asc") ((x,1):[]) [] sss sodn sor soa (x:[])) | x<-dbNames]
+                           where
+                             dbNames = translateServerObjectToDBName (getServerObject obj) sodn soa
+                             firstTable = head dbNames
+-- making table phrase when there is only one sql table
+makeSqlTablePhrase :: NestedObject -> String -> Int -> String
+makeSqlTablePhrase obj name number = if (withSubSelection obj)==True then " (select * from "++name++" where "++(getSubSelectionField obj)++"="++(getSubSelectionArgument obj)++") as "++name++numStr else " "++name++" as "++name++numStr
+  where
+    numStr = show number    
+addSqlQueryFields :: SubFields -> Map String Int -> String -> String -> String -> [(String,Int)] -> [SubFields] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)] -> [(String,String,[String])] -> [(String,[String],[String])] -> [String] -> [([String],String)]
+addSqlQueryFields [] 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
+  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++x++xNumStr++".id,") (from++(makeTransitions newCounts (getDBObjectRelationships ltable x sor) h)) (order++","++x++xNumStr++".id asc") ((x,xNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa (x:tbls) | x<-tables, let newCounts=calcNewCounts ltable x counts sor, let xNum=(!) newCounts x, let xNumStr=show xNum]
+    | (length tables)>0 = addSqlQueryFields (getSubFields h) firstTableNewCounts (select++firstSubfieldTable++firsttableNumStr++".id,") (from++(makeTransitions firstTableNewCounts (getDBObjectRelationships ltable firstSubfieldTable sor) h)) (order++","++firstSubfieldTable++firsttableNumStr++".id asc") ((firstSubfieldTable,firsttableNum):(ltable,ltableNo):names) (t:fields) sss sodn sor soa $ firstSubfieldTable:tbls
+  where
+    tables = translateServerObjectToDBName (getServerObject h) sodn soa
+    firstSubfieldTable = head tables
+    firstTableNewCounts = calcNewCounts ltable firstSubfieldTable counts sor
+    firsttableNum = (!) firstTableNewCounts firstSubfieldTable
+    firsttableNumStr = 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
+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
+removeLastChar "" = ""
+removeLastChar str = init str
+-- get the tables where we need to increment the tables counter
+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)
+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
+    table5NumStr = show $ (!) counts h5
+makeTransitions counts (h1:h2:h3:h4:t) nobj = " left join "++(if (withSubSelection nobj)==True then "(select * from "++h3++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")" else h3)++" as "++h3++table3NumStr++" on "++(makeEqColumns (h1++(show $ (!) counts h1)) h2 (h3++table3NumStr) h4)
+  where
+    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 _ _ = 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
+makeEqColumnsHelper :: String -> String -> String -> String -> String -> String
+makeEqColumnsHelper rlt tb1 col1 tb2 col2
+    | (elem ' ' col1)&&(elem ' ' col2)&&(length rlt)>0 = makeEqColumnsHelper (rlt++" and "++tb1++"."++fst++"="++tb2++"."++snd) tb1 rmd1 tb2 rmd2
+    | (elem ' ' col1)&&(elem ' ' col2) = makeEqColumnsHelper (tb1++"."++fst++"="++tb2++"."++snd) tb1 rmd1 tb2 rmd2
+    | (elem ' ' col1) = throw RelationshipConfigurationException
+    | (elem ' ' col2) = throw RelationshipConfigurationException
+    | (length rlt)>0 = rlt++" and "++tb1++"."++col1++"="++tb2++"."++col2
+    | otherwise = tb1++"."++col1++"="++tb2++"."++col2
+  where
+    (fst, rmd1) = getFirstColumn col1
+    (snd, rmd2) = getFirstColumn col2
+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
+
+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
+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
+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
+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

src/GraphQLdbi.hs view

@@ -1,386 +1,454 @@-{- |-Module      : GraphQLdbi-Description : Here are methods to interpret your GraphQL-SQL query and process the Persistent style results-License     : IPS-Maintainer  : jasonsychau@live.ca-Stability   : provisional--<https://graphql.github.io/ Here> is a link to the official documents. You can learn and get a feel of how can you implement this package which is a GraphQL-to-SQL translator with Persistent package style return-value processing to make a GraphQL format return object string.--This module is made to enable interpreting your GraphQL queries. The expected query type is a single string to comprise all your GraphQL queries and fragments. Expected variable type is a single string to your variable-to-value definitions.--When errors are encountered, this module is simply going to throw an uncaught Exception. The Exception name is some hint to where was the error encountered. More information is provided in the below function description.--Not all GraphQL features are currently supported. For a list to updates and current state, you should check the GitHub updates and example <https://github.com/jasonsychau/graphql-w-persistent page>.---}-module GraphQLdbi (-    -- * Functions-    -- | Here is two methods to the package interpretation, validation, and formatting features.-    -- | NOTE: It is is assumed that all nested objects are corresponding to a database table with a primary key that's named "id".-    module GraphQLdbi,-    -- * Server exceptions-    -- | These are server exceptions to make error handling.-    module Model.ServerExceptions-    ) where--import Data.Text (Text)-import Control.Monad.IO.Class (liftIO,MonadIO())-import Control.Exception (throw)-import Components.Parsers.QueryParser (validateQuery,parseStringToObjects,processString)-import Components.ObjectHandlers.ServerObjectValidator (checkObjectsAttributes,replaceObjectsVariables)-import Components.QueryComposers.SQLQueryComposer (makeSqlQueries)-import Components.Parsers.ServerSchemaJsonParser (fetchArguments)-import Components.ObjectHandlers.ServerObjectTrimmer (mergeDuplicatedRootObjects)-import Components.Parsers.VariablesParser (parseVariables)-import Components.DataProcessors.ListDataProcessor (processReturnedValues)-import Model.ServerExceptions-import Model.ServerObjectTypes (RootObject)--                                  -{- |-   This function is to parse, validate, and interpret your query with variables. If you don't have variables, you may pass an empty string.--   __Function return value:__--   The returned values are one tuple to contain information to pass into your database interface and to later reuse in below data processing function. -   The tuple is (PackagedObjects,SQLQueries). The second tuple member is a collection of queries. -   An example is given on this <https://github.com/jasonsychau/graphql-w-persistent page> to iterate the queries to your database.-   The example is also showing how is the first member passed to the data processing function.--   __Schema:__--   The schema json file is formated as one json object to describe the GraphQL objects and the object heirarchy.-   Only "PrimitiveObjects" are valid descendants to "ParentalObjects".-   Only the shared object fields and shared scalar fields are parental object fields.-   If a parental object is a declared field from a primitive object, all descendants are supposed to be declared in the primitive object database relationships.-   When declaring any primitive or parental object, the pseudonym is supposed to list all possible reference words to the object (in root object or nested object)-   Primitive objects are expected to have a unique "id" column in the declared database table.-   Database relationships are defined as an ordered sequence from the identity table to the target association table.-   The order is identity table, identity table join field(s), target table, target table join field(s), then (multiple) triplets (of intermediate table, intermediate table to-join field, then intermediate table from-join field in order of nearness from identity table) if relevant.-   If multiple fields are defining the join, one declares every field with a space " " separation.-   For example, the declaration is [A,"a b", B, "c d"] if the join condition is A.a=B.c and A.b = B.d.-   You can add schema associations as declaring more fields in the primitive objects.--   __Scalar fields:__--   Scalar fields are declared with a type, and they are cast to corresponding JSON format when making the GraphQL result.-   Valid scalar field types are Text, ByteString, Int, Double, Rational, Bool, Day, TimeOfDay, or UTCTime.--   __Function exceptions:__--   Exceptions are returned when error is faced. This method returns errors of:--    * SyntaxException (when there is a problem with the given GraphQL query syntax)-    * ParseFragmentException (when there is a problem with a Fragment syntax)-    * EmptyQueryException (when the query is left blank)-    * InvalidObjectException (when there is problem in nested object syntax, an object is not recognized, or server data is misinterpreted)-    * InvalidObjectSubFieldException (when a subfield is requested from nested object that is not having ownership of the subfield)-    * InvalidScalarException (when there is syntax error in listing scalar fields, or server data is misinterpreted)-    * NullArgumentException (when a transformation is set but no argument is given though we do not yet support transformations) -    * CreatingSqlQueryObjectFieldsException (when there are too many nested object subfields than nested objects to hold them or when there is a problem with the aligning of server object relationship argument - that's the fifth schema argument)-    * RelationshipConfigurationException (when the relationship schema fifth arugment is incorrect number of String values, when an unrecognized pairing is found, or when two table field cardinalities are not same)-    * FailedObjectEqualityException (when we could not match identical queries)-    * DuplicateRootObjectsException (when there is an overlapping query)- -    * ImportSchemaException (when there is a problem with reading your schema)-    * ImportSchemaServerNameException (when there is a problem with reading your servername argument)-    * ImportSchemaPseudonymsException (when there is a problem with reading your pseudonyms list argument)-    * ImportSchemaScalarFieldsException (when there is a problem with reading your scalarfields list argument)-    * ImportSchemaObjectFieldsException (when there is a problem with reading your objectfields list argument)-    * ImportSchemaDatabaseTablesException (when there is a problem with reading your databasetables list argument)-    * ImportSchemaDatabaseRelationshipsException (when there is a problem with reading your databaserelationships list argument)- -    * MissingVariableValueException (when we are missing variables in the variables-value string to the query)-    * InvalidVariableNameException (when we cannot find a variable in the query with given variables-value string)-    * MismatchedVariableTypeException (when query variable type is not matching object scalar type)-    * InvalidVariableTypeException (when variable type is invalid or missing)-    * ReadVariablesException (when the variables json string syntax is incorrect or was not correctly read)-    * VariablesSyntaxException (when the query variables declaration is invalid syntax)--   __Schema format example:__--   Here is an example schema to look at formatting:-   @-    {-      "ParentalObjects":[-        {-          "ServerName":"Taxonomy",-          "Pseudonyms":[-            "taxonomy",-            "Taxonomy"-          ],-          "ServerChildren":[-            "Breed",-            "Species",-            "Family",-            "Genus"-          ]-        }-      ],-      "PrimitiveObjects":[-        {-          "ServerName": "Person",-          "Pseudonyms": [-            "person",-            "Person",-            "owner"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            },-            {-              "Name": "gender",-              "Type": "Int"-            }-          ],-          "ObjectFields": [-            "pet",-            "breed",-            "species",-            "genus",-            "family",-            "taxonomy"-          ],-          "DatabaseTable": "person",-          "DatabaseRelationships": [-            ["person","id","pet","id","pet_ownership","owner_id","animal_id"],-            ["person","id","breed","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id"],-            ["person","id","species","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id"],-            ["person","id","genus","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id"],-            ["person","id","family","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id","genus","id","family_id"]-          ]-        },-        {-          "ServerName": "Family",-          "Pseudonyms": [-            "Family",-            "family"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            }-          ],-          "ObjectFields": [-            "genus",-            "species",-            "breed",-            "pet",-            "person"-          ],-          "DatabaseTable": "family",-          "DatabaseRelationships": [-            ["family","id","person","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],-            ["family","id","pet","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"],-            ["family","id","genus","family_id"],-            ["family","id","species","genus_id","genus","family_id","id"],-            ["family","id","breed","species_id","genus","family_id","id","species","genus_id","id"]-          ]-        },-        {-          "ServerName": "Genus",-          "Pseudonyms": [-            "Genus",-            "genus"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            }-          ],-          "ObjectFields": [-            "family",-            "species",-            "breed",-            "pet",-            "person"-          ],-          "DatabaseTable": "genus",-          "DatabaseRelationships": [-            ["genus","id","person","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],-            ["genus","id","pet","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"],-            ["genus","family_id","family","id"],-            ["genus","id","species","genus_id"],-            ["genus","id","breed","species_id","species","genus_id","id"]-          ]-        },-        {-          "ServerName": "Species",-          "Pseudonyms": [-            "Species",-            "species"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            }-          ],-          "ObjectFields": [-            "family",-            "genus",-            "breed",-            "pet",-            "person"-          ],-          "DatabaseTable": "species",-          "DatabaseRelationships": [-            ["species","id","person","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],-            ["species","id","pet","id","breed","species_id","id","pet_type","breed_id","pet_id"],-            ["species","id","breed","species_id"],-            ["species","genus_id","genus","id"],-            ["species","id","family","genus_id","genus","species_id","id"]-          ]-        },-        {-          "ServerName": "Breed",-          "Pseudonyms": [-            "Breed",-            "breed"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            }-          ],-          "ObjectFields": [-            "family",-            "genus",-            "species",-            "pet",-            "person"-          ],-          "DatabaseTable": "breed",-          "DatabaseRelationships": [-            ["breed","id","person","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],-            ["breed","id","pet","id","pet_type","breed_id","pet_id"],-            ["breed","species_id","species","id"],-            ["breed","species_id","genus","id","species","id","genus_id"],-            ["breed","species_id","family","id","species","id","genus_id","genus","id","family_id"]-          ]-        },-        {-          "ServerName": "Pet",-          "Pseudonyms": [-            "pet",-            "Pet"-          ],-          "ScalarFields": [-            {-              "Name": "id",-              "Type": "Int"-            },-            {-              "Name": "name",-              "Type": "Text"-            },-            {-              "Name": "gender",-              "Type": "Int"-            }-          ],-          "ObjectFields": [-            "owner",-            "breed",-            "species",-            "genus",-            "family",-            "taxonomy"-          ],-          "DatabaseTable": "pet",-          "DatabaseRelationships": [-            ["pet","id","person","id","pet_ownership","animal_id","owner_id"],-            ["pet","id","breed","id","pet_type","pet_id","breed_id"],-            ["pet","id","species","id","pet_type","pet_id","breed_id","breed","id","species_id"],-            ["pet","id","genus","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id"],-            ["pet","id","family","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id","genus","id","family_id"]-          ]-        }-      ]-    }-   @--   __Formatting notes:__--   Nulls are expected as "Unexpected null". This is important when processing ids to separate different results. One can translate nulls to "Unexpected null" when making Text types of query results.--   __Closing remark:__--   As the last remark, I'll turn attention to a quote from specifications.--   @"In contrast, GraphQL only returns the data that's explicitly requested, so new capabilities can be added via new types and new fields on those types without creating a breaking change. This has lead to a common practice of always avoiding breaking changes and serving a versionless API."@ - <https://graphql.github.io/learn/best-practices/>-  -   With respect to that, you should be sure to be explicit with your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server to make graph-like associations.   --}-processQueryString :: (MonadIO m)-                   => FilePath                                  -- ^ This is the path to schema json file-                   -> String                                    -- ^ This is the GraphQL query-                   -> String                                    -- ^ This is the variables string-                   -> m ([(RootObject,[[String]])],[[String]])  -- ^ The return value is a monad of one tuple with package objects and list with grouped sql query strings.-processQueryString fp qry vars = do-                                  (svrobjs,sss,sos,sodn,sor,soa) <- liftIO $ fetchArguments fp-                                  let dvars = parseVariables vars qry-                                  let str = processString qry-                                  let objs = if (validateQuery str)==True then (parseStringToObjects str svrobjs soa dvars) else throw SyntaxException-                                  let robjs = mergeDuplicatedRootObjects $ replaceObjectsVariables sss objs dvars-                                  let (tbls,qrys) = if (checkObjectsAttributes robjs sss sos soa)==True then (makeSqlQueries robjs sodn sor soa) else (throw InvalidObjectSubFieldException)-                                  return (zip robjs tbls,qrys)-{- |-    After casting all database results to Text (example is given in <https://github.com/jasonsychau/graphql-w-persistent examples> page), you may use this function to process data to GraphQL format.--    The second argument is the package objects given from function processQueryString.-    -    The return result is a string to resemble the GraphQL return value.--    These are the exceptions returned from this function:--     * InvalidObjectException (when server data is misinterpreted or an unrecognized server object is met)-     * InvalidScalarException (when server data is misinterpreted)-     * EOFDataProcessingException (when the given data is shorter than expected in reference to the given serve objects)-     * InvalidArgumentException (when there is an internal argument error - you should not observe this)-     * InvalidVariableTypeException (when an unrecognized base data type is met)-     * InvalidObjectScalarFieldException (when an unrecognized object-scalar pair is met)--     * ImportSchemaException (when there is a problem with reading your schema)-     * ImportSchemaServerNameException (when there is a problem with reading your servername argument)-     * ImportSchemaPseudonymsException (when there is a problem with reading your pseudonyms list argument)-     * ImportSchemaScalarFieldsException (when there is a problem with reading your scalarfields list argument)-     * ImportSchemaObjectFieldsException (when there is a problem with reading your objectfields list argument)-     * ImportSchemaDatabaseTablesException (when there is a problem with reading your databasetables list argument)-     * ImportSchemaDatabaseRelationshipsException (when there is a problem with reading your databaserelationships list argument)--}-processQueryData :: (MonadIO m)-                 => FilePath                   -- ^ This is the path to schema json file-                 -> [(RootObject,[[String]])]  -- ^ 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.-                 -> m String                   -- ^ The return value is a monad of string type to describe the GraphQL-organized return values.-processQueryData fp cc dt = do-                              (_,sss,_,sodn,_,soa) <- liftIO $ fetchArguments fp-                              let (ro,tb) = unzip cc-                              return $ processReturnedValues sss sodn soa ro tb dt+{- |
+Module      : GraphQLdbi
+Description : Here are methods to interpret your GraphQL-SQL query and process the Persistent style results
+License     : IPS
+Maintainer  : jasonsychau@live.ca
+Stability   : provisional
+
+<https://graphql.github.io/ Here> is a link to the official documents. You can learn and get a feel of how can you implement this package which is a GraphQL-to-SQL translator with Persistent package style return-value processing to make a GraphQL format return object string.
+
+This module is made to enable interpreting your GraphQL queries. The expected query type is a single string to comprise all your GraphQL queries and fragments. Expected variable type is a single string to your variable-to-value definitions.
+
+When errors are encountered, this module is simply going to throw an uncaught Exception. The Exception name is some hint to where was the error encountered. More information is provided in the below function description.
+
+Not all GraphQL features are currently supported. For a list to updates and current state, you should check the GitHub updates and example <https://github.com/jasonsychau/graphql-w-persistent page>.
+
+-}
+module GraphQLdbi (
+    -- * Functions
+    -- | Here is three methods to the package interpretation, validation, and formatting features.
+    module GraphQLdbi,
+    -- * Server exceptions
+    -- | These are server exceptions to make error handling.
+    module Model.ServerExceptions
+    ) where
+
+import Data.Text (Text)
+import Control.Monad.IO.Class (liftIO,MonadIO())
+import Control.Exception (throw)
+import Components.Parsers.QueryParser (validateQuery,parseStringToObjects,processString)
+import Components.ObjectHandlers.ServerObjectValidator (checkObjectsAttributes,replaceObjectsVariables)
+import Components.QueryComposers.SQLQueryComposer (makeSqlQueries)
+import Components.Parsers.ServerSchemaJsonParser (fetchArguments)
+import Components.ObjectHandlers.ServerObjectTrimmer (mergeDuplicatedRootObjects)
+import Components.Parsers.VariablesParser (parseVariables)
+import Components.DataProcessors.ListDataProcessor (processReturnedValues)
+import Model.ServerExceptions
+import Model.ServerObjectTypes (RootObject,SchemaSpecs,QueryData)
+
+
+{- |
+   This function is to parse your schema. The return values are passed to the other two functions to interpret your schema. You can define your schema with tuples and lists without reading a json file as defined in below function, but you will not receive type and duplicate checking from this function.
+
+   __Schema:__
+
+   The schema json file is formated as one json object to describe the GraphQL objects and the object heirarchy.
+   Only "PrimitiveObjects" are valid descendants to "ParentalObjects".
+   Only the shared object fields and shared scalar fields are parental object fields.
+   If a parental object is a declared field from a primitive object, all descendants are supposed to be declared in the primitive object database relationships.
+   When declaring any primitive or parental object, the pseudonym is supposed to list all possible reference words to the object (in root object or nested object)
+   Primitive objects are expected to have a unique "id" column in the declared database table.
+   Database relationships are defined as an ordered sequence from the identity table to the target association table.
+   The order is identity table, identity table join field(s), target table, target table join field(s), then (multiple) triplets (of intermediate table, intermediate table to-join field, then intermediate table from-join field in order of nearness from identity table) if relevant.
+   If multiple fields are defining the join, one declares every field with a space " " separation.
+   For example, the declaration is [A,"a b", B, "c d"] if the join condition is A.a=B.c and A.b = B.d.
+   You can add schema associations as declaring more fields in the primitive objects.
+
+   __Scalar fields:__
+
+   Scalar fields are declared with a type, and they are cast to corresponding JSON format when making the GraphQL result.
+   Valid scalar field types are Text, ByteString, Int, Double, Rational, Bool, Day, TimeOfDay, or UTCTime.
+
+   __Function exceptions:__
+
+   Exceptions are returned when error is faced. This method returns errors of:
+
+    * ImportSchemaException (when there is a problem with reading your schema)
+    * ImportSchemaServerNameException (when there is a problem with reading your servername argument)
+    * ImportSchemaPseudonymsException (when there is a problem with reading your pseudonyms list argument)
+    * ImportSchemaScalarFieldsException (when there is a problem with reading your scalarfields list argument)
+    * ImportSchemaObjectFieldsException (when there is a problem with reading your objectfields list argument)
+    * ImportSchemaDatabaseTablesException (when there is a problem with reading your databasetables list argument)
+    * ImportSchemaDatabaseRelationshipsException (when there is a problem with reading your databaserelationships list argument)
+    * ImportSchemaDuplicateException (when two or more Server objects are sharing the same name)
+
+   __Important note:__
+   
+   It is assumed that all nested objects are corresponding to a database table with a primary key that's named "id".
+
+   __Schema format example:__
+
+   Here is an example schema to look at formatting:
+
+   @
+    {
+      "ParentalObjects":[
+        {
+          "ServerName":"Taxonomy",
+          "Pseudonyms":[
+            "taxonomy",
+            "Taxonomy"
+          ],
+          "ServerChildren":[
+            "Breed",
+            "Species",
+            "Family",
+            "Genus"
+          ]
+        }
+      ],
+      "PrimitiveObjects":[
+        {
+          "ServerName": "Person",
+          "Pseudonyms": [
+            "person",
+            "Person",
+            "owner"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            },
+            {
+              "Name": "gender",
+              "Type": "Int",
+              "Arguments": [
+                {
+                  "Name": "as",
+                  "Options": [
+                    {
+                      "Name": "MALEFEMALE",
+                      "Type": "Text",
+                      "Prefix": "CASE WHEN ",
+                      "Suffix": "==1 THEN 'MALE' ELSE 'FEMALE' END"
+                    }
+                  ]
+                }
+              ]
+            }
+          ],
+          "ObjectFields": [
+            "pet",
+            "breed",
+            "species",
+            "genus",
+            "family",
+            "taxonomy"
+          ],
+          "DatabaseTable": "person",
+          "DatabaseRelationships": [
+            ["person","id","pet","id","pet_ownership","owner_id","animal_id"],
+            ["person","id","breed","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id"],
+            ["person","id","species","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id"],
+            ["person","id","genus","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id"],
+            ["person","id","family","id","pet_ownership","owner_id","animal_id","pet","id","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id","genus","id","family_id"]
+          ]
+        },
+        {
+          "ServerName": "Family",
+          "Pseudonyms": [
+            "Family",
+            "family"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            }
+          ],
+          "ObjectFields": [
+            "genus",
+            "species",
+            "breed",
+            "pet",
+            "person"
+          ],
+          "DatabaseTable": "family",
+          "DatabaseRelationships": [
+            ["family","id","person","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],
+            ["family","id","pet","id","genus","family_id","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"],
+            ["family","id","genus","family_id"],
+            ["family","id","species","genus_id","genus","family_id","id"],
+            ["family","id","breed","species_id","genus","family_id","id","species","genus_id","id"]
+          ]
+        },
+        {
+          "ServerName": "Genus",
+          "Pseudonyms": [
+            "Genus",
+            "genus"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            }
+          ],
+          "ObjectFields": [
+            "family",
+            "species",
+            "breed",
+            "pet",
+            "person"
+          ],
+          "DatabaseTable": "genus",
+          "DatabaseRelationships": [
+            ["genus","id","person","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],
+            ["genus","id","pet","id","species","genus_id","id","breed","species_id","id","pet_type","breed_id","pet_id"],
+            ["genus","family_id","family","id"],
+            ["genus","id","species","genus_id"],
+            ["genus","id","breed","species_id","species","genus_id","id"]
+          ]
+        },
+        {
+          "ServerName": "Species",
+          "Pseudonyms": [
+            "Species",
+            "species"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            }
+          ],
+          "ObjectFields": [
+            "family",
+            "genus",
+            "breed",
+            "pet",
+            "person"
+          ],
+          "DatabaseTable": "species",
+          "DatabaseRelationships": [
+            ["species","id","person","id","breed","species_id","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],
+            ["species","id","pet","id","breed","species_id","id","pet_type","breed_id","pet_id"],
+            ["species","id","breed","species_id"],
+            ["species","genus_id","genus","id"],
+            ["species","id","family","genus_id","genus","species_id","id"]
+          ]
+        },
+        {
+          "ServerName": "Breed",
+          "Pseudonyms": [
+            "Breed",
+            "breed"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            }
+          ],
+          "ObjectFields": [
+            "family",
+            "genus",
+            "species",
+            "pet",
+            "person"
+          ],
+          "DatabaseTable": "breed",
+          "DatabaseRelationships": [
+            ["breed","id","person","id","pet_type","breed_id","pet_id","pet_ownership","animal_id","owner_id"],
+            ["breed","id","pet","id","pet_type","breed_id","pet_id"],
+            ["breed","species_id","species","id"],
+            ["breed","species_id","genus","id","species","id","genus_id"],
+            ["breed","species_id","family","id","species","id","genus_id","genus","id","family_id"]
+          ]
+        },
+        {
+          "ServerName": "Pet",
+          "Pseudonyms": [
+            "pet",
+            "Pet"
+          ],
+          "ScalarFields": [
+            {
+              "Name": "id",
+              "Type": "Int",
+              "Arguments": []
+            },
+            {
+              "Name": "name",
+              "Type": "Text",
+              "Arguments": []
+            },
+            {
+              "Name": "gender",
+              "Type": "Int",
+              "Arguments": [
+                {
+                  "Name": "as",
+                  "Options": [
+                    {
+                      "Name": "MALEFEMALE",
+                      "Type": "Text",
+                      "Prefix": "CASE WHEN ",
+                      "Suffix": "==1 THEN 'MALE' ELSE 'FEMALE' END"
+                    }
+                  ]
+                }
+              ]
+            }
+          ],
+          "ObjectFields": [
+            "owner",
+            "breed",
+            "species",
+            "genus",
+            "family",
+            "taxonomy"
+          ],
+          "DatabaseTable": "pet",
+          "DatabaseRelationships": [
+            ["pet","id","person","id","pet_ownership","animal_id","owner_id"],
+            ["pet","id","breed","id","pet_type","pet_id","breed_id"],
+            ["pet","id","species","id","pet_type","pet_id","breed_id","breed","id","species_id"],
+            ["pet","id","genus","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id"],
+            ["pet","id","family","id","pet_type","pet_id","breed_id","breed","id","species_id","species","id","genus_id","genus","id","family_id"]
+          ]
+        }
+      ]
+    }
+   @
+
+   __Schema recommendation:__
+
+   If you add every possible chain from every PrimitiveObject to every other PrimitiveObject, you can extend the schema coverage and query capacities.
+
+   __Closing remark:__
+
+   As the last remark, I'll turn attention to a quote from specifications.
+
+   @"In contrast, GraphQL only returns the data that's explicitly requested, so new capabilities can be added via new types and new fields on those types without creating a breaking change. This has lead to a common practice of always avoiding breaking changes and serving a versionless API."@ - <https://graphql.github.io/learn/best-practices/>
+  
+   With respect to that, you should be sure to be explicit with your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server to make graph-like associations.   
+-}
+processSchema :: (MonadIO m)
+              => FilePath       -- ^ This is the path to schema json file
+              -> m SchemaSpecs  -- ^ The return value is a monad for your schema data.
+processSchema fp = do
+          schema <- liftIO $ fetchArguments fp
+          return schema
+{- |
+  This function is to parse, validate, and interpret your query with variables. If you don't have variables, you may pass an empty string. The function is expecting your schema as SchemaSpec type from the above function. You can alternatively define you schema with lists and tuples. The order is
+
+  @
+  ([(ServerObjectName,[ServerObjectPseudonyms])],[(ServerObjectName,[(ScalarName,ScalarType)])],[(ServerObjectName,[NestedObjectNames])],[(ServerObjectName,ServerObjectDatabaseTableName)],[(StartingDatabaseTableName,EndingDatabaseTableName,[PathBetweenDatabaseTables])],[(ParentServerObjectName,[ParentPseudonyms],[ServerObjectDescendants])])
+  @
+
+  You also can use the above function to print your schema data and paste it into your script file.
+
+  __Function return value:__
+
+  The returned values are one tuple to contain information to pass into your database interface and to later reuse in below data processing function. 
+  The tuple is (PackagedObjects,SQLQueries). The second tuple member is a collection of queries. 
+  An example is given on this <https://github.com/jasonsychau/graphql-w-persistent page> to iterate the queries to your database.
+  The example is also showing how is the first member passed to the data processing function.
+
+  __Function exceptions:__
+
+  Exceptions are returned when error is faced. This method returns errors of:
+
+  * SyntaxException (when there is a problem with the given GraphQL query syntax)
+  * ParseFragmentException (when there is a problem with a Fragment syntax)
+  * EmptyQueryException (when the query is left blank)
+  * InvalidObjectException (when there is problem in nested object syntax, an object is not recognized, or server data is misinterpreted)
+  * InvalidObjectSubFieldException (when a subfield is requested from nested object that is not having ownership of the subfield)
+  * InvalidScalarException (when there is syntax error in listing scalar fields, or server data is misinterpreted)
+  * NullArgumentException (when a transformation is set but no argument is given though we do not yet support transformations) 
+  * CreatingSqlQueryObjectFieldsException (when there are too many nested object subfields than nested objects to hold them or when there is a problem with the aligning of server object relationship argument - that's the fifth schema argument)
+  * RelationshipConfigurationException (when the relationship schema fifth arugment is incorrect number of String values, when an unrecognized pairing is found, or when two table field cardinalities are not same)
+  * FailedObjectEqualityException (when we could not match identical queries)
+  * DuplicateRootObjectsException (when there is an overlapping query)
+
+  * MissingVariableValueException (when we are missing variables in the variables-value string to the query)
+  * InvalidVariableNameException (when we cannot find a variable in the query with given variables-value string)
+  * MismatchedVariableTypeException (when query variable type is not matching object scalar type)
+  * InvalidVariableTypeException (when variable type is invalid or missing)
+  * ReadVariablesException (when the variables json string syntax is incorrect or was not correctly read)
+  * VariablesSyntaxException (when the query variables declaration is invalid syntax)
+
+  __Schema format example:__
+
+  You should refer to the above function details for information on schema format and details.
+
+  __Closing remark:__
+
+  As the last remark, I'll turn attention to a quote from specifications.
+
+  @"In contrast, GraphQL only returns the data that's explicitly requested, so new capabilities can be added via new types and new fields on those types without creating a breaking change. This has lead to a common practice of always avoiding breaking changes and serving a versionless API."@ - <https://graphql.github.io/learn/best-practices/>
+
+  With respect to that, you should be sure to be explicit with your schema representation. You should give all planned details, and you should make adjustments when you feel to evolve your server to make graph-like associations.   
+-}
+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.
+processQueryString (svrobjs,sss,sos,sodn,sor,soa) qry vars =
+          let dvars = parseVariables vars qry
+              str = processString qry
+              objs = if (validateQuery str)==True then (parseStringToObjects str svrobjs soa dvars) else throw SyntaxException
+              robjs = mergeDuplicatedRootObjects $ replaceObjectsVariables sss soa objs dvars
+              (tbls,qrys) = if (checkObjectsAttributes robjs sss sos soa)==True then (makeSqlQueries robjs sss sodn sor soa) else (throw InvalidObjectSubfieldException)
+          in (zip robjs tbls,qrys)
+{- |
+  After casting all database results to Text (example is given in <https://github.com/jasonsychau/graphql-w-persistent examples> page), you may use this function to process data to GraphQL format.
+
+  The second argument is the package objects given from function processQueryString.
+  
+  The return result is a string to resemble the GraphQL return value.
+
+  __Formatting notes (IMPORTANT):__
+
+  Nulls are expected as "Unexpected null". This is the Persistent default and important when processing ids to separate different results. One can translate nulls to "Unexpected null" when making Text types of query results.
+
+  __Function exceptions:__
+
+  Exceptions are returned when error is faced. This method returns errors of:
+
+  * InvalidObjectException (when server data is misinterpreted or an unrecognized server object is met)
+  * InvalidScalarException (when server data is misinterpreted)
+  * EOFDataProcessingException (when the given data is shorter than expected in reference to the given serve objects)
+  * InvalidArgumentException (when there is an internal argument error - you should not observe this)
+  * InvalidVariableTypeException (when an unrecognized base data type is met)
+  * InvalidObjectScalarFieldException (when an unrecognized object-scalar pair is met)
+-}
+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.
+                 -> 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
+          in processReturnedValues sss sodn soa ro tb dt

src/Model/ServerExceptions.hs view

@@ -1,44 +1,44 @@-{- |-Module      : Model.ServerExceptions-Description : Here are exceptions for debugging.-License     : IPS-Maintainer  : jasonsychau@live.ca-Stability   : provisional--}-module Model.ServerExceptions where--import Control.Exception---data QueryException = SyntaxException |-                      ParseFragmentException |-                      EmptyQueryException | -                      InvalidObjectException | -                      InvalidScalarException |-                      InvalidObjectScalarFieldException | -                      InvalidObjectSubFieldException |-                      NullArgumentException |-                      CreatingSqlQueryObjectFieldsException |-                      CreatingSqlQueryObjectsException |-                      EOFDataProcessingException |-                      RelationshipConfigurationException |-                      FailedObjectEqualityException |-                      DuplicateRootObjectsException |-                      ImportSchemaException |-                      ImportSchemaServerNameException |-                      ImportSchemaPseudonymsException |-                      ImportSchemaScalarFieldsException |-                      ImportSchemaObjectFieldsException |-                      ImportSchemaDatabaseTablesException |-                      ImportSchemaDatabaseRelationshipsException |-                      ImportSchemaChildrenException |-                      MissingVariableValueException |-                      InvalidVariableNameException |-                      MismatchedVariableTypeException |-                      InvalidVariableTypeException |-                      ReadVariablesException |-                      VariablesSyntaxException |-                      InvalidArgumentException-  deriving Show-+{- |
+Module      : Model.ServerExceptions
+Description : Here are exceptions for debugging.
+License     : IPS
+Maintainer  : jasonsychau@live.ca
+Stability   : provisional
+-}
+module Model.ServerExceptions where
+
+import Control.Exception
+
+
+data QueryException = SyntaxException |
+                      ParseFragmentException |
+                      EmptyQueryException | 
+                      InvalidObjectException | 
+                      InvalidScalarException |
+                      NullArgumentException |
+                      CreatingSqlQueryObjectFieldsException |
+                      CreatingSqlQueryObjectsException |
+                      EOFDataProcessingException |
+                      RelationshipConfigurationException |
+                      FailedObjectEqualityException |
+                      DuplicateRootObjectsException |
+                      ImportSchemaException |
+                      ImportSchemaServerNameException |
+                      ImportSchemaPseudonymsException |
+                      ImportSchemaScalarFieldsException |
+                      ImportSchemaObjectFieldsException |
+                      ImportSchemaDatabaseTablesException |
+                      ImportSchemaDatabaseRelationshipsException |
+                      ImportSchemaChildrenException |
+                      ImportSchemaDuplicateException |
+                      MissingVariableValueException |
+                      InvalidVariableNameException |
+                      MismatchedVariableTypeException |
+                      InvalidVariableTypeException |
+                      ReadVariablesException |
+                      VariablesSyntaxException |
+                      InvalidArgumentException |
+                      InvalidObjectSubfieldException
+  deriving Show
+
 instance Exception QueryException

src/Model/ServerObjectTypes.hs view

@@ -1,33 +1,41 @@-{- |-Module      : Model.ServerObjectTypes-Description : Here is the data types for the server objects.-License     : IPS-Maintainer  : jasonsychau@live.ca-Stability   : provisional--}-module Model.ServerObjectTypes where----- | These are objects to represent GraphQL query roots.-type RootObjects = [RootObject]-type RootObject = NestedObject---- | NestedObjects are the general object type. They are found as RootObjects or as object Subfields.-data NestedObject = NestedObject Alias Name ServerObject SubSelection SubFields-                    deriving Show-type Alias = Maybe String-type ServerObject = String-type SubSelection = Maybe ScalarType-type SubFields = [Field]-type Field = Either ScalarType FieldObject-type FieldObject = Either NestedObject InlinefragmentObject-data InlinefragmentObject = InlinefragmentObject ServerObject SubFields-                    deriving Show---- | ScalarTypes are the other subfield type. They are also found at object attributes.-data ScalarType = ScalarType Alias Name Transformation Argument-               deriving (Show,Eq)-type Transformation = Maybe String-type Argument = Maybe String--type Name = String+{- |
+Module      : Model.ServerObjectTypes
+Description : Here is the data types for the server objects.
+License     : IPS
+Maintainer  : jasonsychau@live.ca
+Stability   : provisional
+-}
+module Model.ServerObjectTypes where
+
+
+-- | These are objects to represent GraphQL query roots.
+type RootObjects = [RootObject]
+type RootObject = NestedObject
+
+-- | NestedObjects are the general object type. They are found as RootObjects or as object Subfields.
+data NestedObject = NestedObject !Alias !Name !ServerObject !SubSelection !SubFields
+type Alias = Maybe String
+type ServerObject = String
+type SubSelection = Maybe ScalarType
+type SubFields = [Field]
+type Field = Either ScalarType FieldObject
+type FieldObject = Either NestedObject InlinefragmentObject
+data InlinefragmentObject = InlinefragmentObject !ServerObject !SubFields
+
+-- | ScalarTypes are the other subfield type. They are also found at object attributes.
+data ScalarType = ScalarType !Alias !Name !Transformation !Argument
+                deriving Eq
+type Transformation = Maybe String
+type Argument = Maybe String
+
+type Name = String
+
+data Fragment = Fragment
+    { name :: String
+    , targetObject :: ServerObject
+    , replacement :: String
+    }
+
+type SchemaSpecs = ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
+
+type QueryData = [(RootObject,[[String]])]