Mercurial > urweb
comparison src/postgres.sml @ 2176:d2a98983f502
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 => |