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.Foldable (foldl',foldr')
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,
countTableIds
)
processReturnedValues :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[(Int,Bool,String)]]] -> [[[[[Text]]]]] -> String
processReturnedValues sss sodn soa robjs tbls rlts = encodeStrict $ processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts
processReturnedValuesToJsonObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> [RootObject] -> [[[(Int,Bool,String)]]] -> [[[[[Text]]]]] -> JSObject (JSObject JSValue)
processReturnedValuesToJsonObject sss sodn soa robjs tbls rlts = toJSObject [("data", toJSObject [processReturnedValue sss sodn soa x y z | (x,y,z) <- zip3 robjs tbls rlts])]
processReturnedValue :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> RootObject -> [[(Int,Bool,String)]] -> [[[[Text]]]] -> (String, JSValue)
processReturnedValue sss sodn soa (NestedObject Nothing name sobj _ sfs) tbls rlts = (name, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts)
processReturnedValue sss sodn soa (NestedObject (Just alias) name sobj _ sfs) tbls rlts = (alias, showJSONs $ processSubFields sss sodn soa sobj tbls sfs rlts)
processSubFields :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[(Int,Bool,String)]] -> [Field] -> [[[[Text]]]] -> [JSValue]
processSubFields sss sodn soa sobj tbls (sf:sfs) (vRlt:rlts)
| all (\x -> (null x)||(null $ head x)) (vRlt:rlts) = []
| oneObject&&(null object)==False = (showJSON $ toJSObject object):(processSubFields sss sodn soa sobj tbls (sf:sfs) remData)
| oneObject = processSubFields sss sodn soa sobj tbls (sf:sfs) remData
| otherwise = [showJSON $ toJSObject x | x<-objects, (null x)==False]++(processSubFields sss sodn soa sobj tbls (sf:sfs) remData)
where
oneObject = all (\x -> (null x)||((snd3 $ head x)==False)) $ tail tbls
zDta = zip3 tbls (vRlt:rlts) idCounts
object = makeOneGQLObject sss sodn soa sobj tbls (sf:sfs) [fetchGraphQlRow dt idC | (_,dt,idC)<-zDta]
notEmptyQueryResults = [(x,y,z) | (x,y,z)<-zDta,(null x)==False,(null y)==False,(null $ head y)==False]
groupedData = foldl' (\z (x,y) ->if (null z)==True then [[(x,y)]] else if (null x)||((snd3 $ head x)==False) then ((init z)++[(last z)++[(x,y)]]) else (z++[[(x,y)]])) [] $ [(x,fetchGraphQlRow y z) | (x,y,z)<-notEmptyQueryResults]
labeledData = [unzip x | x<-groupedData]
objects = foldr (\(x,y) z -> (makeOneGQLObject sss sodn soa sobj x (sf:sfs) y):z) [] labeledData
remData = [removeDataRow x idC | (_, x, idC)<-zDta]
idCounts = if (null tbls)||(null $ head tbls) then [] else foldl' (\y x -> if (null x) then y++[0] else if (not $ snd3 $ head x) then y++[last y] else y++[countTableIds (thd3 $ head x) sodn]) [countTableIds (thd3 $ head $ head tbls) sodn] $ tail tbls
processSubFields _ _ _ _ _ _ [] = []
processSubFields _ _ _ _ _ [] _ = []
thd3 :: (a,b,c) -> c
thd3 (_,_,x) = x
snd3 :: (a,b,c) -> b
snd3 (_,x,_) = x
makeOneGQLObject :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[String],String)] -> [(String,[String],[String])] -> String -> [[(Int,Bool,String)]] -> [Field] -> [[[[Text]]]] -> [(String,JSValue)]
makeOneGQLObject _ _ _ _ [] _ _ = throw EOFDataProcessingException
makeOneGQLObject _ _ _ _ ([]:_) _ _ = throw EOFDataProcessingException
makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias "__typename" trans arg)):b) dat = (getScalarFieldLabel $ ScalarType alias "__typename" trans arg, showJSON $ pack $ translateTableToObject (thd3 $ head $ head tbls) sodn):(makeOneGQLObject sss sodn soa sobj tbls b dat)
makeOneGQLObject sss sodn soa sobj tbls ((Left (ScalarType alias name trans arg)):b) ((((i:j):k):l):m) = (getScalarFieldLabel $ ScalarType alias name trans arg, castJSType (findPrimitiveScalarTypeType (translateTableToObject (thd3 $ head $ head tbls) sodn) name trans arg sss) i):(makeOneGQLObject sss sodn soa sobj tbls b (((j:k):l):m))
makeOneGQLObject sss sodn soa sobj tbls ((Right (Left (NestedObject alias name nso ss sfs))):b) ((j:k):l) = ((getNestedObjectFieldLabel $ NestedObject alias name nso ss sfs), showJSONs (processSubFields sss sodn soa nso nxtTbls sfs nxtData)):(makeOneGQLObject sss sodn soa sobj remTbls b remData)
where
(nxtTbls,nxtData,remTbls,remData) = separateObjectData tbls ((j:k):l)
makeOneGQLObject sss sodn soa sobj tbls ((Right (Right (InlinefragmentObject ifo sfs))):b) dat
| (isServerObjectTable (thd3 $ head $ head tbls) ifo sodn soa)==True = makeOneGQLObject sss sodn soa sobj tbls (sfs++b) dat
| otherwise = makeOneGQLObject sss sodn soa sobj tbls b dat
makeOneGQLObject _ _ _ _ _ [] ((([]:_):_):_) = []
makeOneGQLObject _ _ _ _ _ _ (([]:_):_) = []
makeOneGQLObject _ _ _ _ _ ((Right (Left _)):[]) ([]:_) = throw EOFDataProcessingException
makeOneGQLObject _ _ _ _ _ _ ([]:_) = []
makeOneGQLObject _ _ _ _ _ _ [] = []
makeOneGQLObject _ _ _ _ _ [] _ = []
makeOneGQLObject _ _ _ _ _ ((Left _):_) ((([]:_):_):_) = throw EOFDataProcessingException
separateObjectData :: [[(Int,Bool,String)]] -> [[[[Text]]]] -> ([[(Int,Bool,String)]],[[[[Text]]]],[[(Int,Bool,String)]],[[[[Text]]]])
separateObjectData info dat = foldl' (\(nTbls,nDt,rTbls,rDt) (meta,ndt)-> let
mty = null meta
one = (length meta)==1
newMeta = if mty||one then [] else (lvl,fst,tbl):(take (objQryCount-1) flwObjs)
newData = if mty then [] else if fFst then take (length newMeta) nxtDat else if tblPos<=((length newMeta)-1) then take ((length nxtObjs)-tblPos) ndt else []
remMeta = if mty then [] else if one then meta else (head meta):(drop objQryCount $ nxtObjs)
remData = if mty then [] else if fFst then (head ndt):(drop objQryCount nxtDat) else if tblPos<=(objQryCount-1) then [] else ndt
nxtObjs = tail meta
flwObjs = tail nxtObjs
nxtDat = tail ndt
(lvl,fst,tbl) = head nxtObjs
objQryCount = foldr' (\(nlvl,nfst,ntbl) y->if nlvl<=lvl then 1 else y+1) 1 flwObjs
tblPos = foldr' (\(idx,(_,fst,_)) y->if fst then idx else y) ((length nxtObjs)-1) $ zip [0..] $ nxtObjs
(_,fFst,_) = head meta
in
(nTbls++[newMeta],nDt++[newData],rTbls++[remMeta],rDt++[remData])) ([],[],[],[]) $ zip info dat
findPrimitiveScalarTypeType :: ServerObject -> String -> Transformation -> Argument -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> String
findPrimitiveScalarTypeType sobj name trans arg ((obj,flds):rst)
| sobj==obj = findScalarTypeType name trans arg flds
| otherwise = findPrimitiveScalarTypeType sobj name trans arg rst
findPrimitiveScalarTypeType _ _ _ _ [] = throw InvalidObjectException
findScalarTypeType :: String -> Transformation -> Argument -> [(String,String,[(String,[(String,String,String,String)])])] -> String
findScalarTypeType name Nothing _ ((sName,sType,opts):rst)
| name==sName = sType
| otherwise = findScalarTypeType name Nothing Nothing rst
findScalarTypeType name (Just trans) arg ((sName,sType,args):rst)
| name==sName = findArgumentOptionType trans arg args
| otherwise = findScalarTypeType name (Just trans) arg rst
findScalarTypeType _ _ _ [] = throw InvalidScalarException
findArgumentOptionType :: String -> Argument -> [(String,[(String,String,String,String)])] -> String
findArgumentOptionType 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
findArgumentOptionType _ _ [] = throw InvalidArgumentException
findOptionType :: String -> [(String,String,String,String)] -> String
findOptionType arg ((oname,typ,_,_):rst)
| arg==oname = typ
| otherwise = findOptionType arg rst
findOptionType _ [] = throw InvalidArgumentException
fetchGraphQlRow :: [[[Text]]] -> Int -> [[[Text]]]
fetchGraphQlRow _ 0 = []
fetchGraphQlRow [] _ = []
fetchGraphQlRow ([]:_) _ = []
fetchGraphQlRow rlts idCols = if (all ((==) nll) firstIds) then [] else
[[drop idCols rw | rw<-qryRlt, (take idCols rw)==firstIds] | qryRlt<-rlts]
where
firstIds = take idCols $ head $ head rlts
nll = pack "Unexpected null"
removeDataRow :: [[[Text]]] -> Int -> [[[Text]]]
removeDataRow _ 0 = []
removeDataRow ([]:_) _ = []
removeDataRow rlts idCols = [[rw | rw<-qryRlt, (take idCols rw)/=firstIds] | qryRlt<-rlts]
where firstIds = take idCols $ head $ head rlts
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