ServerSchemaJsonParser.hs

module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where

import qualified Control.Exception as E
import Text.JSON
import Model.ServerExceptions


fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String)])],[(String,[String])],[(String,[String])],[(String,String,[String])])
fetchArguments fp = do 
    schema <- Prelude.readFile fp
    let parsed = schema
    return $ parseSchema parsed
parseSchema :: 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) = E.throw ImportSchemaException
checkJSValueListValue (Ok a) = a
parseHelper :: [(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])])
parseHelper svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor)
parseHelper svrobjs sss sos sdbn sor (obj:t) = parseHelper ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,tables):sdbn) (sor++(processRelationships relationships)) t
  where
    name = getServerName (valFromObj "servername" obj :: Result String)
    pseudonyms = getStringList (valFromObj "pseudonyms" obj :: Result [String]) 0
    scalars = checkScalars (valFromObj "scalarfields" obj :: Result [JSValue])
    nestedobjects = getStringList (valFromObj "objectfields" obj :: Result [String]) 1
    tables = getStringList (valFromObj "databasetables" obj :: Result [String]) 2
    relationships = getListStringList (valFromObj "databaserelationships" obj :: Result [[String]])
getServerName :: Result String -> String
getServerName (Error str) = E.throw ImportSchemaServerNameException
getServerName (Ok name) = name
getStringList :: Result [String] -> Int -> [String]
getStringList (Ok rlt) _ = rlt
getStringList _ t
    | t==0 = E.throw ImportSchemaPseudonymsException
    | t==1 = E.throw ImportSchemaObjectFieldsException
    | t==2 = E.throw ImportSchemaDatabaseTablesException
    | otherwise = E.throw ImportSchemaException
getListStringList :: Result [[String]] -> [[String]]
getListStringList (Error str) = E.throw ImportSchemaDatabaseRelationshipsException
getListStringList (Ok rlt) = rlt
checkScalars :: Result [JSValue] -> [(String,String)]
checkScalars (Error str) = E.throw ImportSchemaScalarFieldsException
checkScalars (Ok a) = getScalars a
getScalars :: [JSValue] -> [(String,String)]
getScalars [] = []
getScalars ((JSObject obj):t) = (getString (valFromObj "name" obj :: Result String),getType (valFromObj "type" obj :: Result String)):(getScalars t)
getString :: Result String -> String
getString (Error str) = E.throw ImportSchemaScalarFieldsException
getString (Ok a) = a
getType :: Result String -> String
getType (Error str) = E.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 = E.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 _ = E.throw ImportSchemaException
getThird :: [String] -> String
getThird (h1:h2:h3:t) = h3
getThird _ = E.throw ImportSchemaException