summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ChangeLog.md4
-rw-r--r--graphql-w-persistent.cabal2
-rw-r--r--src/Components/DataProcessors/PersistentDataProcessor.hs5
-rw-r--r--src/Components/ObjectHandlers/ServerObjectValidator.hs2
-rw-r--r--src/Components/Parsers/QueryParser.hs205
-rw-r--r--src/Components/Parsers/VariablesParser.hs21
-rw-r--r--src/GraphQL.hs6
-rw-r--r--src/GraphQLHelper.hs4
-rw-r--r--src/Model/ServerExceptions.hs3
9 files changed, 159 insertions, 93 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 1e28c26..b813934 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,8 +1,8 @@
# Revision history for graphql-w-persistent
-## 0.3.1.3 -- 2019-05-01
+## 0.3.2.1 -- 2019-05-18
-* allow relationships of links between more than one field
+* 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
diff --git a/graphql-w-persistent.cabal b/graphql-w-persistent.cabal
index 66d6563..0eeb366 100644
--- a/graphql-w-persistent.cabal
+++ b/graphql-w-persistent.cabal
@@ -10,7 +10,7 @@ name: graphql-w-persistent
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.3.1.3
+version: 0.3.2.1
-- A short (one-line) description of the package.
synopsis: Haskell GraphQL query parser-interpreter-data processor.
diff --git a/src/Components/DataProcessors/PersistentDataProcessor.hs b/src/Components/DataProcessors/PersistentDataProcessor.hs
index 3c20ff2..14ea96f 100644
--- a/src/Components/DataProcessors/PersistentDataProcessor.hs
+++ b/src/Components/DataProcessors/PersistentDataProcessor.hs
@@ -21,9 +21,10 @@ processReturnedValue sss (NestedObject alias name sobj _ sfs) rlts = (if (alias=
-- with SubFields and data rows, we want json representation on qraphql query data
processSubFields :: [(String,[(String,String)])] -> String -> [Field] -> [[[Text]]] -> [JSValue]
processSubFields _ _ _ [] = []
-processSubFields sss sobj sfs rlts = if length(qryData)>0 then ((showJSON $ toJSObject $ composeGraphQlRow sss sobj sfs $ fetchGraphQlRow qryData):(processSubFields sss sobj sfs [removeDataRow qryData])) else []
+processSubFields _ _ [] _ = []
+processSubFields sss sobj sfs rlts = if length(dta)>0 then ((showJSON $ toJSObject $ composeGraphQlRow sss sobj sfs $ fetchGraphQlRow dta):(processSubFields sss sobj sfs [removeDataRow dta])) else []
where
- qryData = foldr (\x y -> x++y) [] rlts
+ dta = foldr (\x y -> x++y) [] rlts
composeGraphQlRow :: [(String,[(String,String)])] -> String -> [Field] -> [[Text]] -> [(String,JSValue)]
composeGraphQlRow _ _ [] ([]:t) = [] -- done
-- composeGraphQlRow _ _ _ [] = [] -- no data
diff --git a/src/Components/ObjectHandlers/ServerObjectValidator.hs b/src/Components/ObjectHandlers/ServerObjectValidator.hs
index 0c09e70..67b94e9 100644
--- a/src/Components/ObjectHandlers/ServerObjectValidator.hs
+++ b/src/Components/ObjectHandlers/ServerObjectValidator.hs
@@ -16,7 +16,7 @@ hasValidAttributes (NestedObject alias name sobject ss sfs) sss sos = (if ss==No
isValidSubSelection :: ServerObject -> ScalarType -> [(String,[(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,[String])] -> Bool
-isValidSubFields _ [] _ _ = False -- we should not get an empty query
+isValidSubFields _ [] _ _ = True -- 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,[String])] -> Bool
isValidSubField obj (Left sf) sss sos = (isValidServerObjectScalarField obj sname sss) -- &&(isValidScalarTransformation obj sname trans arg)
diff --git a/src/Components/Parsers/QueryParser.hs b/src/Components/Parsers/QueryParser.hs
index 5e4018d..19cc0b8 100644
--- a/src/Components/Parsers/QueryParser.hs
+++ b/src/Components/Parsers/QueryParser.hs
@@ -5,6 +5,7 @@ import qualified Control.Exception as E
import Model.ServerExceptions
import Model.ServerObjectTypes
import Components.ObjectHandlers.ObjectsHandler (readServerObject)
+import Data.Char (toLower)
{-----Step 1. PROCESSING-----}
@@ -70,13 +71,13 @@ validateNoEmptyBracketsHelper (a:b) acc (i:j)
{-----Step 3. PARSING-----}
-parseStringToObjects :: String -> [(String,[String])] -> RootObjects
-parseStringToObjects [] _ = E.throw EmptyQueryException
-parseStringToObjects str svrobjs = composeObjects query svrobjs
+parseStringToObjects :: String -> [(String,[String])] -> [(String,String,String)] -> RootObjects
+parseStringToObjects [] _ _ = E.throw EmptyQueryException
+parseStringToObjects str svrobjs vars = composeObjects query svrobjs vars
where
(qry,fmts) = getQueryAndFragments str
fragments = parseFragments fmts svrobjs
- query = substituteFragments qry fragments svrobjs
+ query = substituteFragments qry fragments svrobjs vars
-- REQUIRES: curly braces are in correct order
getQueryAndFragments :: String -> (String, String)
getQueryAndFragments str = getQueryAndFragmentsHelper str 0 False "" ""
@@ -110,7 +111,6 @@ createFragment str svrobjs = createFragmentHelper str 0 [] False False False Fal
n is for name
a is for arrangement
o is for object
- b is for
-}
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
@@ -129,7 +129,7 @@ createFragmentHelper (h:t) l acc d n a 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)&&((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
@@ -139,7 +139,7 @@ createFragmentHelper (h:t) l acc d n a o rst1 rst2 svrobjs
| 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
+ | (isValidIdentifierChar h)||h==' '||h==')'||h=='('||h==':'||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
@@ -148,26 +148,26 @@ isValidFragmentNameChar c = ((fromEnum c)>=65&&(fromEnum c)<=90)||((fromEnum c)>
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
+substituteFragments :: String -> [Fragment] -> [(String,[String])] -> [(String,String,String)] -> String
+substituteFragments [] _ _ _ = ""
+substituteFragments str [] _ _ = str
-- check that all fragments are valid
-substituteFragments str fragments svrobjs = substituteFragmentsHelper str fragments 0 "" svrobjs
+substituteFragments str fragments svrobjs vars = substituteFragmentsHelper str fragments 0 "" svrobjs vars
-- 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)
+substituteFragmentsHelper :: String -> [Fragment] -> Int -> String -> [(String,[String])] -> [(String,String,String)] -> String
+substituteFragmentsHelper [] _ _ _ _ _ = ""
+substituteFragmentsHelper str [] _ _ _ _ = str
+substituteFragmentsHelper (h:t) fragments l acc svrobjs vars
+ | h=='{'&&l==0 = h:substituteFragmentsHelper t fragments (l+1) [] svrobjs vars
+ | l==0 = h:substituteFragmentsHelper t fragments l [] svrobjs vars
+ | h=='{' = ((h:(subResult))++(substituteFragmentsHelper continue fragments (l+1) [] svrobjs vars))
+ | h=='}' = h:(substituteFragmentsHelper t fragments (l-1) [] svrobjs vars)
+ | otherwise = h:(substituteFragmentsHelper t fragments l (acc++[h]) svrobjs vars)
where
replacer = findFragment fragments (getNestedObject acc svrobjs)
(subject, continue) = splitSubject t "" 0
- subResult = substituteHelper subject (target replacer) (switch replacer) "" ""
+ subResult = substituteHelper subject (target replacer) (switch replacer) "" "" vars
-- from accumulated objects/fields/arguments, we return a found object where code is without brackets
getNestedObject :: String -> [(String,[String])] -> ServerObject
getNestedObject [] _ = E.throw ParseFragmentException
@@ -195,15 +195,18 @@ splitSubject (h:t) acc l
| 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])
+substituteHelper :: String -> String -> String -> String -> String -> [(String,String,String)] -> String
+substituteHelper [] _ _ acc rlt _ = (rlt++acc)
+substituteHelper subj [] _ _ _ _ = subj
+substituteHelper (h:t) trg rpl acc rlt vars
+ | (length acc)<3&&h=='.' = substituteHelper t trg rpl (acc++[h]) rlt vars
+ | (length acc)<3 = substituteHelper t trg rpl [] (rlt++acc++[h]) vars
+ | (isMatching (acc++[h]) trg)&&((length (acc++[h]))==(length trg))&&(directive==True) = substituteHelper t trg rpl [] (rlt++rpl) vars
+ | (isMatching (acc++[h]) trg)&&((length (acc++[h]))==(length trg)) = substituteHelper directiveTail trg rpl [] rlt vars
+ | (isMatching (acc++[h]) trg) = substituteHelper t trg rpl (acc++[h]) rlt vars
+ | otherwise = substituteHelper t trg rpl [] (rlt++acc++[h]) vars
+ where
+ (directive,directiveTail) = checkDirective t vars
-- 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)
@@ -215,14 +218,14 @@ 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])] -> 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
+composeObjects :: String -> [(String,[String])] -> [(String,String,String)] -> RootObjects
+composeObjects [] _ _ = E.throw EmptyQueryException
+composeObjects str svrobjs vars = composeObjectsHelper str 0 svrobjs vars
+composeObjectsHelper :: String -> Int -> [(String,[String])] -> [(String,String,String)] -> RootObjects
+composeObjectsHelper [] _ _ _ = E.throw EmptyQueryException
+composeObjectsHelper (h:t) l svrobjs vars
+ | h=='{'&&l==0 = separateRootObjects (extractLevel t) svrobjs vars -- find and separate every root object
+ | otherwise = composeObjectsHelper t l svrobjs vars
-- ...separate and determine operation
-- TODO: implement operations
-- determineOperation :: String -> (Operation,String)
@@ -236,24 +239,24 @@ composeObjectsHelper (h:t) l svrobjs
-- 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]++level) svrobjs) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs)
- | otherwise = separateRootObjectsHelper t (acc++[h]) svrobjs
+separateRootObjects :: String -> [(String,[String])] -> [(String,String,String)] -> [RootObject]
+separateRootObjects str svrobjs vars = separateRootObjectsHelper str "" svrobjs vars
+separateRootObjectsHelper :: String -> String -> [(String,[String])] -> [(String,String,String)] -> [RootObject]
+separateRootObjectsHelper [] _ _ _ = []
+separateRootObjectsHelper (h:t) acc svrobjs vars
+ | h=='{' = (((createNestedObject (acc++[h]++level) svrobjs vars) :: RootObject):separateRootObjectsHelper levelTail "" svrobjs vars)
+ | otherwise = separateRootObjectsHelper t (acc++[h]) svrobjs vars
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])] -> 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
+createNestedObject :: String -> [(String,[String])] -> [(String,String,String)] -> NestedObject
+createNestedObject str svrobjs vars = createNestedObjectHelper str "" svrobjs vars
+createNestedObjectHelper :: String -> String -> [(String,[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 vars
+ | h=='{' = (NestedObject ((parseAlias acc) :: Alias) ((parseName acc) :: Name) ((parseServerObject acc svrobjs) :: ServerObject) ((parseSubSelection acc) :: SubSelection) ((parseSubFields (extractLevel t) svrobjs vars) :: SubFields)) :: RootObject
+ | otherwise = createNestedObjectHelper t (acc++[h]) svrobjs vars
-- given object header without any braces, we want a name.
parseServerObject :: String -> [(String,[String])] -> ServerObject
parseServerObject [] svrobjs = readServerObject "" svrobjs
@@ -287,30 +290,42 @@ 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])] -> [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++[h]) [] 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 selectTail (acc1++[h]++subselect) [] svrobjs
- | h=='('&&(length acc2)>0 = parseSubFieldsHelper selectTail (acc2++[h]++subselect) [] svrobjs
- | h=='{'&&(length acc1)>0 = (Right $ (createNestedObject (acc1++[h]++level) svrobjs) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs
- | h=='{'&&(length acc2)>0 = (Right $ (createNestedObject (acc2++[h]++level) svrobjs) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs
- | h=='}' = parseSubFieldsHelper t acc1 acc2 svrobjs
- | (length acc2)>0 = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) [] svrobjs
- | otherwise = parseSubFieldsHelper t (acc1++[h]) [] svrobjs
+parseSubFields :: String -> [(String,[String])] -> [(String,String,String)] -> [Field]
+parseSubFields [] _ _ = []
+parseSubFields str svrobjs vars = parseSubFieldsHelper str "" "" svrobjs True vars
+parseSubFieldsHelper :: String -> String -> String -> [(String,[String])] -> Bool -> [(String,String,String)] -> [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 inc vars
+ | h==':' = parseSubFieldsHelper (removeLeadingSpaces t) (acc2++acc1++[h]) [] svrobjs inc vars
+ | h==' '&&(length acc1)>0 = parseSubFieldsHelper t [] acc1 svrobjs inc vars
+ | h==' ' = parseSubFieldsHelper t acc1 acc2 svrobjs inc vars
+ | h==','&&(length acc1)>0&&(inc==True) = (Left $ createScalarType acc1 :: Field):parseSubFieldsHelper t [] [] svrobjs True vars
+ | h==','&&(length acc1)>0 = parseSubFieldsHelper t [] [] svrobjs True vars
+ | h==','&&(length acc2)>0&&(inc==True) = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t [] [] svrobjs True vars
+ | h==','&&(length acc2)>0 = parseSubFieldsHelper t [] [] svrobjs True vars
+ | h=='('&&(length acc1)>0 = parseSubFieldsHelper selectTail (acc1++[h]++subselect) [] svrobjs inc vars
+ | h=='('&&(length acc2)>0 = parseSubFieldsHelper selectTail (acc2++[h]++subselect) [] svrobjs inc vars
+ | h=='{'&&(length acc1)>0&&(inc==True) = (Right $ (createNestedObject (acc1++[h]++level) svrobjs vars) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs True vars
+ | h=='{'&&(length acc1)>0 = parseSubFieldsHelper levelTail [] [] svrobjs True vars
+ | h=='{'&&(length acc2)>0&&(inc==True) = (Right $ (createNestedObject (acc2++[h]++level) svrobjs vars) :: Field):parseSubFieldsHelper levelTail [] [] svrobjs True vars
+ | h=='{'&&(length acc2)>0 = parseSubFieldsHelper levelTail [] [] svrobjs True vars
+ | h=='@'&&(directive==True) = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs True vars
+ | h=='@' = parseSubFieldsHelper directiveTail acc1 acc2 svrobjs False vars
+ | h=='}' = parseSubFieldsHelper t acc1 acc2 svrobjs inc vars
+ | (length acc2)>0&&inc==True = (Left $ createScalarType acc2 :: Field):parseSubFieldsHelper t (acc1++[h]) [] svrobjs True vars
+ | (length acc2)>0 = parseSubFieldsHelper t (acc1++[h]) [] svrobjs True vars
+ | otherwise = parseSubFieldsHelper t (acc1++[h]) [] svrobjs inc vars
where
(level,levelTail) = splitLevel t "" 0
(subselect,selectTail) = getSubSelection t
+ (directive,directiveTail) = checkDirective (h:t) vars
removeLeadingSpaces :: String -> String
removeLeadingSpaces [] = []
removeLeadingSpaces (h:t) = if h==' ' then removeLeadingSpaces t else (h:t)
@@ -330,6 +345,50 @@ splitLevel (h:t) acc l
| 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 = E.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 str chr = getPrefixHelper str chr ""
+getPrefixHelper :: String -> Char -> String -> String
+getPrefixHelper [] _ _ = ""
+getPrefixHelper (h:t) trg acc = if h==trg then acc else getPrefixHelper t trg (acc++[h])
+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 [] _ = E.throw InvalidVariableNameException
+getVariableValue ((name,typ,val):t) var
+ | (name==var)&&(typ=="Bool") = val
+ | (name==var) = E.throw MismatchedVariableTypeException
+ | otherwise = getVariableValue t var
-- pull level and leave out closing brace.
extractLevel :: String -> String
extractLevel [] = []
diff --git a/src/Components/Parsers/VariablesParser.hs b/src/Components/Parsers/VariablesParser.hs
index ba2cca9..a09cb1d 100644
--- a/src/Components/Parsers/VariablesParser.hs
+++ b/src/Components/Parsers/VariablesParser.hs
@@ -46,26 +46,27 @@ getQueryEpilogue :: String -> String
getQueryEpilogue [] = E.throw EmptyQueryException
getQueryEpilogue (h:t) = if (h=='{') then [] else h:(getQueryEpilogue t)
removeLeadingSpaces :: String -> String
-removeLeadingSpaces str = foldl (\y x -> if x==' ' then [] else y++[x]) [] str
+removeLeadingSpaces (h:t) = if (h==' ') then removeLeadingSpaces t else (h:t)
separateVariables :: Bool -> String -> Bool -> String -> String -> String -> [(String,String,Maybe String)]
-separateVariables _ [] _ _ _ [] = []
-separateVariables _ var _ [] _ [] = E.throw VariablesSyntaxException
-separateVariables _ var _ typ [] [] = if (isValidBaseType typ) then (var,typ,Nothing):[] else E.throw InvalidVariableTypeException
-separateVariables _ var _ typ dval [] = if (isValidBaseType typ) then (var,typ,Just dval):[] else E.throw InvalidVariableTypeException
+separateVariables _ [] _ _ _ [] = [] -- no variables
+separateVariables _ var _ [] _ [] = E.throw VariablesSyntaxException -- variable without type
+separateVariables _ var _ typ [] [] = if (isValidBaseType typ) then (var,typ,Nothing):[] else E.throw InvalidVariableTypeException -- variable without default value
+separateVariables _ var _ typ dval [] = if (isValidBaseType typ) then (var,typ,Just $ removeTailSpaces dval):[] else E.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 E.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) = E.throw InvalidVariableTypeException
- | (h=='$') = E.throw VariablesSyntaxException
- | (h==':') = E.throw VariablesSyntaxException
- | (h=='=') = E.throw VariablesSyntaxException
| (h/=',') = separateVariables var acc1 typ acc2 (acc3++[h]) t
- | otherwise = (acc1,acc2,if (length acc3)==0 then Nothing else (Just $ removeTailSpaces acc3)):(separateVariables False [] False [] [] 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 = foldr (\x y -> if x==' ' then [] else x:y) [] str
+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"] \ No newline at end of file
diff --git a/src/GraphQL.hs b/src/GraphQL.hs
index 5e8eb58..986efb3 100644
--- a/src/GraphQL.hs
+++ b/src/GraphQL.hs
@@ -205,7 +205,9 @@ processQueryStringWithVariables :: String -- ^ This is th
-> [(String,[String])] -- ^ unique server object name to list of database table names (which are exact references to table names).
-> [(String,String,[String])] -- ^ two database table names 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 with grouped sql query strings.
-processQueryStringWithVariables qry vars svrobjs sss sos sodn sor = checkObjectsToSqlWithVariables sss sos sodn sor (VP.parseVariables vars qry) $ checkStringToObjects svrobjs $ QP.processString qry
+processQueryStringWithVariables qry vars svrobjs sss sos sodn sor = checkObjectsToSqlWithVariables sss sos sodn sor dvars $ checkStringToObjectsWithVariables svrobjs dvars $ QP.processString qry
+ where
+ dvars = VP.parseVariables vars qry
{- |
Except being nested in a monad, this funcion is same as above.
@@ -359,7 +361,7 @@ processQueryStringWithJsonAndVariables :: (MonadIO m)
processQueryStringWithJsonAndVariables qry vars fp = do
(svrobjs,sss,sos,sodn,sor) <- IO.liftIO $ JP.fetchArguments fp
let dvars = VP.parseVariables vars qry
- return $ checkObjectsToSqlWithVariables sss sos sodn sor dvars $ checkStringToObjects svrobjs $ QP.processString qry
+ return $ checkObjectsToSqlWithVariables sss sos sodn sor dvars $ checkStringToObjectsWithVariables svrobjs dvars $ QP.processString qry
{- |
This is the function to call after casting PersistValues to Text from processQueryString of which you may find on my examples <https://github.com/jasonsychau/graphql-w-persistent page>.
diff --git a/src/GraphQLHelper.hs b/src/GraphQLHelper.hs
index 1596ac4..95acd66 100644
--- a/src/GraphQLHelper.hs
+++ b/src/GraphQLHelper.hs
@@ -10,10 +10,12 @@ import Model.ServerExceptions
checkStringToObjects :: [(String,[String])] -> String -> [RootObject]
-checkStringToObjects svrobjs str = if (QP.validateQuery str)==True then (QP.parseStringToObjects str svrobjs) else E.throw SyntaxException
+checkStringToObjects svrobjs str = if (QP.validateQuery str)==True then (QP.parseStringToObjects str svrobjs []) else E.throw SyntaxException
checkObjectsToSql :: [(String,[(String,String)])] -> [(String,[String])] -> [(String,[String])] -> [(String,String,[String])] -> [RootObject] -> ([RootObject],[[String]])
checkObjectsToSql sss sos sodn sor ros = if (SOV.checkObjectsAttributes reducedRobjs sss sos)==True then (reducedRobjs,QC.makeSqlQueries reducedRobjs sodn sor) else (E.throw InvalidObjectException)
where reducedRobjs = SOT.mergeDuplicatedRootObjects ros
+checkStringToObjectsWithVariables :: [(String,[String])] -> [(String,String,String)] -> String -> [RootObject]
+checkStringToObjectsWithVariables svrobjs vars str = if (QP.validateQuery str)==True then (QP.parseStringToObjects str svrobjs vars) else E.throw SyntaxException
checkObjectsToSqlWithVariables :: [(String,[(String,String)])] -> [(String,[String])] -> [(String,[String])] -> [(String,String,[String])] -> [(String,String,String)] -> [RootObject] -> ([RootObject],[[String]])
checkObjectsToSqlWithVariables sss sos sodn sor vars ros = if (SOV.checkObjectsAttributes valueObjects sss sos)==True then (valueObjects,QC.makeSqlQueries valueObjects sodn sor) else (E.throw InvalidObjectSubFieldException)
where
diff --git a/src/Model/ServerExceptions.hs b/src/Model/ServerExceptions.hs
index d7a1001..8c7d195 100644
--- a/src/Model/ServerExceptions.hs
+++ b/src/Model/ServerExceptions.hs
@@ -37,7 +37,8 @@ data QueryException = SyntaxException |
InvalidVariableTypeException |
ReadVariablesException |
VariablesSyntaxException |
- ValueInterpretationException
+ ValueInterpretationException |
+ InvalidDirectiveException
deriving Show
instance Exception QueryException \ No newline at end of file