1:- module(miniroon_spec,
2 [ dcgappend/3
3 , netstring_prefix_for_payload/3
4 , netstring_bytes/3
5 , netstring_maplist_dcg/4
6 , phrase_length/4
7 , netstring_call_dcg/3
8 , miniroon_encoding/2
9 , miniroon_header/3
10 , miniroon_v0_caveat_list/3
11 ]).
12:- use_module(library(debug), [assertion/1]).
13:- use_module(library(dcg/basics), [digits/3]).
14
15% pack_install(delay). => https://storage.googleapis.com/packs.ndrix.com/delay/delay-0.3.3.zip
16% Also at: https://github.com/mndrix/delay
17:- use_module(library(delay), [delay/1]).
18
19:- multifile delay:mode/1.
20
21delay:mode(lists:append(ground,_)).
22delay:mode(lists:append(_,ground)).
23
24delay:mode(system:string_bytes(ground,_,ground)).
25delay:mode(system:string_bytes(_,ground,ground)).
26
27%delay:mode(system:number_codes(ground,_)).
28%delay:mode(system:number_codes(_,ground)).
29
30%delay:mode(system:length(_,ground)).
31%delay:mode(system:length(list,_)).
32
33delay:mode(miniroon_spec:netstring_prefix_digits(list, _, _)).
34delay:mode(miniroon_spec:netstring_prefix_digits(_, list, _)).
35
36delay:mode(miniroon_spec:miniroon_v0_action(ground, _)).
37delay:mode(miniroon_spec:miniroon_v0_action(_, list)).
38
39delay:mode(miniroon_spec:phrase_length(nonvar, ground, _, _)).
40delay:mode(miniroon_spec:phrase_length(ground, _, _, _)).
41
42:- op(950, xfx, will_be). %< Shorthand operator for type and value checking
43:- op(800, fx, ~). %< Shorthand operator for delayed goal
44
45~(Goal) :- delay(Goal).
46
47%%% Helpers for DCGs:
48
49% swapped arguments append for use in DCGs
50% when called with instanced list as first argument it unifies it's content with DCG.
51dcgappend([], L, L) :- !.
52dcgappend([H|T], [H|R], L) :-
53 dcgappend(T, R, L).
54
55% Non-cutting variant:
56%dcgappend(List, L0, L1) :- append(List, L1, L0).
57
58phrase_length_agg(List, Terminator, CurrentDepth, Length) :-
59 ( List == Terminator
60 -> CurrentDepth = Length
61 ; NextDepth is CurrentDepth + 1,
62 assertion(compound(List)),
63 List = [_|NextList],
64 phrase_length_agg(NextList, Terminator, NextDepth, Length)
65 ).
66
67phrase_length(DCGBody, List, Rest, Length) :-
68 phrase(DCGBody, List, Terminator),
69 phrase_length_agg(List, Terminator, 0, Length),
70 Terminator = Rest.
71
72%%% Helpers for type and value checking:
73
74% apply check to value when bound
75will_be(Value, Goal) :-
76 freeze(Value, assertion(call(Goal, Value))).
77
78byte(Value) :- must_be(between(0, 255), Value).
79
80nonnegative_integer(Value) :- must_be(nonneg, Value).
81
82sequence_of_bytes([]).
83sequence_of_bytes([First|Rest]) :-
84 First will_be byte,
85 Rest will_be sequence_of_bytes.
86
87%%% Generic grammar definitions:
88
89nonzero_digit(Code) -->
90 [Code],
91 { assertion(ground(Code)) },
92 { member(Code, `123456789`) }.
93
94%%% Netstring definitions:
95
96netstring_bytes(PayloadBytes) --> %> Netstring is a sequence of bytes.
97 { PayloadBytes will_be sequence_of_bytes },
98 netstring_prefix_for_payload(PayloadBytes), %> It consists of prefix,
99 PayloadBytes, %> payload,
100 `,`. %> and terminator. Terminator is single ASCII comma `,`.
101
102netstring_string(PayloadString) -->
103 { ~ string_bytes(PayloadString, PayloadBytes, octet) },
104 netstring_bytes(PayloadBytes).
105
106%> Netstring prefix is the shortest ASCII decimal representation for length of
107%^ payload in bytes, followed by ASCII colon `:`.
108%^ That is number starting with non-zero digit unless payload is empty,
109%^ in which case it's `0`.
110netstring_prefix_for_payload(PayloadBytes, A, B) :-
111 ~ netstring_prefix_digits(Prefix, A, B),
112 ~ number_codes(PayloadLength, Prefix),
113 length(PayloadBytes, PayloadLength).
114
115netstring_prefix_digits(`0`) --> `0:`, !.
116netstring_prefix_digits([C|Cs]) -->
117 nonzero_digit(C),
118 !,
119 digits(Cs),
120 `:`.
121
122netstring_call_dcg(DCGBody, L0, Rest) :-
123 ~ phrase_length(DCGBody,Payload,[44|Rest],PayloadLength),
124 ~ number_codes(PayloadLength, PrefixDigits),
125 netstring_prefix_digits(PrefixDigits, L0, Payload).
126
127netstring_maplist_dcg(_, []) --> {true}.
128netstring_maplist_dcg(DCGBody, [Item|Rest]) -->
129 netstring_call_dcg(call(DCGBody, Item)),
130 netstring_maplist_dcg(DCGBody, Rest).
131
132%%% Miniroon definitions:
133
134miniroon_encoding(Miniroon, Bytes) :-
135 Bytes will_be sequence_of_bytes,
136 phrase(netstring_call_dcg(miniroon_content(Miniroon)), Bytes).
137
138% Miniroon is a netstring whose payload is concatenation of three parts: header, caveat list and signature.
139miniroon_content(miniroon_v0(Identifier, Action, Caveats, Signature)) -->
140 netstring_call_dcg(miniroon_header(header_v0(Identifier, Action))),
141 %netstring_call_dcg(miniroon_v0_caveat_list(Caveats)),
142 netstring_call_dcg(netstring_maplist_dcg(miniroon_v0_caveat, Caveats)),
143 netstring_bytes(Signature).
144
145miniroon_v0_action(revoke) --> `revoke`.
146miniroon_v0_action(invoke) --> `invoke`.
147miniroon_v0_action(invoke_once) --> `invoke-once`.
148
149miniroon_header(header_v0(Identifier, Action)) -->
150 netstring_bytes(`capv0`),
151 netstring_bytes(Identifier),
152 netstring_call_dcg(miniroon_v0_action(Action)).
153
154miniroon_v0_caveat(caveat_v0_env_is(VarName, Value)) -->
155 netstring_bytes(`env-is`),
156 netstring_string(VarName),
157 netstring_string(Value).
158miniroon_v0_caveat(caveat_v0_env_absent(VarName)) -->
159 netstring_bytes(`env-absent`),
160 netstring_string(VarName).
161miniroon_v0_caveat(caveat_v0_env_regmatch(VarName, Pattern)) -->
162 netstring_bytes(`env-re`),
163 netstring_string(VarName),
164 netstring_string(Pattern).
165miniroon_v0_caveat(caveat_v0_env_glob(VarName, Pattern)) -->
166 netstring_bytes(`env-glob`),
167 netstring_string(VarName),
168 netstring_string(Pattern).
169
170miniroon_v0_caveat_list([]) --> {true}.
171miniroon_v0_caveat_list([Caveat|Rest]) -->
172 netstring_call_dcg(miniroon_v0_caveat(Caveat)),
173 miniroon_v0_caveat_list(Rest).