Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file boundary.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253moduleStable=structopenCore.Core_stablemoduleV1=structtypet=string[@@derivingsexp,bin_io,compare]endendopenCoretypet=string[@@derivingsexp_of,compare,hash]typeboundary=tletof_string=Fn.idletto_string=Fn.idmoduleOpen=structletto_string_monoidt=String_monoid.concat_string["\n";"--";t;"\n"]endmoduleClose=structletto_string_monoidt=String_monoid.concat_string["\n";"--";t;"--"]endmoduleOpen_first=structletto_string_monoidt=String_monoid.concat_string["--";t;"\n"]endletsplittbstr=letlf=Bigstring_shared.of_string"\n"inletcrlf=Bigstring_shared.of_string"\r\n"inletdashdash=Bigstring_shared.of_string"--"inlett=Bigstring_shared.of_string("--"^t)inletmatch_after~posbstr~pattern=letlen=Bigstring_shared.lengthpatterninOption.some_if(pos>=0&&pos+len<=Bigstring_shared.lengthbstr&&[%compare.equal:Bigstring_shared.t]pattern(Bigstring_shared.subbstr~pos~len))(pos+len)inletmatch_before~pos:end_bstr~pattern=letstart=end_-Bigstring_shared.lengthpatterninmatch_after~pos:startbstr~pattern|>Option.map~f:(funend_'->assert(end_=end_');start)inletmatch_crlfdirection~posbstr=ifpos=0||pos=Bigstring_shared.lengthbstrthenSomeposelse(letmatch_=matchdirectionwith|`After->funpattern->match_after~posbstr~pattern|`Before->funpattern->match_before~posbstr~patterninOption.first_some(match_crlf)(match_lf))inletrecfind_boundarypos=matchBigstring_shared.substr_indexbstr~pos~pattern:twith|None->(* No more occurrences of [BOUNDARY] so definitely at EOF *)`Eof|Somepos->letno_prologue=pos=0in(* Ensure we are at the start of a line (after [CR]LF, or beginning of bigstring) *)(matchmatch_crlf`Before~posbstrwith|None->find_boundary(pos+1)(* skip a character to avoid getting stuck in a loop *)|Somebegin_->letpos=pos+Bigstring_shared.lengthtinletis_terminal,pos=matchmatch_after~posbstr~pattern:dashdashwith|Somepos->true,pos|None->false,posin(* Ensure we are at the end of a line (before [CR]LF, or end of bigstring) *)(matchmatch_crlf`After~posbstrwith|None->find_boundarypos|Someend_->ifis_terminalthen`Close_boundary(begin_,pos)elseifno_prologuethen`Open_boundary_firstend_else`Open_boundary(begin_,end_)))inletrecloopposacchas_prologue=letsub?stop()=letstop=Option.valuestop~default:(Bigstring_shared.lengthbstr)inletlen=stop-posiniflen<=0thenBigstring_shared.emptyelseBigstring_shared.sub~pos~lenbstrinmatchfind_boundaryposwith|`Open_boundary_firstpos->loopposaccfalse|`Open_boundary(stop,pos)->letchunk=sub~stop()inlooppos(chunk::acc)has_prologue|`Close_boundary(stop,pos)->letchunk=sub~stop()inletepilogue=ifpos<Bigstring_shared.lengthbstrthenSome(Bigstring_shared.sub~posbstr)elseNoneinchunk::acc,epilogue,has_prologue|`Eof->letchunk=sub()inchunk::acc,None,has_prologuein(* RFC 2046: A multipart body may have a prologue and an epilogue *)letparts,epilogue,has_prologue=loop0[]trueinmatchList.revpartswith|[]->Somebstr,[],epilogue|prologue::partswhenhas_prologue->Someprologue,parts,epilogue|parts->None,parts,epilogue;;moduleGenerator=structtypenonrect=tSequence.tletsexp_of_tt=[%sexp((Sequence.taket5|>Sequence.to_list)@["..."]:stringlist)];;(* This boundary pattern ensures that the boundary should not appear in
- Headers
- Quoted-printable text
- Base64 encoded content.
The only posibility is that it might appear in plaintext, but
that would be incredibly rare.
We avoid conflicts by generating IDs with different numbers as needed.
*)letdefault=Sequence.unfold~init:0~f:(funnum->letstr=sprintf"--==::BOUNDARY::%06d::==--"numinSome(str,num+1));;let%expect_test_=Sequence.takedefault5|>Sequence.iter~f:print_endline;[%expect{|
--==::BOUNDARY::000000::==--
--==::BOUNDARY::000001::==--
--==::BOUNDARY::000002::==--
--==::BOUNDARY::000003::==--
--==::BOUNDARY::000004::==--
|}];;(* Increment the last numeric component to avoid number conflicts. *)letfrom_existing_boundarystr=Sequence.append(Sequence.singletonstr)defaultlet%expect_test_=Sequence.take(from_existing_boundary"BOUNDARY")5|>Sequence.iter~f:print_endline;[%expect{|
BOUNDARY
--==::BOUNDARY::000000::==--
--==::BOUNDARY::000001::==--
--==::BOUNDARY::000002::==--
--==::BOUNDARY::000003::==--
|}];;letfind_nonflictingtparts=Sequence.find_exnt~f:(funt->List.for_allparts~f:(funpart->(* This will incorrectly report a conflict if [BOUNDARY] occurs in the text or is
a prefix/suffix of any existing boundary. This is very unlikely to happen in
practice, and would just result in an alternative boundary being used. *)not(String_monoid.is_substringpart~substring:t)));;let%expect_test_=find_nonflicting(from_existing_boundary"BOUNDARY")[String_monoid.of_string"foobar"]|>print_endline;[%expect{| BOUNDARY |}];;let%expect_test_=find_nonflicting(from_existing_boundary"BOUNDARY")[String_monoid.of_string"--BOUNDARY--"]|>print_endline;[%expect{| --==::BOUNDARY::000000::==-- |}];;let%expect_test_=find_nonflicting(from_existing_boundary"BOUNDARY")[String_monoid.of_string"...BOUNDARY...--==::BOUNDARY::000000::==--..."]|>print_endline;[%expect{| --==::BOUNDARY::000001::==-- |}];;endletgenerate_non_conflicting_boundary?prologue~parts?epiloguet=Generator.find_nonflictingt((Option.to_listprologue|>List.map~f:Bigstring_shared.to_string_monoid)@parts@(Option.to_listepilogue|>List.map~f:Bigstring_shared.to_string_monoid));;letjoin_without_checking_for_conflicts?prologue~parts?epiloguet=ifList.is_emptypartsthen(matchprologue,epiloguewith|Someprologue,Someepilogue->String_monoid.plus(Bigstring_shared.to_string_monoidprologue)(Bigstring_shared.to_string_monoidepilogue)|Somecontent,None|None,Somecontent->Bigstring_shared.to_string_monoidcontent|None,None->String_monoid.of_string"\n")else((* Different types of boundaries that may appear in a message *)letboundary_open_first=t|>Open_first.to_string_monoidinletboundary_open=t|>Open.to_string_monoidinletboundary_close=t|>Close.to_string_monoidinletfirst_boundary=ifOption.is_someprologuethenboundary_openelseboundary_open_firstinletprologue=Option.value_mapprologue~f:Bigstring_shared.to_string_monoid~default:String_monoid.emptyinletinner_boundary=boundary_openinletlast_boundary=boundary_closeinletepilogue=Option.value_mapepilogue~f:Bigstring_shared.to_string_monoid~default:String_monoid.emptyinString_monoid.concat[prologue;first_boundary;String_monoid.concat~sep:inner_boundaryparts;last_boundary;epilogue]);;