implementation module iTasks.API.Extensions.SQLDatabase import iTasks, Database.SQL, Database.SQL.MySQL, Database.SQL.SQLite, Data.Error, Data.Func, System.FilePath import iTasks._Framework.IWorld, iTasks._Framework.SDS import qualified Data.Map //Extend Resource type for mysql resources :: *Resource | MySQLResource *(!*MySQLCursor, !*MySQLConnection, !*MySQLContext) | SQLiteResource *(!*SQLiteCursor, !*SQLiteConnection, !*SQLiteContext) derive class iTask SQLDatabaseDef, SQLDatabase, SQLValue, SQLTime, SQLDate, SQLTable, SQLColumn, SQLColumnType sqlShare :: String (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur) (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> RWShared (SQLDatabaseDef,p) r w sqlShare name readFun writeFun = createReadWriteSDS "SQLShares" name (readFunSQL readFun) (writeFunSQL writeFun) readFunSQL :: (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur) (SQLDatabaseDef,p) *IWorld -> (!MaybeError TaskException r,!*IWorld) readFunSQL fun (MySQLDatabase db,p) iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = fun p cur # iworld = closeMySQLDB cur con cxt iworld = case res of (Ok v) = (Ok v,iworld) (Error e) = (Error (exception e),iworld) readFunSQL fun (SQLiteDatabase path,p) iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = fun p cur # iworld = closeSQLiteDB cur con cxt iworld = case res of (Ok v) = (Ok v,iworld) (Error e) = (Error (exception e),iworld) writeFunSQL :: (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) (SQLDatabaseDef,p) w *IWorld -> (!MaybeError TaskException (SDSNotifyPred (SQLDatabaseDef,p)),!*IWorld) writeFunSQL fun (MySQLDatabase db,p) w iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = fun p w cur # iworld = closeMySQLDB cur con cxt iworld = case res of (Ok _) = (Ok (const True),iworld) (Error e) = (Error (exception e),iworld) writeFunSQL fun (SQLiteDatabase path,p) w iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = fun p w cur # iworld = closeSQLiteDB cur con cxt iworld = case res of (Ok _) = (Ok (const True),iworld) (Error e) = (Error (exception e),iworld) sqlExecute :: SQLDatabaseDef [String] (A.*cur: *cur -> *(MaybeErrorString a,*cur) | SQLCursor cur) -> Task a | iTask a sqlExecute (MySQLDatabase db) touchIds queryFun = mkInstantTask eval where eval _ iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = queryFun cur # iworld = closeMySQLDB cur con cxt iworld = case res of Error e = (Error (exception e), iworld) Ok v = (Ok v,iworld) sqlExecute (SQLiteDatabase path) touchIds queryFun = mkInstantTask eval where eval _ iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (res,cur) = queryFun cur # iworld = closeSQLiteDB cur con cxt iworld = case res of Error e = (Error (exception e), iworld) Ok v = (Ok v,iworld) execSelect :: SQLStatement [SQLValue] *cur -> *(MaybeErrorString [SQLRow],*cur) | SQLCursor cur execSelect query values cur # (err,cur) = execute query values cur | isJust err = (Error (toString (fromJust err)),cur) # (err,rows,cur) = fetchAll cur | isJust err = (Error (toString (fromJust err)),cur) = (Ok rows,cur) execInsert :: SQLStatement [SQLValue] *cur -> *(MaybeErrorString Int,*cur) | SQLCursor cur execInsert query values cur # (err,cur) = execute query values cur | isJust err = (Error (toString (fromJust err)),cur) # (err,id,cur) = insertId cur | isJust err = (Error (toString (fromJust err)),cur) = (Ok id,cur) execDelete :: SQLStatement [SQLValue] *cur -> *(MaybeErrorString (),*cur) | SQLCursor cur execDelete query values cur # (err,cur) = execute query values cur | isJust err = (Error (toString (fromJust err)),cur) = (Ok (),cur) sqlExecuteSelect :: SQLDatabaseDef SQLStatement ![SQLValue] -> Task [SQLRow] sqlExecuteSelect db query values = sqlExecute db [] (execSelect query values) sqlSelectShare :: String SQLStatement ![SQLValue] -> ROShared SQLDatabaseDef [SQLRow] sqlSelectShare name query values = sdsTranslate "sqlSelectShare" (\db -> (db,())) (createReadWriteSDS "SQLShares" name (readFunSQL readFun) write) where readFun () cur # (err,cur) = execute query values cur | isJust err = (Error (toString (fromJust err)),cur) # (err,rows,cur) = fetchAll cur | isJust err = (Error (toString (fromJust err)),cur) = (Ok rows,cur) write _ () iworld = (Ok (const True),iworld) sqlTables :: ROShared SQLDatabaseDef [SQLTableName] sqlTables = createReadOnlySDSError read where read (MySQLDatabase db) iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (err,tables,cur) = listTables cur | isJust err = (Error (exception (toString (fromJust err))),iworld) # iworld = closeMySQLDB cur con cxt iworld = (Ok tables,iworld) read (SQLiteDatabase path) iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (err,tables,cur) = listTables cur | isJust err = (Error (exception (toString (fromJust err))),iworld) # iworld = closeSQLiteDB cur con cxt iworld = (Ok tables,iworld) sqlTableDefinition :: ROShared (SQLDatabaseDef,SQLTableName) SQLTable sqlTableDefinition = createReadOnlySDSError read where read (MySQLDatabase db,tablename) iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (err,mbTable,cur) = describeTable tablename cur | isJust err = (Error (exception (toString (fromJust err))),iworld) # iworld = closeMySQLDB cur con cxt iworld = (Ok (fromJust mbTable),iworld) read (SQLiteDatabase path,tablename) iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (exception e), iworld) Ok (cur,con,cxt) # (err,mbTable,cur) = describeTable tablename cur | isJust err = (Error (exception (toString (fromJust err))),iworld) # iworld = closeSQLiteDB cur con cxt iworld = (Ok (fromJust mbTable),iworld) sqlExecuteCreateTable :: SQLDatabaseDef SQLTable -> Task () sqlExecuteCreateTable (MySQLDatabase db) table = mkInstantTask eval where eval _ iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (dynamic e,toString e), iworld) Ok (cur,con,cxt) # (res,cur) = createTable table cur # iworld = closeMySQLDB cur con cxt iworld = case res of Just e = (Error (dynamic e,toString e), iworld) Nothing = (Ok (), iworld) sqlExecuteCreateTable (SQLiteDatabase path) table = mkInstantTask eval where eval _ iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (dynamic e,toString e), iworld) Ok (cur,con,cxt) # (res,cur) = createTable table cur # iworld = closeSQLiteDB cur con cxt iworld = case res of Just e = (Error (dynamic e,toString e), iworld) Nothing = (Ok (), iworld) sqlExecuteDropTable :: SQLDatabaseDef SQLTableName -> Task () sqlExecuteDropTable (MySQLDatabase db) tablename = mkInstantTask eval where eval _ iworld # (mbOpen,iworld) = openMySQLDB db iworld = case mbOpen of Error e = (Error (dynamic e,toString e), iworld) Ok (cur,con,cxt) # (res,cur) = deleteTable tablename cur # iworld = closeMySQLDB cur con cxt iworld = case res of Just e = (Error (dynamic e,toString e), iworld) Nothing = (Ok (), iworld) sqlExecuteDropTable (SQLiteDatabase path) tablename = mkInstantTask eval where eval _ iworld # db = {SQLDatabase|database=path,host=Nothing,username=Nothing,password=Nothing} # (mbOpen,iworld) = openSQLiteDB db iworld = case mbOpen of Error e = (Error (dynamic e,toString e), iworld) Ok (cur,con,cxt) # (res,cur) = deleteTable tablename cur # iworld = closeSQLiteDB cur con cxt iworld = case res of Just e = (Error (dynamic e,toString e), iworld) Nothing = (Ok (), iworld) openMySQLDB :: !SQLDatabase !*IWorld -> (MaybeErrorString (!*MySQLCursor, !*MySQLConnection, !*MySQLContext), !*IWorld) openMySQLDB db iworld=:{IWorld|resources=Just (MySQLResource con)} = (Ok con, {IWorld|iworld & resources=Nothing}) openMySQLDB db iworld=:{IWorld|resources=Nothing} # iworld=:{IWorld|world} = {IWorld|iworld & resources = Nothing} # (err,mbContext,world) = openContext world | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) # (err,mbConn,context) = openConnection db (fromJust mbContext) | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) # (err,mbCursor,connection) = openCursor (fromJust mbConn) | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) = (Ok (fromJust mbCursor,connection, context),{IWorld|iworld & world = world}) openMySQLDB db iworld = openMySQLDB db (closeCurrentResource iworld) closeMySQLDB :: !*MySQLCursor !*MySQLConnection !*MySQLContext !*IWorld -> *IWorld closeMySQLDB cursor connection context iworld=:{IWorld|resources=Nothing} = {IWorld|closeCurrentResource iworld & resources=Just (MySQLResource (cursor,connection,context))} openSQLiteDB :: !SQLDatabase !*IWorld -> (MaybeErrorString (!*SQLiteCursor, !*SQLiteConnection, !*SQLiteContext), !*IWorld) openSQLiteDB db iworld=:{IWorld|resources=Just (SQLiteResource con)} = (Ok con, {IWorld|iworld & resources=Nothing}) openSQLiteDB db iworld=:{IWorld|resources=Nothing} # iworld=:{IWorld|world,server={paths={dataDirectory}}} = {IWorld|iworld & resources = Nothing} # db = {db & database = dataDirectory db.database} # (err,mbContext,world) = openContext world | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) # (err,mbConn,context) = openConnection db (fromJust mbContext) | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) # (err,mbCursor,connection) = openCursor (fromJust mbConn) | isJust err = (Error (toString (fromJust err)),{IWorld|iworld & world = world}) = (Ok (fromJust mbCursor,connection, context),{IWorld|iworld & world = world}) openSQLiteDB db iworld = openSQLiteDB db (closeCurrentResource iworld) closeSQLiteDB :: !*SQLiteCursor !*SQLiteConnection !*SQLiteContext !*IWorld -> *IWorld closeSQLiteDB cursor connection context iworld=:{IWorld|resources=Nothing} = {IWorld|closeCurrentResource iworld & resources=Just (SQLiteResource (cursor,connection,context))} closeCurrentResource :: !*IWorld -> *IWorld closeCurrentResource iworld=:{IWorld|resources=Nothing} = iworld closeCurrentResource iworld=:{IWorld|resources=Just (SQLiteResource (cursor,connection,context)),world} # (err,connection) = closeCursor cursor connection # (err,context) = closeConnection connection context # (err,world) = closeContext context world = {IWorld|iworld & resources=Nothing, world = world} closeCurrentResource iworld=:{IWorld|resources=Just (MySQLResource (cursor,connection,context)),world} # (err,connection) = closeCursor cursor connection # (err,context) = closeConnection connection context # (err,world) = closeContext context world = {IWorld|iworld & resources=Nothing, world = world}