module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where

import Control.Exception (throw)
import Data.Foldable (foldl',foldr')
import Text.JSON (
    JSValue(JSObject),
    JSObject,
    Result(Ok,Error),
    valFromObj,
    decode
  )
import Model.ServerExceptions (
    QueryException(
      ImportSchemaServerNameException,
      ImportSchemaServerNameException,
      ImportSchemaServerNameException,
      ImportSchemaException,
      ImportSchemaChildrenException,
      ImportSchemaPseudonymsException,
      ImportSchemaScalarFieldsException,
      ImportSchemaDatabaseTablesException,
      ImportSchemaObjectFieldsException,
      ImportSchemaDatabaseRelationshipsException,
      ImportSchemaDuplicateException
    )
  )


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