ServerSchemaJsonParser.hs

module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where

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


fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
fetchArguments fp = do 
    schema <- Prelude.readFile fp
    return $ parseSchema schema
parseSchema :: String -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
parseSchema str = parseHelper $ checkJSValueListValue (decode str :: Result (JSObject JSValue))
checkJSValueListValue :: Result (JSObject JSValue) -> (JSObject JSValue)
checkJSValueListValue (Error str) = throw ImportSchemaException
checkJSValueListValue (Ok a) = a
parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])],[(String,[String],[String])])
parseHelper json = (svrobjs,sss,sos,sdbn,sor,soa)
  where
    (svrobjs,sss,sos,sdbn,sor) = parsePrimitivesIterator [] [] [] [] [] $ getObjects (valFromObj "PrimitiveObjects" json :: Result [JSObject JSValue])
    soa = parseParentsIterator [] $ getObjects (valFromObj "ParentalObjects" json :: Result [JSObject JSValue])
parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String)])] -> [(String,[String])] -> [(String,String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,String)],[(String,String,[String])])
parsePrimitivesIterator svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor)
parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,table):sdbn) (sor++(processRelationships relationships)) t
  where
    name = getString (valFromObj "ServerName" obj :: Result String) 0
    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
    scalars = checkScalars (valFromObj "ScalarFields" obj :: Result [JSValue])
    nestedobjects = getStringList (valFromObj "ObjectFields" obj :: Result [String]) 1
    table = getString (valFromObj "DatabaseTable" obj :: Result String) 2
    relationships = getListStringList (valFromObj "DatabaseRelationships" obj :: Result [[String]])
parseParentsIterator :: [(String,[String],[String])] -> [JSObject JSValue] -> [(String,[String],[String])]
parseParentsIterator soa [] = soa
parseParentsIterator soa (obj:t) = parseParentsIterator ((name,pseudonyms,children):soa) t
  where
    name = getString (valFromObj "ServerName" obj :: Result String) 0
    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
    children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 2
getObjects :: Result [JSObject JSValue] -> [JSObject JSValue]
getObjects (Error _) = throw ImportSchemaServerNameException
getObjects (Ok objects) = objects
getString :: Result String -> Int -> String
getString (Ok str) _ = str
getString (Error str) t
  | t==0 = throw ImportSchemaServerNameException
  | t==1 = throw ImportSchemaScalarFieldsException
  | t==2 = throw ImportSchemaDatabaseTablesException
  | otherwise = throw ImportSchemaException
getStringList :: Result [String] -> Int -> [String]
getStringList (Ok rlt) _ = rlt
getStringList _ t
  | t==0 = throw ImportSchemaPseudonymsException
  | t==1 = throw ImportSchemaObjectFieldsException
  | t==2 = throw ImportSchemaChildrenException
  | otherwise = throw ImportSchemaException
getListStringList :: Result [[String]] -> [[String]]
getListStringList (Error str) = throw ImportSchemaDatabaseRelationshipsException
getListStringList (Ok rlt) = rlt
checkScalars :: Result [JSValue] -> [(String,String)]
checkScalars (Error str) = throw ImportSchemaScalarFieldsException
checkScalars (Ok a) = getScalars a
getScalars :: [JSValue] -> [(String,String)]
getScalars [] = []
getScalars ((JSObject obj):t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String)):(getScalars t)
getType :: Result String -> String
getType (Error str) = throw ImportSchemaScalarFieldsException
getType (Ok a)
    | a=="Text" = a
    | a=="ByteString" = a
    | a=="Int" = a
    | a=="Double" = a
    | a=="Rational" = a
    | a=="Bool" = a
    | a=="Day" = a
    | a=="TimeOfDay" = a
    | a=="UTCTime" = a
    | otherwise = throw ImportSchemaScalarFieldsException
processRelationships :: [[String]] -> [(String,String,[String])]
processRelationships lst = foldr (\x y -> (getFirst x,getThird x, x):y) [] lst
getFirst :: [String] -> String
getFirst (h:t) = h
getFirst _ = throw ImportSchemaException
getThird :: [String] -> String
getThird (h1:h2:h3:t) = h3
getThird _ = throw ImportSchemaException