Mercurial > urweb

comparison src/postgres.sml @ 2176:d2a98983f502

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Start of support for surviving database-server restarts, for Postgres
author Adam Chlipala <adam@chlipala.net>
date Sat, 17 Oct 2015 10:49:25 -0400
parents 661b531f55bd
children 00cf8214c2e3
comparison
equal deleted inserted replaced
2175:3ffef52d549c 2176:d2a98983f502
1 (* Copyright (c) 2008-2010, Adam Chlipala 1 (* Copyright (c) 2008-2010, 2015, Adam Chlipala
2 * All rights reserved. 2 * All rights reserved.
3 * 3 *
4 * Redistribution and use in source and binary forms, with or without 4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met: 5 * modification, are permitted provided that the following conditions are met:
6 * 6 *
518 newline, 518 newline,
519 string "msg[1023] = 0;", 519 string "msg[1023] = 0;",
520 newline, 520 newline,
521 string "PQfinish(conn);", 521 string "PQfinish(conn);",
522 newline, 522 newline,
523 string "uw_error(ctx, BOUNDED_RETRY, ", 523 string "uw_error(ctx, FATAL, ",
524 string "\"Connection to Postgres server failed: %s\", msg);"], 524 string "\"Connection to Postgres server failed: %s\", msg);"],
525 newline, 525 newline,
526 string "}", 526 string "}",
527 newline, 527 newline,
528 string "uw_set_db(ctx, conn);", 528 string "uw_set_db(ctx, conn);",
610 string ")"] 610 string ")"]
611 in 611 in
612 getter t 612 getter t
613 end 613 end
614 614
615 fun queryCommon {loc, query, cols, doCols} = 615 fun queryCommon {loc, query, cols, doCols, runit} =
616 box [string "int n, i;", 616 box [string "int n, i;",
617 newline, 617 newline,
618 newline, 618 newline,
619 619
620 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", 620 string "if (res == NULL) {",
621 box [newline,
622 string "if (uw_try_reconnecting_if_at_most_one(ctx)) {",
623 box [newline,
624 string "conn = uw_get_db(ctx);",
625 newline,
626 runit,
627 newline],
628 string "}",
629 newline,
630 string "if (res == NULL) uw_error(ctx, FATAL, \"Can't allocate query result; database server might be down.\");",
631 newline],
632 string "}",
621 newline, 633 newline,
622 newline, 634 newline,
623 635
624 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 636 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
625 newline, 637 newline,
685 newline, 697 newline,
686 string "uw_pop_cleanup(ctx);", 698 string "uw_pop_cleanup(ctx);",
687 newline] 699 newline]
688 700
689 fun query {loc, cols, doCols} = 701 fun query {loc, cols, doCols} =
690 box [string "PGconn *conn = uw_get_db(ctx);", 702 let
691 newline, 703 val runit = string "res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
692 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", 704 in
693 newline, 705 box [string "PGconn *conn = uw_get_db(ctx);",
694 newline, 706 newline,
695 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}] 707 string "PGresult *res;",
708 newline,
709 runit,
710 newline,
711 newline,
712 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query", runit = runit}]
713 end
696 714
697 fun p_ensql t e = 715 fun p_ensql t e =
698 case t of 716 case t of
699 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] 717 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
700 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] 718 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
754 newline]) 772 newline])
755 inputs, 773 inputs,
756 newline] 774 newline]
757 775
758 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = 776 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} =
759 box [string "PGconn *conn = uw_get_db(ctx);", 777 let
760 newline, 778 val runit =
761 779 box [string "res = ",
762 makeParams inputs, 780 if #persistent (Settings.currentProtocol ()) then
763 781 box [string "PQexecPrepared(conn, \"uw",
764 newline, 782 string (Int.toString id),
765 string "PGresult *res = ", 783 string "\", ",
766 if #persistent (Settings.currentProtocol ()) then 784 string (Int.toString (length inputs)),
767 box [string "PQexecPrepared(conn, \"uw", 785 string ", paramValues, paramLengths, paramFormats, 0);"]
768 string (Int.toString id), 786 else
769 string "\", ", 787 box [string "PQexecParams(conn, \"",
770 string (Int.toString (length inputs)), 788 string (Prim.toCString query),
771 string ", paramValues, paramLengths, paramFormats, 0);"] 789 string "\", ",
772 else 790 string (Int.toString (length inputs)),
773 box [string "PQexecParams(conn, \"", 791 string ", NULL, paramValues, paramLengths, paramFormats, 0);"]]
774 string (Prim.toCString query), 792 in
775 string "\", ", 793 box [string "PGconn *conn = uw_get_db(ctx);",
776 string (Int.toString (length inputs)), 794 newline,
777 string ", NULL, paramValues, paramLengths, paramFormats, 0);"], 795
778 newline, 796 makeParams inputs,
779 newline, 797
780 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", 798 newline,
781 string (Prim.toCString query), 799 string "PGresult *res;",
782 string "\""]}] 800 runit,
783 801 newline,
784 fun dmlCommon {loc, dml, mode} = 802 newline,
785 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", 803 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
804 string (Prim.toCString query),
805 string "\""],
806 runit = runit}]
807 end
808
809 fun dmlCommon {loc, dml, mode, runit} =
810 box [string "if (res == NULL) {",
811 box [newline,
812 string "if (uw_try_reconnecting_if_at_most_one(ctx)) {",
813 box [newline,
814 string "conn = uw_get_db(ctx);",
815 newline,
816 runit,
817 newline],
818 string "}",
819 newline,
820 string "if (res == NULL) uw_error(ctx, FATAL, \"Can't allocate DML result; database server might be down.\");",
821 newline],
822 string "}",
786 newline, 823 newline,
787 newline, 824 newline,
788 825
789 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", 826 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
790 newline, 827 newline,
816 newline, 853 newline,
817 newline, 854 newline,
818 855
819 string "res = PQexec(conn, \"ROLLBACK TO s\");", 856 string "res = PQexec(conn, \"ROLLBACK TO s\");",
820 newline, 857 newline,
821 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", 858 string "if (res == NULL) {",
859 box [newline,
860 string "uw_error(ctx, FATAL, \"Can't allocate DML ROLLBACK result; database server might be down.\");",
861 newline],
862 string "}",
822 newline, 863 newline,
823 newline, 864 newline,
824 865
825 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", 866 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
826 newline, 867 newline,
849 newline, 890 newline,
850 box [string "PQclear(res);", 891 box [string "PQclear(res);",
851 newline, 892 newline,
852 string "res = PQexec(conn, \"RELEASE s\");", 893 string "res = PQexec(conn, \"RELEASE s\");",
853 newline, 894 newline,
854 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", 895 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML RELEASE result.\");",
855 newline, 896 newline,
856 newline, 897 newline,
857 898
858 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", 899 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
859 newline, 900 newline,
875 fun makeSavepoint mode = 916 fun makeSavepoint mode =
876 case mode of 917 case mode of
877 Error => box [] 918 Error => box []
878 | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");", 919 | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");",
879 newline, 920 newline,
880 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", 921 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML SAVEPOINT result.\");",
881 newline, 922 newline,
882 newline, 923 newline,
883 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", 924 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
884 box [newline, 925 box [newline,
885 string "PQclear(res);", 926 string "PQclear(res);",
891 string "PQclear(res);", 932 string "PQclear(res);",
892 newline, 933 newline,
893 newline] 934 newline]
894 935
895 fun dml (loc, mode) = 936 fun dml (loc, mode) =
896 box [string "PGconn *conn = uw_get_db(ctx);", 937 let
897 newline, 938 val runit = string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);"
898 string "PGresult *res;", 939 in
899 newline, 940 box [string "PGconn *conn = uw_get_db(ctx);",
900 941 newline,
901 makeSavepoint mode, 942 string "PGresult *res;",
902 943 newline,
903 string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);", 944
904 newline, 945 makeSavepoint mode,
905 newline, 946
906 dmlCommon {loc = loc, dml = string "dml", mode = mode}] 947 runit,
948 newline,
949 newline,
950 dmlCommon {loc = loc, dml = string "dml", mode = mode, runit = runit}]
951 end
907 952
908 fun dmlPrepared {loc, id, dml, inputs, mode} = 953 fun dmlPrepared {loc, id, dml, inputs, mode} =
909 box [string "PGconn *conn = uw_get_db(ctx);", 954 let
910 newline, 955 val runit =
911 956 box [string "res = ",
912 makeParams inputs, 957 if #persistent (Settings.currentProtocol ()) then
913 958 box [string "PQexecPrepared(conn, \"uw",
914 newline, 959 string (Int.toString id),
915 string "PGresult *res;", 960 string "\", ",
916 newline, 961 string (Int.toString (length inputs)),
917 newline, 962 string ", paramValues, paramLengths, paramFormats, 0);"]
918 963 else
919 makeSavepoint mode, 964 box [string "PQexecParams(conn, \"",
920 965 string (Prim.toCString dml),
921 string "res = ", 966 string "\", ",
922 if #persistent (Settings.currentProtocol ()) then 967 string (Int.toString (length inputs)),
923 box [string "PQexecPrepared(conn, \"uw", 968 string ", NULL, paramValues, paramLengths, paramFormats, 0);"]]
924 string (Int.toString id), 969 in
925 string "\", ", 970 box [string "PGconn *conn = uw_get_db(ctx);",
926 string (Int.toString (length inputs)), 971 newline,
927 string ", paramValues, paramLengths, paramFormats, 0);"] 972
928 else 973 makeParams inputs,
929 box [string "PQexecParams(conn, \"", 974
930 string (Prim.toCString dml), 975 newline,
931 string "\", ", 976 string "PGresult *res;",
932 string (Int.toString (length inputs)), 977 newline,
933 string ", NULL, paramValues, paramLengths, paramFormats, 0);"], 978 newline,
934 newline, 979
935 newline, 980 makeSavepoint mode,
936 dmlCommon {loc = loc, dml = box [string "\"", 981
937 string (Prim.toCString dml), 982 runit,
938 string "\""], mode = mode}] 983 newline,
939 984 newline,
940 fun nextvalCommon {loc, query} = 985 dmlCommon {loc = loc, dml = box [string "\"",
941 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");", 986 string (Prim.toCString dml),
987 string "\""], mode = mode, runit = runit}]
988 end
989
990 fun nextvalCommon {loc, query, runit} =
991 box [string "if (res == NULL) {",
992 box [newline,
993 string "if (uw_try_reconnecting_if_at_most_one(ctx))",
994 newline,
995 string "conn = uw_get_db(ctx);",
996 newline,
997 runit,
998 newline,
999 string "uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
1000 newline],
1001 string "}",
942 newline, 1002 newline,
943 newline, 1003 newline,
944 1004
945 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 1005 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
946 newline, 1006 newline,
985 SOME s => 1045 SOME s =>
986 string ("\"SELECT NEXTVAL('" ^ s ^ "')\"") 1046 string ("\"SELECT NEXTVAL('" ^ s ^ "')\"")
987 | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ", 1047 | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ",
988 seqE, 1048 seqE,
989 string ", \"')\"))"] 1049 string ", \"')\"))"]
1050
1051 val runit = string "res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
990 in 1052 in
991 box [string "char *query = ", 1053 box [string "char *query = ",
992 query, 1054 query,
993 string ";", 1055 string ";",
994 newline, 1056 newline,
995 string "PGconn *conn = uw_get_db(ctx);", 1057 string "PGconn *conn = uw_get_db(ctx);",
996 newline, 1058 newline,
997 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", 1059 string "PGresult *res;",
998 newline, 1060 newline,
999 newline, 1061 runit,
1000 nextvalCommon {loc = loc, query = string "query"}] 1062 newline,
1063 newline,
1064 nextvalCommon {loc = loc, query = string "query", runit = runit}]
1001 end 1065 end
1002 1066
1003 fun nextvalPrepared {loc, id, query} = 1067 fun nextvalPrepared {loc, id, query} =
1004 box [string "PGconn *conn = uw_get_db(ctx);", 1068 let
1005 newline, 1069 val runit =
1006 newline, 1070 box [string "res = ",
1007 string "PGresult *res = ", 1071 if #persistent (Settings.currentProtocol ()) then
1008 if #persistent (Settings.currentProtocol ()) then 1072 box [string "PQexecPrepared(conn, \"uw",
1009 box [string "PQexecPrepared(conn, \"uw", 1073 string (Int.toString id),
1010 string (Int.toString id), 1074 string "\", 0, NULL, NULL, NULL, 0);"]
1011 string "\", 0, NULL, NULL, NULL, 0);"] 1075 else
1012 else 1076 box [string "PQexecParams(conn, \"",
1013 box [string "PQexecParams(conn, \"", 1077 string (Prim.toCString query),
1014 string (Prim.toCString query), 1078 string "\", 0, NULL, NULL, NULL, NULL, 0);"]]
1015 string "\", 0, NULL, NULL, NULL, NULL, 0);"], 1079 in
1016 newline, 1080 box [string "PGconn *conn = uw_get_db(ctx);",
1017 newline, 1081 newline,
1018 nextvalCommon {loc = loc, query = box [string "\"", 1082 newline,
1019 string (Prim.toCString query), 1083
1020 string "\""]}] 1084 string "PGresult *res;",
1021 1085 newline,
1022 fun setvalCommon {loc, query} = 1086 runit,
1023 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");", 1087 newline,
1088 newline,
1089 nextvalCommon {loc = loc, query = box [string "\"",
1090 string (Prim.toCString query),
1091 string "\""], runit = runit}]
1092 end
1093
1094 fun setvalCommon {loc, query, runit} =
1095 box [string "if (res == NULL) {",
1096 box [newline,
1097 string "if (uw_try_reconnecting_if_at_most_one(ctx))",
1098 newline,
1099 string "conn = uw_get_db(ctx);",
1100 newline,
1101 runit,
1102 newline,
1103 string "uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");",
1104 newline],
1105 string "}",
1024 newline, 1106 newline,
1025 newline, 1107 newline,
1026 1108
1027 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", 1109 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
1028 newline, 1110 newline,
1046 val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ", 1128 val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
1047 seqE, 1129 seqE,
1048 string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ", 1130 string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
1049 count, 1131 count,
1050 string "), \")\"))))"] 1132 string "), \")\"))))"]
1133
1134 val runit = string "res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
1051 in 1135 in
1052 box [string "char *query = ", 1136 box [string "char *query = ",
1053 query, 1137 query,
1054 string ";", 1138 string ";",
1055 newline, 1139 newline,
1056 string "PGconn *conn = uw_get_db(ctx);", 1140 string "PGconn *conn = uw_get_db(ctx);",
1057 newline, 1141 newline,
1058 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", 1142
1059 newline, 1143 string "PGresult *res;",
1060 newline, 1144 newline,
1061 setvalCommon {loc = loc, query = string "query"}] 1145 runit,
1146 newline,
1147 newline,
1148 setvalCommon {loc = loc, query = string "query", runit = runit}]
1062 end 1149 end
1063 1150
1064 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" 1151 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
1065 | #"\\" => "\\\\" 1152 | #"\\" => "\\\\"
1066 | ch => 1153 | ch =>