graphql-w-persistent (empty) → 0.1.0.0
raw patch · 13 files changed
+818/−0 lines, 13 filesdep +basedep +containersdep +jsonsetup-changed
Dependencies added: base, containers, json, text
Files
- ChangeLog.md +5/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- graphql-w-persistent.cabal +88/−0
- src/Components/DataProcessors/PersistentDataProcessor.hs +62/−0
- src/Components/ObjectHandlers/ObjectsHandler.hs +64/−0
- src/Components/ObjectHandlers/ServerObjectValidator.hs +29/−0
- src/Components/Parsers/QueryParser.hs +357/−0
- src/Components/QueryComposers/SQLQueryComposer.hs +57/−0
- src/GraphQL.hs +64/−0
- src/GraphQLHelper.hs +14/−0
- src/Model/ServerExceptions.hs +33/−0
- src/Model/ServerObjectTypes.hs +30/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for graphql-w-yesod + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ graphql-w-persistent.cabal view
@@ -0,0 +1,88 @@+-- 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.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Haskell GraphQL query parser-interpreter-data processor. + +-- A longer description of the package. +description: This is a general purpose Haskell GraphQL query parser and interpreter. It is including data processing to return GraphQL object formats. The query parser and interpreter are universal (on available query types). It is accepting any string query, and it is returning a list of string database-queries. The data processing unit is designed around the return values from the Yesod and Persistent interface (cast as Text data values from PersistValue). With another server that is same data representation on the returned values from the database, this entire package is applicable. + +-- 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 + +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: GraphQL + + -- Modules included in this library but not exported. + other-modules: Components.DataProcessors.PersistentDataProcessor, + Components.ObjectHandlers.ObjectsHandler, + Components.ObjectHandlers.ServerObjectValidator, + Components.Parsers.QueryParser, + Components.QueryComposers.SQLQueryComposer, + Model.ServerObjectTypes, + Model.ServerExceptions, + GraphQLHelper + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.11 && <4.12, + containers >=0.5.11 && <0.6, + json >=0.9.2 && <0.10, + text >=1.2.3.0 && <1.3 + + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 +
+ src/Components/DataProcessors/PersistentDataProcessor.hs view
@@ -0,0 +1,62 @@+module Components.DataProcessors.PersistentDataProcessor where + +import Data.Maybe +import Data.Either +import Data.Text (Text) +import Text.JSON (encodeStrict,toJSObject,JSValue,showJSONs,toJSObject,showJSON) +import qualified Control.Exception as E +import Model.ServerExceptions +import Model.ServerObjectTypes +import Components.ObjectHandlers.ObjectsHandler (getSubFields) + + +-- with root objects we want one json representation of separate graphql results... +processReturnedValues :: [RootObject] -> [[[[Text]]]] -> String +processReturnedValues robjs rlts = encodeStrict $ toJSObject [("data", toJSObject [processReturnedValue x y | x<-robjs, y<-groupSingleQueryResults rlts])] +-- with separated sql query results, we want a list of data rows that are separated by only graphql query... +groupSingleQueryResults :: [[[[Text]]]] -> [[[Text]]] +groupSingleQueryResults rlts = [foldr (\y z -> y++z) [] x | x<-rlts] +-- with qraphql query object and sql return data, we want json representation on graphql query results... +processReturnedValue :: RootObject -> [[Text]] -> (String, JSValue) +processReturnedValue (NestedObject alias name _ _ sfs) rlts = (if (alias==Nothing) then name else (fromJust alias), showJSONs $ processSubFields sfs rlts) +-- with SubFields and data rows, we want json representation on qraphql query data +processSubFields :: [Field] -> [[Text]] -> [JSValue] +processSubFields _ [] = [] +processSubFields sfs rlts = ((showJSON $ toJSObject $ composeGraphQlRow sfs $ fetchGraphQlRow rlts):(processSubFields sfs $ removeDataRow rlts)) +composeGraphQlRow :: [Field] -> [[Text]] -> [(String,JSValue)] +composeGraphQlRow [] [[]] = [] -- done +composeGraphQlRow [] _ = E.throw EOFDataProcessingException +composeGraphQlRow _ [[]] = E.throw EOFDataProcessingException +composeGraphQlRow (a:b) ((h:t):j) + | (isLeft a)==True = (((getScalarFieldLabel $ fromLeft (E.throw InvalidScalarException) a), (showJSON h)):(composeGraphQlRow b (removeNDataColumns 1 ((h:t):j)))) + | otherwise = (((getNestedObjectFieldLabel $ fromRight (E.throw InvalidObjectException) a), showJSONs (processSubFields (getSubFields $ fromRight (E.throw InvalidObjectException) a) (pullNDataColumns nestedObjectFieldCount ((h:t):j)))):(composeGraphQlRow b (removeNDataColumns nestedObjectFieldCount ((h:t):j)))) + where + nestedObjectFieldCount = (countNestedObjectQueriedFields $ fromRight (E.throw InvalidObjectException) a) +fetchGraphQlRow :: [[Text]] -> [[Text]] +fetchGraphQlRow rlts = [t | (h:t)<-rlts, (h)==(head $ head rlts)] +removeDataRow :: [[Text]] -> [[Text]] +removeDataRow rlts = [x | x<-rlts, (head x)/=(head $ head rlts)] +getScalarFieldLabel :: ScalarType -> String +getScalarFieldLabel (ScalarType alias name trans arg) = if (alias/=Nothing) then (fromJust alias) else name +getNestedObjectFieldLabel :: NestedObject -> String +getNestedObjectFieldLabel (NestedObject alias name sobj ss sfs) = if (alias/=Nothing) then (fromJust alias) else name +pullNDataColumns :: Int -> [[Text]] -> [[Text]] +pullNDataColumns _ [] = [] +pullNDataColumns cnt rslt + | (cnt<0) = E.throw InvalidArgumentException + | otherwise = [if (length x)<cnt then (E.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 +countNestedObjectQueriedFields :: NestedObject -> Int +countNestedObjectQueriedFields (NestedObject alias name sobj ss sfs) = 1+(countNestedObjectQueriedSubFields sfs) +countNestedObjectQueriedSubFields :: [Field] -> Int +countNestedObjectQueriedSubFields [] = 0 +countNestedObjectQueriedSubFields (h:t) + | (isLeft h)==True = 1+(countNestedObjectQueriedSubFields t) + | otherwise = (countNestedObjectQueriedFields (fromRight (E.throw InvalidObjectException) h))+(countNestedObjectQueriedSubFields t) +-- remove nested object columns from data row that is including nested object id +removeNDataColumns :: Int -> [[Text]] -> [[Text]] +removeNDataColumns 0 rslt = rslt +removeNDataColumns (-1) _ = E.throw EOFDataProcessingException +removeNDataColumns _ [[]] = [[]] +removeNDataColumns _ ([]:t) = E.throw EOFDataProcessingException +removeNDataColumns cnt rslt = removeNDataColumns (cnt-1) [t | (h:t)<-rslt]
+ src/Components/ObjectHandlers/ObjectsHandler.hs view
@@ -0,0 +1,64 @@+module Components.ObjectHandlers.ObjectsHandler where + +import Data.Maybe +import qualified Control.Exception as E +import Model.ServerExceptions +import Model.ServerObjectTypes + + +readServerObject :: String -> [(String,[String])] -> ServerObject +readServerObject str [] = E.throw InvalidObjectException +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])] -> Bool +isValidServerObjectScalarField _ _ [] = E.throw InvalidObjectException +isValidServerObjectScalarField sobj name ((a,b):t) + | sobj==a&&(elem name b)==True = True + | sobj==a = False + | otherwise = isValidServerObjectScalarField sobj name t +-- you can create as many relationships as you want with your server... +isValidServerObjectNestedObjectField :: ServerObject -> String -> [(String,[String])] -> Bool +isValidServerObjectNestedObjectField _ _ [] = E.throw InvalidObjectException +isValidServerObjectNestedObjectField sobj name ((a,b):t) + | sobj==a&&(elem name b)==True = True + | sobj==a = False + | 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] +translateServerObjectToDBName _ [] = E.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 _ _ [] = E.throw RelationshipConfigurationException +getDBObjectRelationships from to ((a,b,c):t) + | from==a&&to==b = c + | otherwise = getDBObjectRelationships from to t + + +getScalarName :: ScalarType -> String +getScalarName (ScalarType alias name trans arg) = name +getScalarArgument :: ScalarType -> String +getScalarArgument (ScalarType alias name trans arg) = if arg==Nothing then (E.throw NullArgumentException) else (fromJust arg) +getTransformation :: ScalarType -> (Transformation,Argument) +getTransformation (ScalarType alias name trans arg) = (trans,arg) +getObjectName :: NestedObject -> String +getObjectName (NestedObject alias name sobj ss sf) = name +getServerObject :: NestedObject -> ServerObject +getServerObject (NestedObject alias name sobj ss sf) = sobj +getSubFields :: NestedObject -> SubFields +getSubFields (NestedObject alias name sobj ss sf) = sf +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
+ src/Components/ObjectHandlers/ServerObjectValidator.hs view
@@ -0,0 +1,29 @@+module Components.ObjectHandlers.ServerObjectValidator where + +import qualified Control.Exception as E +import Data.Maybe +import Data.Either +import Model.ServerObjectTypes +import Model.ServerExceptions +import Components.ObjectHandlers.ObjectsHandler + + +-- check that all nested objects are with valid properties +checkObjectsAttributes :: [RootObject] -> [(String,[String])] -> [(String,[String])] -> Bool +checkObjectsAttributes objs sss sos = foldr (\x y -> (hasValidAttributes x sss sos)&&y) True objs +hasValidAttributes :: NestedObject -> [(String,[String])] -> [(String,[String])] -> Bool +hasValidAttributes (NestedObject alias name sobject ss sfs) sss sos = (if ss==Nothing then True else isValidSubSelection sobject (fromJust ss) sss)&&(isValidSubFields sobject sfs sss sos) +isValidSubSelection :: ServerObject -> ScalarType -> [(String,[String])] -> Bool +isValidSubSelection obj (ScalarType alias name trans arg) sss = (isValidServerObjectScalarField obj name sss) -- &&(isValidScalarTransformation obj name trans arg) +isValidSubFields :: ServerObject -> [Field] -> [(String,[String])] -> [(String,[String])] -> Bool +isValidSubFields _ [] _ _ = False -- we should not get an empty query +isValidSubFields obj sfs sss sos = foldr (\x y -> (isValidSubField obj x sss sos)&&y) True sfs +isValidSubField :: ServerObject -> Field -> [(String,[String])]-> [(String,[String])] -> Bool +isValidSubField obj (Left sf) sss sos = (isValidServerObjectScalarField obj sname sss) -- &&(isValidScalarTransformation obj sname trans arg) + where + sname = getScalarName sf + (trans, arg) = getTransformation sf +isValidSubField obj sf sss sos = (isValidServerObjectNestedObjectField obj ofname sos)&&(hasValidAttributes nestedObjectField sss sos) + where + nestedObjectField = fromRight (E.throw InvalidObjectException) sf + ofname = getObjectName nestedObjectField
+ src/Components/Parsers/QueryParser.hs view
@@ -0,0 +1,357 @@+module Components.Parsers.QueryParser where + + +import qualified Control.Exception as E +import Model.ServerExceptions +import Model.ServerObjectTypes +import Components.ObjectHandlers.ObjectsHandler (readServerObject) + + +{-----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 (h1:h2:t) mde + | h1=='#' = removeCommentsHelper (h2:t) True + | h1=='\r' = '\r':removeCommentsHelper (h2:t) False + | h1=='\n' = '\n':removeCommentsHelper (h2:t) False + | h1=='\\'&&h2=='r' = '\\':'r':removeCommentsHelper t False + | h1=='\\'&&h2=='n' = '\\':'n':removeCommentsHelper t False + | mde==True = removeCommentsHelper (h2:t) mde + | otherwise = h1:(removeCommentsHelper (h2: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:[]) + | h=='\n' = ' ':[] + | h=='\r' = ' ':[] + | otherwise = h:[] +removeLinebreaks (h1:h2:t) + | h1=='\\'&&h2=='r' = ' ':removeLinebreaks t + | h1=='\\'&&h2=='n' = ' ':removeLinebreaks t + | otherwise = h1:removeLinebreaks (h2: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])] -> RootObjects +parseStringToObjects [] _ = E.throw EmptyQueryException +parseStringToObjects str svrobjs = composeObjects query svrobjs + where + (qry,fmts) = getQueryAndFragments str + fragments = parseFragments fmts svrobjs + query = substituteFragments qry fragments svrobjs +-- 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 + | m==True = getQueryAndFragmentsHelper t l m q (f++[h]) +data Fragment = Fragment + { name :: String + , targetObject :: ServerObject + , replacement :: String + } deriving Show +parseFragments :: String -> [(String,[String])] -> [Fragment] +parseFragments str svrobjs = parseFragmentsHelper str "" 0 [] svrobjs +parseFragmentsHelper :: String -> String -> Int -> [Fragment] -> [(String,[String])] -> [Fragment] +parseFragmentsHelper [] _ _ rslt _ = rslt +parseFragmentsHelper (h:t) acc l rslt svrobjs + | h=='{' = parseFragmentsHelper t (acc++[h]) (l+1) rslt svrobjs + | h=='}'&&l==1 = parseFragmentsHelper t [] (l-1) ((createFragment acc svrobjs):rslt) svrobjs -- completed one fragment + | h=='}' = parseFragmentsHelper t (acc++[h]) (l-1) rslt svrobjs -- closed a nested object + | otherwise = parseFragmentsHelper t (acc++[h]) l rslt svrobjs +-- with a fragment string that is without closing curly braces, we want a fragments +createFragment :: String -> [(String,[String])] -> Fragment +createFragment str svrobjs = createFragmentHelper str 0 [] False False False False "" "" svrobjs +{- + 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])] -> Fragment +createFragmentHelper [] l acc d n a o rst1 rst2 svrobjs = if (l==1&&d==True&&n==True&&a==True&&o==True) then Fragment { name=rst1,targetObject=(readServerObject rst2 svrobjs),replacement=acc } else E.throw ParseFragmentException +createFragmentHelper (h:t) l acc d n a o rst1 rst2 svrobjs + | 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 + | d==False&&h==' '&&(length acc)>0&&acc=="fragment" = createFragmentHelper t l [] True n a o rst1 rst2 svrobjs + | d==False&&h==' '&&(length acc)>0 = E.throw ParseFragmentException + | d==False&&h==' '&&(length acc)<1 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs + | d==False = E.throw ParseFragmentException + | n==False&&h==' '&&(length acc)==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs + | n==False&&h==' '&&(length acc)>0 = createFragmentHelper t l [] d True a o acc rst2 svrobjs + | n==False&&(isValidFragmentNameChar h)==False = E.throw ParseFragmentException + | n==False = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs + | a==False&&h==' '&&(length acc)==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs + | a==False&&h==' '&&(length acc)>0&&(acc=="on") = createFragmentHelper t l [] d n True o rst1 rst2 svrobjs + | a==False&&h==' '&&(length acc)>0 = E.throw ParseFragmentException + | a==False&&(h=='o'||h=='n') = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs + | a==False = E.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 + | o==False&&((length acc)==0)&&(h==' ') = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs + | o==False&&((length acc)==0) = E.throw ParseFragmentException + | o==False&&h==' ' = createFragmentHelper t l [] d n a True rst1 acc svrobjs + | o==False&&h=='{' = createFragmentHelper t (l+1) [] d n a True rst1 acc svrobjs + | o==False&&(isValidIdentifierChar h) = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs + | o==False = E.throw ParseFragmentException + | h==' '&&l==0 = createFragmentHelper t l [] d n a o rst1 rst2 svrobjs + | h=='{'&&l==0 = createFragmentHelper t (l+1) [] d n a o rst1 rst2 svrobjs + | l==0 = E.throw ParseFragmentException + | (isValidIdentifierChar h)||h==' ' = createFragmentHelper t l (acc++[h]) d n a o rst1 rst2 svrobjs + | h=='{' = createFragmentHelper t (l+1) (acc++[h]) d n a o rst1 rst2 svrobjs + | h=='}' = createFragmentHelper t (l-1) (acc++[h]) d n a o rst1 rst2 svrobjs + | otherwise = E.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)==39) + -- call after infering types on nested objects +substituteFragments :: String -> [Fragment] -> [(String,[String])] -> String +substituteFragments [] _ _ = "" +substituteFragments str [] _ = str +-- check that all fragments are valid +substituteFragments str fragments svrobjs = substituteFragmentsHelper str fragments 0 "" svrobjs +-- With query code, we use fragments to replace code blocks +-- REQUIRES: the curly braces are correctly balanced and placed +substituteFragmentsHelper :: String -> [Fragment] -> Int -> String -> [(String,[String])] -> String +substituteFragmentsHelper [] _ _ _ _ = "" +substituteFragmentsHelper str [] _ _ _ = str +substituteFragmentsHelper (h:t) fragments l acc svrobjs + | h=='{'&&l==0 = h:substituteFragmentsHelper t fragments (l+1) [] svrobjs + | l==0 = h:substituteFragmentsHelper t fragments l [] svrobjs + | h=='{' = ((h:(subResult))++(substituteFragmentsHelper continue fragments (l+1) [] svrobjs)) + | h=='}' = h:(substituteFragmentsHelper t fragments (l-1) [] svrobjs) + | otherwise = h:(substituteFragmentsHelper t fragments l (acc++[h]) svrobjs) + where + replacer = findFragment fragments (getNestedObject acc svrobjs) + (subject, continue) = splitSubject t "" 0 + subResult = substituteHelper subject (target replacer) (switch replacer) "" "" +-- from accumulated objects/fields/arguments, we return a found object where code is without brackets +getNestedObject :: String -> [(String,[String])] -> ServerObject +getNestedObject [] _ = E.throw ParseFragmentException +getNestedObject str svrobjs + | (elem ':' str)&&(elem '(' str) = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then [] else y++[x]) "" (foldr (\x y -> if x=='(' then [] else x:y) "" str)) svrobjs + | (elem '(' str) = readServerObject (removeSpaces $ foldr (\x y -> if x=='(' then [] else x:y) "" str) svrobjs + | (elem ':' str) = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then [] else y++[x]) "" str) svrobjs + | otherwise = readServerObject (removeSpaces str) svrobjs +-- from possible fragments and found fragment (if present), we return (replacement string, target string). +data Replacer = Replacer + { target :: String + , switch :: String + } +findFragment :: [Fragment] -> ServerObject -> Replacer +findFragment [] _ = Replacer { target="",switch="" } -- we never encounter an empty Fragment list, so we needn't worry about a blank Replacer +findFragment (frt:t) tar + | (targetObject frt)==tar = Replacer { target=("..."++(name frt)),switch=(replacement frt) } + | otherwise = findFragment t tar +-- 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 +substituteHelper :: String -> String -> String -> String -> String -> String +substituteHelper [] _ _ acc rlt = (rlt++acc) +substituteHelper subj [] _ _ _ = subj +substituteHelper (h:t) trg rpl acc rlt + | (length acc)<3&&h=='.' = substituteHelper t trg rpl (acc++[h]) rlt + | (length acc)<3 = substituteHelper t trg rpl [] (rlt++acc++[h]) + | (isMatching (acc++[h]) trg)&&((length (acc++[h]))==(length trg)) = substituteHelper t trg rpl [] (rlt++rpl) + | (isMatching (acc++[h]) trg) = substituteHelper t trg rpl (acc++[h]) rlt + | otherwise = substituteHelper t trg rpl [] (rlt++acc++[h]) +-- check whether both strings are thus far same +isMatching :: String -> String -> Bool +isMatching acc trg = foldr (\(x,y) z -> (x==y)&&z) True (zip acc trg) +-- 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 +-} +composeObjects :: String -> [(String,[String])] -> RootObjects +composeObjects [] _ = E.throw EmptyQueryException +composeObjects str svrobjs = composeObjectsHelper str 0 svrobjs +composeObjectsHelper :: String -> Int -> [(String,[String])] -> RootObjects +composeObjectsHelper [] _ _ = E.throw EmptyQueryException +composeObjectsHelper (h:t) l svrobjs + | h=='{'&&l==0 = separateRootObjects (extractLevel t) svrobjs -- find and separate every root object + | otherwise = composeObjectsHelper t l svrobjs +-- ...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])] -> [RootObject] +separateRootObjects str svrobjs = separateRootObjectsHelper str "" svrobjs +separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [RootObject] +separateRootObjectsHelper [] _ _ = [] +separateRootObjectsHelper (h:t) acc svrobjs + | h=='{' = ((createNestedObject (acc++[h]++(extractLevel t)) svrobjs) :: RootObject):separateRootObjectsHelper (removeLevel t) [] svrobjs + | otherwise = separateRootObjectsHelper t (acc++[h]) svrobjs +-- 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])] -> NestedObject +createNestedObject str svrobjs = createNestedObjectHelper str "" svrobjs +createNestedObjectHelper :: String -> String -> [(String,[String])] -> NestedObject +createNestedObjectHelper [] _ _ = E.throw InvalidObjectException -- we should not encounter this since we already checked against empty brackets +createNestedObjectHelper (h:t) acc svrobjs + | h=='{' = (NestedObject ((parseAlias acc) :: Alias) ((parseName acc) :: Name) ((parseServerObject acc svrobjs) :: ServerObject) ((parseSubSelection acc) :: SubSelection) ((parseSubFields (extractLevel t) svrobjs) :: SubFields)) :: RootObject + | otherwise = createNestedObjectHelper t (acc++[h]) svrobjs +-- given object header without any braces, we want a name. +parseServerObject :: String -> [(String,[String])] -> ServerObject +parseServerObject [] svrobjs = readServerObject "" svrobjs +parseServerObject str svrobjs + | (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 + | (elem ':' str)==True = readServerObject (removeSpaces $ foldl (\y x -> if x==':' then [] else (y++[x])) "" str) svrobjs + | otherwise = readServerObject (removeSpaces str) svrobjs +-- given object header without any braces, we want the alias if there is one. +parseAlias :: String -> Alias +parseAlias [] = Nothing :: Alias +parseAlias str = parseAliasHelper str "" +parseAliasHelper :: String -> String -> Alias +parseAliasHelper [] _ = Nothing :: Alias +parseAliasHelper (h:t) acc + | h=='(' = Nothing :: Alias + | h==':' = (Just $ removeSpaces acc) :: Alias + | otherwise = parseAliasHelper t (acc++[h]) +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) ((removeSpaces (foldr (\x y -> if x==':' then [] else x:y) "" t)) :: Name) (Nothing :: Transformation) ((Just $ removeSpaces $ 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])] -> [Field] +parseSubFields [] _ = [] +parseSubFields str svrobjs = parseSubFieldsHelper str "" "" svrobjs +parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> [Field] +parseSubFieldsHelper [] [] [] _ = [] +parseSubFieldsHelper [] [] acc _ = [Left $ createScalarType acc :: Field] +parseSubFieldsHelper [] acc [] _ = [Left $ createScalarType acc :: Field] +parseSubFieldsHelper [] acc1 acc2 _ = (Left $ createScalarType (acc2++acc1)):[] +parseSubFieldsHelper (h:t) acc1 acc2 svrobjs + | h==':' = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1) [] svrobjs + | h==' '&&(length acc1)>0 = parseSubFieldsHelper t [] acc1 svrobjs + | h==' ' = parseSubFieldsHelper t acc1 acc2 svrobjs + | h==','&&(length acc1)>0 = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t [] [] svrobjs + | h==','&&(length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t [] [] svrobjs + | h=='('&&(length acc1)>0 = parseSubFieldsHelper (removeSubSelection t) (acc1++(getSubSelection t)) [] svrobjs + | h=='('&&(length acc2)>0 = parseSubFieldsHelper (removeSubSelection t) (acc2++(getSubSelection t)) [] svrobjs + | h=='{'&&(length acc1)>0 = (Right $ (createNestedObject (acc1++[h]++(extractLevel t)) svrobjs) :: Field):parseSubFieldsHelper (removeLevel t) [] [] svrobjs + | h=='{'&&(length acc2)>0 = ((Right $ (createNestedObject (acc2++[h]++(extractLevel t))) svrobjs) :: Field):parseSubFieldsHelper (removeLevel t) [] [] svrobjs + | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) [] svrobjs + | otherwise = parseSubFieldsHelper t (acc1++[h]) [] svrobjs +removeLeadingSpaces :: String -> String +removeLeadingSpaces [] = [] +removeLeadingSpaces (h:t) = if h==' ' then removeLeadingSpaces t else (h:t) +-- EFFECTS: return subfields code without closing bracket +removeSubSelection :: String -> String +removeSubSelection [] = [] +removeSubSelection (h:t) = if h==')' then t else removeSubSelection t +-- EFFECTS: return subselection specification without closing bracket +getSubSelection :: String -> String +getSubSelection [] = [] +getSubSelection (h:t) = if h==')' then [] else h:getSubSelection t +extractLevel :: String -> String +extractLevel [] = [] +extractLevel str = extractLevelHelper str 0 +extractLevelHelper :: String -> Int -> String +extractLevelHelper [] _ = [] +extractLevelHelper (h:t) l + | h=='{' = '{':extractLevelHelper t (l+1) + | h=='}'&&l==0 = [] + | h=='}' = '}':extractLevelHelper t (l-1) + | otherwise = h:extractLevelHelper t l +removeLevel :: String -> String +removeLevel [] = [] +removeLevel str = removeLevelHelper str 0 +removeLevelHelper :: String -> Int -> String +removeLevelHelper [] _ = [] +removeLevelHelper (h:t) l + | l<0 = 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 [] = E.throw InvalidScalarException +createScalarType str = createScalarTypeHelper str "" "" +createScalarTypeHelper :: String -> String -> String -> ScalarType +createScalarTypeHelper [] x [] = ScalarType (Nothing :: Alias) (x :: Name) (Nothing :: Transformation) (Nothing :: Argument) +createScalarTypeHelper [] [] x = ScalarType (Nothing :: Alias) (x :: Name) (Nothing :: Transformation) (Nothing :: Argument) +createScalarTypeHelper [] x y = ScalarType (Just y :: Alias) (x :: Name) (Nothing :: Transformation) (Nothing :: Argument) +createScalarTypeHelper (h:t) acc1 acc2 + | h==':' = createScalarTypeHelper t [] acc1 + | h=='(' = ScalarType (Just acc2 :: Alias) (acc1 :: Name) ((Just $ foldr (\x y -> if x==':' then [] else x:y) [] t) :: Transformation) ((Just $ foldl (\y x -> if x==':' then [] else (y++[x])) [] (foldr (\x y -> if x==')' then [] else x:y) [] t)) :: Argument) + | otherwise = createScalarTypeHelper t (acc1++[h]) acc2 +-- 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 DataProcessor.hs
+ src/Components/QueryComposers/SQLQueryComposer.hs view
@@ -0,0 +1,57 @@+module Components.QueryComposers.SQLQueryComposer where + +import Data.Either +import qualified Data.Map.Strict as M +import qualified Control.Exception as E +import Model.ServerObjectTypes +import Model.ServerExceptions +import Components.ObjectHandlers.ObjectsHandler + + +makeSqlQueries :: [RootObject] -> [(String,[String])] -> [(String,String,[String])] -> [[String]] +makeSqlQueries [] _ _ = [] +makeSqlQueries (h:t) sodn sor = (makeSqlQuerySet h sodn sor):(makeSqlQueries t sodn sor) +makeSqlQuerySet :: RootObject -> [(String,[String])] -> [(String,String,[String])] -> [String] +makeSqlQuerySet obj sodn sor = if (length $ translateServerObjectToDBName (getServerObject obj) sodn)==1 then (addSqlQueryFields (getSubFields obj) (M.fromList [((head $ translateServerObjectToDBName (getServerObject obj) sodn),1)]) ("select "++(head $ translateServerObjectToDBName (getServerObject obj) sodn)++(show 1)++".id,") (" from"++(makeSqlTablePhrase obj (head $ translateServerObjectToDBName (getServerObject obj) sodn) 1)) (" order by "++(head $ translateServerObjectToDBName (getServerObject obj) sodn)++(show 1)++".id asc") (((head $ translateServerObjectToDBName (getServerObject obj) sodn)++(show 1)):[]) [] [(head $ translateServerObjectToDBName (getServerObject obj) sodn)] sodn sor) else (foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields obj) (M.fromList [(x,1)]) ("select "++x++(show 1)++".id,") (" from"++(makeSqlTablePhrase obj x 1)) (" order by "++x++(show 1)++".id asc") ((x++(show 1)):[]) [] [x] sodn sor) | x<-(translateServerObjectToDBName (getServerObject obj) sodn)]) +-- 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 -> M.Map String Int -> String -> String -> String -> [String] -> [SubFields] -> [String] -> [(String,[String])] -> [(String,String,[String])] -> [String] +addSqlQueryFields [] counts select from order [] [] ltable _ _ = [(removeLastChar select)++from++order++";"] +addSqlQueryFields [] counts select from order [] (h:t) ltable _ _ = E.throw CreatingSqlQueryObjectFieldsException +addSqlQueryFields [] counts select from order (h:t) [] ltable _ _ = [(removeLastChar select)++from++order++";"] +addSqlQueryFields [] counts select from order (a:b) (h:t) ltable sodn sor = addSqlQueryFields h counts select from order b t ltable sodn sor +addSqlQueryFields (h:t) counts select from order [] [] ltable _ _ = E.throw CreatingSqlQueryObjectsException +addSqlQueryFields (h:t) counts select from order [] (a:b) ltable _ _ = E.throw CreatingSqlQueryObjectsException +addSqlQueryFields (h:t) counts select from order names fields ltable sodn sor + | (isLeft h)==True = addSqlQueryFields t counts (select++(head names)++"."++(getScalarName $ fromLeft (E.throw InvalidScalarException) h)++",") from order names fields ltable sodn sor + -- since only difference is table name, I should remove repeated computations by changing only name... + | tablesCount>1 = foldr (\x y -> x++y) [] [(addSqlQueryFields (getSubFields nobj) (calcNewCounts (head ltable) x) (select++x++(show $ (M.!) (calcNewCounts (head ltable) x) x)++".id,") (from++(makeTransitions (calcNewCounts (head ltable) x) (getDBObjectRelationships (head ltable) x sor) nobj)) (order++","++x++(show $ (M.!) (calcNewCounts (head ltable) x) x)++".id asc") ((x++(show $ (M.!) (calcNewCounts (head ltable) x) x)):names) (t:fields) [x]) sodn sor | x<-tables] + | otherwise = addSqlQueryFields (getSubFields nobj) (calcNewCounts (head ltable) $ head tables) (select++(head tables)++(show $ (M.!) (calcNewCounts (head ltable) $ head tables) (head tables))++".id,") (from++(makeTransitions (calcNewCounts (head ltable) $ head tables) (getDBObjectRelationships (head ltable) (head tables) sor) nobj)) (order++","++(head tables)++(show $ (M.!) (calcNewCounts (head ltable) $ head tables) (head tables))++".id asc") (((head tables)++(show ((calcNewCounts (head ltable) $ head tables) M.! (head tables)))):names) (t:fields) [(head tables)] sodn sor + where + calcNewCounts :: String -> String -> M.Map String Int + calcNewCounts from to = foldr (\x y -> M.insertWith (+) x 1 y) counts (getNewTables $ getDBObjectRelationships from to sor) + nobj = fromRight (E.throw InvalidObjectException) h + sobj = getServerObject nobj + tablesCount = length tables + tables = translateServerObjectToDBName sobj sodn +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 :: M.Map String Int -> [String] -> NestedObject -> String +makeTransitions counts (h1:h2:h3:h4:h5:h6:h7:t) nobj = " inner join "++h5++" as "++h5++(show $ (M.!) counts h5)++" on "++h1++(show $ (M.!) counts h1)++"."++h2++"="++h5++(show $ (M.!) counts h5)++"."++h6++(completeTransition counts (h3:h4:h5:h6:h7:t) nobj) +makeTransitions counts (h1:h2:h3:h4:t) nobj = " inner join "++(if (withSubSelection nobj)==True then ("(select * from "++h3++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")") else h3)++" as "++h3++(show $ (M.!) counts h3)++" on "++h1++(show $ (M.!) counts h1)++"."++h2++"="++h3++(show $ (M.!) counts h3)++"."++h4 +makeTransitions _ _ _ = E.throw RelationshipConfigurationException +completeTransition :: M.Map String Int -> [String] -> NestedObject -> String +completeTransition counts (h1:h2:h3:h4:h5:[]) nobj = " inner join "++(if (withSubSelection nobj)==True then ("(select * from "++h1++" where "++(getSubSelectionField nobj)++"="++(getSubSelectionArgument nobj)++")") else h1)++" as "++h1++(show $ (M.!) counts h1)++" on "++h3++(show $ (M.!) counts h3)++"."++h5++"="++h1++(show $ (M.!) counts h1)++"."++h2 +completeTransition counts (h1:h2:h3:h4:h5:h6:h7:h8:t) nobj = " inner join "++h6++" as "++h6++(show $ (M.!) counts h6)++" on "++h3++(show $ (M.!) counts h3)++"."++h5++"="++h6++(show $ (M.!) counts h6)++"."++h7++(completeTransition counts (h1:h2:h6:h7:h8:t) nobj) +completeTransition counts _ _ = E.throw RelationshipConfigurationException
+ src/GraphQL.hs view
@@ -0,0 +1,64 @@+{- | +Module : GraphQL +Description : Here is methods to interpret your GraphQL-SQL query and process the Persistent results +License : IPS +Maintainer : jasonsychau@live.ca +Stability : provisional + +<https://graphql.github.io/ Here> is a link to the official documentations. You can learn and get a feel for how can you implement this package. + +This is the main module to interpret your queries. The expected query type is a single string to comprise all your GraphQL queries and fragments. + +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. +-} +module GraphQL ( + -- * Functions + module GraphQL, + -- * Server data types + module Model.ServerObjectTypes + ) where + +import Data.Text (Text) +import qualified Components.Parsers.QueryParser as QP +import qualified Components.DataProcessors.PersistentDataProcessor as DP +import Model.ServerObjectTypes +import GraphQLHelper + + +{- | Function processQueryString: + This the function to call to get queries from a GraphQL query. + The ordered arguments are: + - the GraphQL query as a string + - a list of tuple of String and list of String that is unique server object names and all names that are referencing then with any query + - a list of tuple of String and list of String that is exact same unique server object names while the list is the valid server object + scalar subfields as they are spelt in the database + - a list of tuple of String and list of String that is exact same unique server object names while the list is the valid server object + nested object subfields as they are referenced in the next list of relationship tables + - a list of tuple of String, String, and list of String that is above server object names to make an identity name, a reference name, + and a list of String that is identity table, escape identity column name, reference table, arrival reference column name, and an from-to + order of intermediate table triplet strings of intermediate table name, intermediate table arrival column name, and intermediate table + departure column name + The return value is a tuple of server representation objects and a list of list of sql queries. The first list is holding lists that are + grouping queries from the same GraphQL query. The inner list is holding the String value sql queries. The server representation objects + is later used to format database results to the GraphQL return value syntax. +-} +processQueryString :: String -- ^ This is the given GraphQL query. + -> [(String,[String])] -- ^ This is the ServerObject to list of query reference names. + -> [(String,[String])] -- ^ This is the ServerObject to list of valid scalar subfields (which are exactly named after database column names). + -> [(String,[String])] -- ^ This is the ServerObject to list of valid nested object subfields (which are exactly named after the from and to strings within the last function argument). + -> [(String,[String])] -- ^ This is the ServerObject to list of database table names (which are exact references to table names). + -> [(String,String,[String])] -- ^ This is the ServerObject to list of from-to-and intermediate triplet strings as described above to identify all GraphQL relationships with database sequences. + -> ([RootObject],[[String]]) -- ^ The return value is one tuple with server objects and list of grouped sql query strings. +processQueryString str svrobjs sss sos sodn sor = checkObjects sss sos sodn sor $ flip checkString svrobjs $ QP.processString str + +{- | Function processPersistentData: + This is the function to call after casting PersistValues to Text from processQueryString. + The ordered arguments are: + - all the data that is cast to Text type + - an unmodified copy of the RootObject list that is returned from processQueryString. + The return result is a string to resemble the GraphQL return value. +-} +processPersistentData :: [[[[Text]]]] -- ^ This is the unmodified Persistent database query return value (a list of GraphQL-grouped results list of SQL query results list of data row lists). + -> [RootObject] -- ^ This is the unmodified server objects that was composed from previous processQueryString function. + -> String -- ^ The return value is a string type to describe the GraphQL-organized return values. +processPersistentData dt ro = DP.processReturnedValues ro dt
+ src/GraphQLHelper.hs view
@@ -0,0 +1,14 @@+module GraphQLHelper where + +import qualified Control.Exception as E +import qualified Components.Parsers.QueryParser as QP +import qualified Components.ObjectHandlers.ServerObjectValidator as SOV +import qualified Components.QueryComposers.SQLQueryComposer as QC +import Model.ServerObjectTypes +import Model.ServerExceptions + + +checkString :: String -> [(String,[String])] -> [RootObject] +checkString str svrobjs = if (QP.validateQuery str)==True then (QP.parseStringToObjects str svrobjs) else E.throw SyntaxException +checkObjects :: [(String,[String])] -> [(String,[String])] -> [(String,[String])] -> [(String,String,[String])] -> [RootObject] -> ([RootObject],[[String]]) +checkObjects sss sos sodn sor ros = if (SOV.checkObjectsAttributes ros sss sos)==True then (ros,QC.makeSqlQueries ros sodn sor) else E.throw InvalidObjectSubFieldException
+ src/Model/ServerExceptions.hs view
@@ -0,0 +1,33 @@+module Model.ServerExceptions where + +import Control.Exception + + +data QueryException = SyntaxException | + VariableException | + ParseFragmentException | + EmptyQueryException | + InvalidObjectException | + InvalidScalarException | + InvalidObjectNestedObjectFieldException | + InvalidObjectScalarFieldException | + InvalidObjectSubFieldException | + InvalidAttributeTransformation | + NullArgumentException | + CreatingSqlQueryObjectFieldsException | + CreatingSqlQueryObjectsException | + TooManyTablesException | + EmptyRowException | + EOFDataProcessingException | + InvalidArgumentException | + Foundlinebreakexception | + RelationshipConfigurationException + deriving Show + +instance Exception QueryException + +-- use Control.Exception.assert to make your unit tests. +-- simply use throw SyntaxException +-- can I catch from main block? +-- you can catch an exception and display message at next page. +-- TODO: abstract read ServerObject: if read is wrong we catch and throw read server object error
+ src/Model/ServerObjectTypes.hs view
@@ -0,0 +1,30 @@+{- | +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 NestedObject + +-- | 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