Mercurial > urweb

comparison src/cjr_print.sml @ 275:73456bfde988

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Validating schema of a live database
author Adam Chlipala <adamc@hcoop.net>
date Tue, 02 Sep 2008 14:40:57 -0400
parents e4baf03a3a64
children ed4af33681d8
comparison
equal deleted inserted replaced
274:e4baf03a3a64 275:73456bfde988
690 end 690 end
691 | DTable (x, _) => box [string "/* SQL table ", 691 | DTable (x, _) => box [string "/* SQL table ",
692 string x, 692 string x,
693 string " */", 693 string " */",
694 newline] 694 newline]
695 | DDatabase s => box [string "void lw_db_init(lw_context ctx) {", 695 | DDatabase s => box [string "static void lw_db_validate(lw_context);",
696 newline, 696 newline,
697 string "PGresult *res;", 697 newline,
698 string "void lw_db_init(lw_context ctx) {",
698 newline, 699 newline,
699 string "PGconn *conn = PQconnectdb(\"", 700 string "PGconn *conn = PQconnectdb(\"",
700 string (String.toString s), 701 string (String.toString s),
701 string "\");", 702 string "\");",
702 newline, 703 newline,
718 newline, 719 newline,
719 string "}", 720 string "}",
720 newline, 721 newline,
721 string "lw_set_db(ctx, conn);", 722 string "lw_set_db(ctx, conn);",
722 newline, 723 newline,
724 string "lw_db_validate(ctx);",
725 newline,
723 string "}", 726 string "}",
724 newline, 727 newline,
725 newline, 728 newline,
726 string "void lw_db_close(lw_context ctx) {", 729 string "void lw_db_close(lw_context ctx) {",
727 newline, 730 newline,
733 datatype 'a search = 736 datatype 'a search =
734 Found of 'a 737 Found of 'a
735 | NotFound 738 | NotFound
736 | Error 739 | Error
737 740
741 fun p_sqltype' env (tAll as (t, loc)) =
742 case t of
743 TFfi ("Basis", "int") => "int8"
744 | TFfi ("Basis", "float") => "float8"
745 | TFfi ("Basis", "string") => "text"
746 | TFfi ("Basis", "bool") => "bool"
747 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
748 Print.eprefaces' [("Type", p_typ env tAll)];
749 "ERROR")
750
751 fun p_sqltype env t = string (p_sqltype' env t)
738 752
739 fun p_file env (ds, ps) = 753 fun p_file env (ds, ps) =
740 let 754 let
741 val (pds, env) = ListUtil.foldlMap (fn (d, env) => 755 val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
742 (p_decl env d, 756 (p_decl env d,
1202 string "}"] 1216 string "}"]
1203 ] 1217 ]
1204 end 1218 end
1205 1219
1206 val pds' = map p_page ps 1220 val pds' = map p_page ps
1221
1222 val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
1223 | _ => NONE) ds
1224
1225 val validate =
1226 box [string "static void lw_db_validate(lw_context ctx) {",
1227 newline,
1228 string "PGconn *conn = lw_get_db(ctx);",
1229 newline,
1230 string "PGresult *res;",
1231 newline,
1232 newline,
1233 p_list_sep newline
1234 (fn (s, xts) =>
1235 let
1236 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
1237 ^ s ^ "'"
1238
1239 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
1240 s,
1241 "') AND (",
1242 String.concatWith " OR "
1243 (map (fn (x, t) =>
1244 String.concat ["(attname = 'lw_",
1245 CharVector.map
1246 Char.toLower x,
1247 "' AND atttypid = (SELECT oid FROM pg_type",
1248 " WHERE typname = '",
1249 p_sqltype' env t,
1250 "'))"]) xts),
1251 ")"]
1252
1253 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
1254 s,
1255 "') AND attnum >= 0"]
1256 in
1257 box [string "res = PQexec(conn, \"",
1258 string q,
1259 string "\");",
1260 newline,
1261 newline,
1262 string "if (res == NULL) {",
1263 newline,
1264 box [string "PQfinish(conn);",
1265 newline,
1266 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1267 newline],
1268 string "}",
1269 newline,
1270 newline,
1271 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1272 newline,
1273 box [string "char msg[1024];",
1274 newline,
1275 string "strncpy(msg, PQerrorMessage(conn), 1024);",
1276 newline,
1277 string "msg[1023] = 0;",
1278 newline,
1279 string "PQclear(res);",
1280 newline,
1281 string "PQfinish(conn);",
1282 newline,
1283 string "lw_error(ctx, FATAL, \"Query failed:\\n",
1284 string q,
1285 string "\\n%s\", msg);",
1286 newline],
1287 string "}",
1288 newline,
1289 newline,
1290 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
1291 newline,
1292 box [string "PQclear(res);",
1293 newline,
1294 string "PQfinish(conn);",
1295 newline,
1296 string "lw_error(ctx, FATAL, \"Table '",
1297 string s,
1298 string "' does not exist.\");",
1299 newline],
1300 string "}",
1301 newline,
1302 newline,
1303 string "PQclear(res);",
1304 newline,
1305
1306 string "res = PQexec(conn, \"",
1307 string q',
1308 string "\");",
1309 newline,
1310 newline,
1311 string "if (res == NULL) {",
1312 newline,
1313 box [string "PQfinish(conn);",
1314 newline,
1315 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1316 newline],
1317 string "}",
1318 newline,
1319 newline,
1320 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1321 newline,
1322 box [string "char msg[1024];",
1323 newline,
1324 string "strncpy(msg, PQerrorMessage(conn), 1024);",
1325 newline,
1326 string "msg[1023] = 0;",
1327 newline,
1328 string "PQclear(res);",
1329 newline,
1330 string "PQfinish(conn);",
1331 newline,
1332 string "lw_error(ctx, FATAL, \"Query failed:\\n",
1333 string q',
1334 string "\\n%s\", msg);",
1335 newline],
1336 string "}",
1337 newline,
1338 newline,
1339 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
1340 string (Int.toString (length xts)),
1341 string "\")) {",
1342 newline,
1343 box [string "PQclear(res);",
1344 newline,
1345 string "PQfinish(conn);",
1346 newline,
1347 string "lw_error(ctx, FATAL, \"Table '",
1348 string s,
1349 string "' has the wrong column types.\");",
1350 newline],
1351 string "}",
1352 newline,
1353 newline,
1354 string "PQclear(res);",
1355 newline,
1356 newline,
1357
1358 string "res = PQexec(conn, \"",
1359 string q'',
1360 string "\");",
1361 newline,
1362 newline,
1363 string "if (res == NULL) {",
1364 newline,
1365 box [string "PQfinish(conn);",
1366 newline,
1367 string "lw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
1368 newline],
1369 string "}",
1370 newline,
1371 newline,
1372 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1373 newline,
1374 box [string "char msg[1024];",
1375 newline,
1376 string "strncpy(msg, PQerrorMessage(conn), 1024);",
1377 newline,
1378 string "msg[1023] = 0;",
1379 newline,
1380 string "PQclear(res);",
1381 newline,
1382 string "PQfinish(conn);",
1383 newline,
1384 string "lw_error(ctx, FATAL, \"Query failed:\\n",
1385 string q'',
1386 string "\\n%s\", msg);",
1387 newline],
1388 string "}",
1389 newline,
1390 newline,
1391 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
1392 string (Int.toString (length xts)),
1393 string "\")) {",
1394 newline,
1395 box [string "PQclear(res);",
1396 newline,
1397 string "PQfinish(conn);",
1398 newline,
1399 string "lw_error(ctx, FATAL, \"Table '",
1400 string s,
1401 string "' has extra columns.\");",
1402 newline],
1403 string "}",
1404 newline,
1405 newline,
1406 string "PQclear(res);",
1407 newline]
1408 end) tables,
1409 string "}"]
1207 in 1410 in
1208 box [string "#include <stdio.h>", 1411 box [string "#include <stdio.h>",
1209 newline, 1412 newline,
1210 string "#include <stdlib.h>", 1413 string "#include <stdlib.h>",
1211 newline, 1414 newline,
1233 string "void lw_handle(lw_context ctx, char *request) {", 1436 string "void lw_handle(lw_context ctx, char *request) {",
1234 newline, 1437 newline,
1235 p_list_sep newline (fn x => x) pds', 1438 p_list_sep newline (fn x => x) pds',
1236 newline, 1439 newline,
1237 string "}", 1440 string "}",
1441 newline,
1442 newline,
1443 validate,
1238 newline] 1444 newline]
1239 end
1240
1241 fun p_sqltype env (tAll as (t, loc)) =
1242 let
1243 val s = case t of
1244 TFfi ("Basis", "int") => "int8"
1245 | TFfi ("Basis", "float") => "float8"
1246 | TFfi ("Basis", "string") => "text"
1247 | TFfi ("Basis", "bool") => "bool"
1248 | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type";
1249 Print.eprefaces' [("Type", p_typ env tAll)];
1250 "ERROR")
1251 in
1252 string s
1253 end 1445 end
1254 1446
1255 fun p_sql env (ds, _) = 1447 fun p_sql env (ds, _) =
1256 let 1448 let
1257 val (pps, _) = ListUtil.foldlMap 1449 val (pps, _) = ListUtil.foldlMap
1262 box [string "CREATE TABLE ", 1454 box [string "CREATE TABLE ",
1263 string s, 1455 string s,
1264 string "(", 1456 string "(",
1265 p_list (fn (x, t) => 1457 p_list (fn (x, t) =>
1266 box [string "lw_", 1458 box [string "lw_",
1267 string x, 1459 string (CharVector.map Char.toLower x),
1268 space,
1269 string ":",
1270 space, 1460 space,
1271 p_sqltype env t, 1461 p_sqltype env t,
1272 space, 1462 space,
1273 string "NOT", 1463 string "NOT",
1274 space, 1464 space,