job:  #9554  This is a complete integrity checker generator.  A prototype is attached to issue 9554 from this OAL.

.// For each class in the model do the following:
.//   Search for duplicate identifiers in the instance extent.
.//   Match referential attribute values with identifier attribute values.
.//   Find unconditional formalizer from a participant in a simple association.
.//   Find unconditional participant from a formalizer in a simple association.
.//   For an associator in a linked association ensure both ends have an instance.
.//   From the one end of an associative, find the unconditional associator.
.//   From the other end of an associative, find the unconditional associator.
.//   For a subtype, ensure a supertype is present.
.//   For a supertype, ensure exactly one subtype is present.
.//
.// Iterate over the given class.
.function t_class_instance_iteration .// string
  .param string key_letters
  .param string inner_body
  .param string trace_attribute
  .param string name
select many $l{key_letters}s from instances of ${key_letters};
for each $l{key_letters} in $l{key_letters}s
  .if ( "" == trace_attribute )
  trace = "";
  .else
  trace = "${trace_attribute} " + STRING::itoa( i:T::idtoi( id:$l{key_letters}.${trace_attribute} ) );
  .end if
  .if ( "" != name )
  trace = trace + " " + $l{key_letters}.${name};
  .end if
${inner_body}
end for;
.end function
.//
.// Ensure no duplicate instance identifiers.
.function t_duplication .// string
  .param string key_letters
  .param string where_clause
  .param integer Numb
  select many duplicate_$l{key_letters}s from instances of ${key_letters} where ( ${where_clause} );
  if ( cardinality duplicate_$l{key_letters}s != 1 )
    LOG::LogInfo( message: "uniqueness violation in ${key_letters} for identifier $t{Numb}:  " + trace );
    break;
  end if;
.end function
.//
.// Select across link to required instance.
.function t_participation .// string
  .param string left_side
  .param string right_side
  .param integer Numb
  .param string multiplicity
  .param string phrase
  .param string attribute_comparison
  .if ( "" != phrase )
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}.'${phrase}'];
  .else
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}];
  .end if
  if ( empty $l{right_side} )
  .if ( "" != phrase )
    LOG::LogInfo( message: "instance not found ${left_side}->${right_side}[R$t{Numb}.'${phrase}']:  " + trace );
  .else
    LOG::LogInfo( message: "instance not found ${left_side}->${right_side}[R$t{Numb}]:  " + trace );
  .end if
    break;
  .if ( "" != attribute_comparison )
  else
    if ( not ( ${attribute_comparison} ) )
      LOG::LogInfo( message: "referentials do not match identifiers between ${left_side} and ${right_side}:  " + trace );
      break;
    end if;
  .end if
  end if;
.end function
.//
.// Loop through looking for a subtype.
.function t_supertype_loop .// string
  .param string super
  .param integer Numb
  .param string Loop_Body
  subtype_count = 0;
${Loop_Body}
  if ( subtype_count < 1 )
    LOG::LogInfo( message: "subtype not found from ${super} across R$t{Numb}:  " + trace );
    break;
  elif ( subtype_count > 1 )
    LOG::LogInfo( message: "more than one subtype found from ${super} across R$t{Numb}:  " + trace );
    break;
  else
    // nop
  end if;
.end function
.//
.// Be sure supertype is present.
.function t_sub_to_super .// string
  .param string sub
  .param string super
  .param integer Numb
  select one $l{super} related by $l{sub}->${super}[R$t{Numb}];
  if ( empty $l{super} )
    LOG::LogInfo( message: "supertype not found across ${sub}->${super}[R$t{Numb}]:" + trace );
    break;
  end if;
.end function
.//
.// Look for a particular subtype.
.function t_super_to_sub .// string
  .param string super
  .param string sub
  .param integer Numb
  select one $l{sub} related by $l{super}->${sub}[R$t{Numb}];
  if ( not_empty $l{sub} )
    subtype_count = subtype_count + 1;
  end if;
.end function
.//
.function instance_uniqueness .// string
  .param inst_ref o_id
  .select one o_obj related by o_id->O_OBJ[R104]
  .assign where_clause = ""
  .assign prefix = ""
  .select many o_oidas related by o_id->O_OIDA[R105]
  .for each o_oida in o_oidas
    .assign clause = "selected." + o_oida.localAttributeName + " == " + $l{o_obj.Key_Lett} + "." + o_oida.localAttributeName
    .assign where_clause = where_clause + prefix + clause
    .assign prefix = " and "
  .end for
  .invoke r = t_duplication( o_obj.Key_Lett, where_clause, o_id.Oid_ID + 1 )
${r.body}
.end function
.//
.function compare_referentials_to_identifiers
  .param string rgo_name
  .param string rto_name
  .param inst_ref r_rgo
  .param inst_ref r_rto
  .//
  .assign where_clause = ""
  .assign conjunction = ""
  .select many o_oidas related by r_rto->O_ID[R109]->O_OIDA[R105]
  .for each o_oida in o_oidas
    .// Get the identifying attribute corresponding to this <o_oida> instance.
    .select any o_attr related by o_oida->O_ATTR[R105] where (selected.Attr_ID == o_oida.Attr_ID)
    .select any o_rtida related by r_rto->O_RTIDA[R110] where ((selected.Attr_ID == o_oida.Attr_ID) and ((selected.Obj_ID == o_oida.Obj_ID) and (selected.Oid_ID == o_oida.Oid_ID)))
    .// There can be more than one valid O_REF here, so get _any_ one.
    .// Note:  If MANY <o_rtida>, we need to rip through the (possible) combined referentials,
    .// unlinking any non-constrained elements.
    .select any o_ref related by o_rtida->O_REF[R111] where ( (selected.Obj_ID == r_rgo.Obj_ID) and (selected.OIR_ID == r_rgo.OIR_ID) )
    .// Get the referential attribute corresponding to the current <o_attr>.
    .select one ref_o_attr related by o_ref->O_RATTR[R108]->O_ATTR[R106]
    .select one o_dbattr related by o_attr->O_BATTR[R106]->O_DBATTR[R107]
    .// template here
    .assign clause = rto_name + "." + o_oida.localAttributeName + " == " + rgo_name + "." + ref_o_attr.Name
    .assign where_clause = where_clause + conjunction + clause
    .assign conjunction = " and "
  .end for
${where_clause}\
.end function
.//
.function participant_participation .// string
  .param inst_ref o_obj
  .select many r_parts related by o_obj->R_OIR[R201]->R_RTO[R203]->R_PART[R204]
  .for each r_part in r_parts
    .select one r_simp related by r_part->R_SIMP[R207]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_form related by r_simp->R_FORM[R208]
      .if ( not_empty r_form )
        .if ( not r_form.Cond )
          .select one r_rgo related by r_form->R_RGO[R205]
          .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
          .assign card = "one"
          .if ( r_form.Mult )
            .assign card = "any"
          .end if
          .assign phrase = ""
          .if ( r_part.Obj_ID == r_form.Obj_ID )
            .assign phrase = r_form.Txt_Phrs
          .end if
          .select one r_rto related by r_part->R_RTO[R204]
          .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
          .assign comparison = r.body
          .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // participant participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
        .end if
      .else
  // unformalized association R$t{r_rel.Numb}
      .end if
    .end if
  .end for
.end function
.//
.function formalizer_participation .// string
  .param inst_ref o_obj
  .select many r_forms related by o_obj->R_OIR[R201]->R_RGO[R203]->R_FORM[R205]
  .for each r_form in r_forms
    .select one r_simp related by r_form->R_SIMP[R208]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_part related by r_simp->R_PART[R207]
      .if ( not r_part.Cond )
        .select one r_rto related by r_part->R_RTO[R204]
        .select one target_o_obj related by r_rto->R_OIR[R203]->O_OBJ[R201]
        .assign card = "one"
        .if ( r_part.Mult )
          .assign card = "any"
        .end if
        .assign phrase = ""
        .if ( r_part.Obj_ID == r_form.Obj_ID )
          .assign phrase = r_part.Txt_Phrs
        .end if
        .select one r_rgo related by r_form->R_RGO[R205]
        .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // formalizer participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function associator_participation .// string
  .param inst_ref o_obj
  .select many r_assrs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_ASSR[R205]
  .for each r_assr in r_assrs
    .select one r_assoc related by r_assr->R_ASSOC[R211]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .select one aone_r_rto related by r_aone->R_RTO[R204]
      .select one aone_o_obj related by aone_r_rto->R_OIR[R203]->O_OBJ[R201]
      .select one aoth_r_rto related by r_aoth->R_RTO[R204]
      .select one aoth_o_obj related by aoth_r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aone.Txt_Phrs
      .end if
      .select one r_rgo related by r_assr->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aone_o_obj.Key_Lett}, r_rgo, aone_r_rto )
      .assign comparison = r.body
      .invoke r = t_participation( o_obj.Key_Lett, aone_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator one participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aone_o_obj.Name}(${aone_o_obj.Key_Lett})
${r.body}
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aoth.Txt_Phrs
      .end if
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aoth_o_obj.Key_Lett}, r_rgo, aoth_r_rto )
      .assign comparison = r.body
      .invoke r = t_participation( o_obj.Key_Lett, aoth_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator other participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aoth_o_obj.Name}(${aoth_o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function aone_participation .// string
  .param inst_ref o_obj
  .select many r_aones related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AONE[R204]
  .for each r_aone in r_aones
    .select one r_assoc related by r_aone->R_ASSOC[R209]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .if ( not r_aoth.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aoth.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aoth.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aone->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aone participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function aoth_participation .// string
  .param inst_ref o_obj
  .select many r_aoths related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AOTH[R204]
  .for each r_aoth in r_aoths
    .select one r_assoc related by r_aoth->R_ASSOC[R210]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .if ( not r_aone.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aone.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aone.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aoth->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aoth participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function supertype_participation .// string
  .param inst_ref o_obj
  .select many r_supers related by o_obj->R_OIR[R201]->R_RTO[R203]->R_SUPER[R204]
  .for each r_super in r_supers
    .assign loop_body = ""
    .select one r_subsup related by r_super->R_SUBSUP[R212]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select many r_subs related by r_subsup->R_SUB[R213]
      .for each r_sub in r_subs
        .select one source_o_obj related by r_sub->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
        .invoke r = t_super_to_sub( o_obj.Key_Lett, source_o_obj.Key_Lett, r_rel.Numb )
        .assign loop_body = loop_body + r.body
      .end for
      .invoke r = t_supertype_loop( o_obj.Key_Lett, r_rel.Numb, loop_body )
  // super to sub participation R$t{r_rel.Numb}:  supertype ${o_obj.Name}(${o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function subtype_participation .// string
  .param inst_ref o_obj
  .select many r_subs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_SUB[R205]
  .for each r_sub in r_subs
    .select one r_subsup related by r_sub->R_SUBSUP[R213]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one target_o_obj related by r_subsup->R_SUPER[R212]->R_RTO[R204]->R_OIR[R203]->O_OBJ[R201]
      .invoke r = t_sub_to_super( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb )
  // sub to super participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.// Return true if the element exists (nested) in the given package name.
.function in_ep_pkg .// boolean
  .param inst_ref ep_pkg
  .param string ep_pkg_Name
  .assign inpkg = false
  .if ( not_empty ep_pkg )
    .if ( ep_pkg_Name == ep_pkg.Name )
      .assign inpkg = true
    .else
      .select one ep_pkg related by ep_pkg->PE_PE[R8001]->EP_PKG[R8000]
      .invoke r = in_ep_pkg( ep_pkg, ep_pkg_Name )
      .assign inpkg = r.result
    .end if
  .end if
  .assign attr_result = inpkg
.end function
.//
.function generate_actions .// string
// For each class in the model do the following:
//   Search for duplicate identifiers in the instance extent.
//   Find unconditional formalizer from a participant in a simple association.
//   Find unconditional participant from a formalizer in a simple association.
//   For an associator in a linked association ensure both ends have an instance.
//   For the one end of an associative, find the unconditional associator.
//   For the other end of an associative, find the unconditional associator.
//   For a subtype, be sure a supertype is present.
//   For a supertype, be sure exactly one subtype is present.
// Show only the first violation of any particular rule in each extent.
  .select many o_objs from instances of O_OBJ
  .for each o_obj in o_objs
    .assign trace_attribute = ""
    .assign name = ""
    .select one ep_pkg related by o_obj->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .assign text = ""
      .select many o_ids related by o_obj->O_ID[R104]
      .for each o_id in o_ids
        .select one o_oida related by o_id->O_OIDA[R105]
        .if ( not_empty o_oida )
          .invoke r = instance_uniqueness( o_id )
          .assign text = text + r.body
          .// Find an identifying attribute to use to provide the user some way
          .// to locate the erroneous element.
          .select one s_dt related by o_oida->O_ATTR[R105]->S_DT[R114] where ( selected.Name == "unique_id" )
          .if ( not_empty s_dt )
            .assign trace_attribute = o_oida.localAttributeName
          .else
            .select one s_dt related by o_oida->O_ATTR[R105]->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114] where ( selected.Name == "unique_id" )
            .if ( not_empty s_dt )
              .assign trace_attribute = o_oida.localAttributeName
            .end if
          .end if
        .end if
      .end for
      .// If class has an attribute named "Name", use it for tracing purposes.
      .select any o_attr related by o_obj->O_ATTR[R102] where ( selected.Root_Nam == "Name" )
      .if ( not_empty o_attr )
        .assign name = o_attr.Root_Nam
      .end if
      .// participant
      .invoke r = participant_participation( o_obj )
      .assign text = text + r.body
      .// formalizer
      .invoke r = formalizer_participation( o_obj )
      .assign text = text + r.body
      .// associator
      .invoke r = associator_participation( o_obj )
      .assign text = text + r.body
      .// aone
      .invoke r = aone_participation( o_obj )
      .assign text = text + r.body
      .// aoth
      .invoke r = aoth_participation( o_obj )
      .assign text = text + r.body
      .// subtype
      .invoke r = subtype_participation( o_obj )
      .assign text = text + r.body
      .// supertype
      .invoke r = supertype_participation( o_obj )
      .assign text = text + r.body
      .// iterate
      .invoke r = t_class_instance_iteration( o_obj.Key_Lett, text, trace_attribute, name )
${r.body}
    .end if
  .end for
  .//
.end function
.//
.function ooaofooa_check_referential_integrity .// string
  .invoke r = generate_actions()
${r.body}
.end function
.//
.invoke r = ooaofooa_check_referential_integrity()
${r.body}
.emit to file "../ooa.txt"

.// still a bug in aoth reference checking
.//
.// For each class in the model do the following:
.//   Search for duplicate identifiers in the instance extent.
.//   Match referential attribute values with identifier attribute values.
.//   Find unconditional formalizer from a participant in a simple association.
.//   Find unconditional participant from a formalizer in a simple association.
.//   For an associator in a linked association ensure both ends have an instance.
.//   From the one end of an associative, find the unconditional associator.
.//   From the other end of an associative, find the unconditional associator.
.//   For a subtype, ensure a supertype is present.
.//   For a supertype, ensure exactly one subtype is present.
.//
.// Iterate over the given class.
.function t_class_instance_iteration .// string
  .param string key_letters
  .param string inner_body
select many $l{key_letters}s from instances of ${key_letters};
for each $l{key_letters} in $l{key_letters}s
${inner_body}
end for;
.end function
.//
.// Ensure no duplicate instance identifiers.
.function t_duplication .// string
  .param string key_letters
  .param string where_clause
  .param integer Numb
  select many duplicate_$l{key_letters}s from instances of ${key_letters} where ( ${where_clause} );
  if ( cardinality duplicate_$l{key_letters}s != 1 )
    LOG::LogInfo( message: "uniqueness violation in ${key_letters} for identifier $t{Numb}" );
    break;
  end if;
.end function
.//
.// Select across link to required instance.
.function t_participation .// string
  .param string left_side
  .param string right_side
  .param integer Numb
  .param string multiplicity
  .param string phrase
  .param string attribute_comparison
  .if ( "" != phrase )
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}.'${phrase}'];
  .else
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}];
  .end if
  if ( empty $l{right_side} )
  .if ( "" != phrase )
    LOG::LogInfo( message: "instance not found ${left_side}->${right_side}[R$t{Numb}.'${phrase}']" );
  .else
    LOG::LogInfo( message: "instance not found ${left_side}->${right_side}[R$t{Numb}]" );
  .end if
    break;
  .if ( "" != attribute_comparison )
  else
    if ( not ( ${attribute_comparison} ) )
      LOG::LogInfo( message: "referentials do not match identifiers between ${left_side} and ${right_side}" );
      break;
    end if;
  .end if
  end if;
.end function
.//
.// Loop through looking for a subtype.
.function t_supertype_loop .// string
  .param string super
  .param integer Numb
  .param string Loop_Body
  subtype_count = 0;
${Loop_Body}
  if ( subtype_count < 1 )
    LOG::LogInfo( message: "subtype not found from ${super} across R$t{Numb}" );
    break;
  elif ( subtype_count > 1 )
    LOG::LogInfo( message: "more than one subtype found from ${super} across R$t{Numb}" );
    break;
  else
    // nop
  end if;
.end function
.//
.// Be sure supertype is present.
.function t_sub_to_super .// string
  .param string sub
  .param string super
  .param integer Numb
  select one $l{super} related by $l{sub}->${super}[R$t{Numb}];
  if ( empty $l{super} )
    LOG::LogInfo( message: "supertype not found across ${sub}->${super}[R$t{Numb}]" );
    break;
  end if;
.end function
.//
.// Look for a particular subtype.
.function t_super_to_sub .// string
  .param string super
  .param string sub
  .param integer Numb
  select one $l{sub} related by $l{super}->${sub}[R$t{Numb}];
  if ( not_empty $l{sub} )
    subtype_count = subtype_count + 1;
  end if;
.end function
.//
.function instance_uniqueness .// string
  .param inst_ref o_id
  .select one o_obj related by o_id->O_OBJ[R104]
  .assign where_clause = ""
  .assign prefix = ""
  .select many o_oidas related by o_id->O_OIDA[R105]
  .for each o_oida in o_oidas
    .assign clause = "selected." + o_oida.localAttributeName + " == " + $l{o_obj.Key_Lett} + "." + o_oida.localAttributeName
    .assign where_clause = where_clause + prefix + clause
    .assign prefix = " and "
  .end for
  .invoke r = t_duplication( o_obj.Key_Lett, where_clause, o_id.Oid_ID + 1 )
${r.body}
.end function
.//
.function compare_referentials_to_identifiers
  .param string rgo_name
  .param string rto_name
  .param inst_ref r_rgo
  .param inst_ref r_rto
  .//
  .assign where_clause = ""
  .assign conjunction = ""
  .select many o_oidas related by r_rto->O_ID[R109]->O_OIDA[R105]
  .for each o_oida in o_oidas
    .// Get the identifying attribute corresponding to this <o_oida> instance.
    .select any o_attr related by o_oida->O_ATTR[R105] where (selected.Attr_ID == o_oida.Attr_ID)
    .select any o_rtida related by r_rto->O_RTIDA[R110] where ((selected.Attr_ID == o_oida.Attr_ID) and ((selected.Obj_ID == o_oida.Obj_ID) and (selected.Oid_ID == o_oida.Oid_ID)))
    .// There can be more than one valid O_REF here, so get _any_ one.
    .// Note:  If MANY <o_rtida>, we need to rip through the (possible) combined referentials,
    .// unlinking any non-constrained elements.
    .select any o_ref related by o_rtida->O_REF[R111] where ( (selected.Obj_ID == r_rgo.Obj_ID) and (selected.OIR_ID == r_rgo.OIR_ID) )
    .// Get the referential attribute corresponding to the current <o_attr>.
    .select one ref_o_attr related by o_ref->O_RATTR[R108]->O_ATTR[R106]
    .select one o_dbattr related by o_attr->O_BATTR[R106]->O_DBATTR[R107]
    .// template here
    .assign clause = rto_name + "." + o_oida.localAttributeName + " == " + rgo_name + "." + ref_o_attr.Name
    .assign where_clause = where_clause + conjunction + clause
    .assign conjunction = " and "
  .end for
${where_clause}\
.end function
.//
.function participant_participation .// string
  .param inst_ref o_obj
  .select many r_parts related by o_obj->R_OIR[R201]->R_RTO[R203]->R_PART[R204]
  .for each r_part in r_parts
    .select one r_simp related by r_part->R_SIMP[R207]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_form related by r_simp->R_FORM[R208]
      .if ( not_empty r_form )
        .if ( not r_form.Cond )
          .select one r_rgo related by r_form->R_RGO[R205]
          .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
          .assign card = "one"
          .if ( r_form.Mult )
            .assign card = "any"
          .end if
          .assign phrase = ""
          .if ( r_part.Obj_ID == r_form.Obj_ID )
            .assign phrase = r_form.Txt_Phrs
          .end if
          .select one r_rto related by r_part->R_RTO[R204]
          .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
          .assign comparison = r.body
          .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // participant participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
        .end if
      .else
  // unformalized association R$t{r_rel.Numb}
      .end if
    .end if
  .end for
.end function
.//
.function formalizer_participation .// string
  .param inst_ref o_obj
  .select many r_forms related by o_obj->R_OIR[R201]->R_RGO[R203]->R_FORM[R205]
  .for each r_form in r_forms
    .select one r_simp related by r_form->R_SIMP[R208]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_part related by r_simp->R_PART[R207]
      .if ( not r_part.Cond )
        .select one r_rto related by r_part->R_RTO[R204]
        .select one target_o_obj related by r_rto->R_OIR[R203]->O_OBJ[R201]
        .assign card = "one"
        .if ( r_part.Mult )
          .assign card = "any"
        .end if
        .assign phrase = ""
        .if ( r_part.Obj_ID == r_form.Obj_ID )
          .assign phrase = r_part.Txt_Phrs
        .end if
        .select one r_rgo related by r_form->R_RGO[R205]
        .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // formalizer participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function associator_participation .// string
  .param inst_ref o_obj
  .select many r_assrs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_ASSR[R205]
  .for each r_assr in r_assrs
    .select one r_assoc related by r_assr->R_ASSOC[R211]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .select one aone_r_rto related by r_aone->R_RTO[R204]
      .select one aone_o_obj related by aone_r_rto->R_OIR[R203]->O_OBJ[R201]
      .select one aoth_r_rto related by r_aoth->R_RTO[R204]
      .select one aoth_o_obj related by aoth_r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aone.Txt_Phrs
      .end if
      .select one r_rgo related by r_assr->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aone_o_obj.Key_Lett}, r_rgo, aone_r_rto )
      .assign comparison = r.body
      .invoke r = t_participation( o_obj.Key_Lett, aone_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator one participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aone_o_obj.Name}(${aone_o_obj.Key_Lett})
${r.body}
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aoth.Txt_Phrs
      .end if
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aoth_o_obj.Key_Lett}, r_rgo, aoth_r_rto )
      .assign comparison = r.body
      .invoke r = t_participation( o_obj.Key_Lett, aoth_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator other participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aoth_o_obj.Name}(${aoth_o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function aone_participation .// string
  .param inst_ref o_obj
  .select many r_aones related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AONE[R204]
  .for each r_aone in r_aones
    .select one r_assoc related by r_aone->R_ASSOC[R209]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .if ( not r_aoth.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aoth.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aoth.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aone->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aone participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function aoth_participation .// string
  .param inst_ref o_obj
  .select many r_aoths related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AOTH[R204]
  .for each r_aoth in r_aoths
    .select one r_assoc related by r_aoth->R_ASSOC[R210]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .if ( not r_aone.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aone.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aone.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aoth->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aoth participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function supertype_participation .// string
  .param inst_ref o_obj
  .assign loop_body = ""
  .select many r_supers related by o_obj->R_OIR[R201]->R_RTO[R203]->R_SUPER[R204]
  .for each r_super in r_supers
    .select one r_subsup related by r_super->R_SUBSUP[R212]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select many r_subs related by r_subsup->R_SUB[R213]
      .for each r_sub in r_subs
        .select one source_o_obj related by r_sub->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
        .invoke r = t_super_to_sub( o_obj.Key_Lett, source_o_obj.Key_Lett, r_rel.Numb )
        .assign loop_body = loop_body + r.body
      .end for
      .invoke r = t_supertype_loop( o_obj.Key_Lett, r_rel.Numb, loop_body )
  // super to sub participation R$t{r_rel.Numb}:  supertype ${o_obj.Name}(${o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function subtype_participation .// string
  .param inst_ref o_obj
  .select many r_subs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_SUB[R205]
  .for each r_sub in r_subs
    .select one r_subsup related by r_sub->R_SUBSUP[R213]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one target_o_obj related by r_subsup->R_SUPER[R212]->R_RTO[R204]->R_OIR[R203]->O_OBJ[R201]
      .invoke r = t_sub_to_super( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb )
  // sub to super participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.// Return true if the element exists (nested) in the given package name.
.function in_ep_pkg .// boolean
  .param inst_ref ep_pkg
  .param string ep_pkg_Name
  .assign inpkg = false
  .if ( not_empty ep_pkg )
    .if ( ep_pkg_Name == ep_pkg.Name )
      .assign inpkg = true
    .else
      .select one ep_pkg related by ep_pkg->PE_PE[R8001]->EP_PKG[R8000]
      .invoke r = in_ep_pkg( ep_pkg, ep_pkg_Name )
      .assign inpkg = r.result
    .end if
  .end if
  .assign attr_result = inpkg
.end function
.//
.function generate_actions .// string
// For each class in the model do the following:
//   Search for duplicate identifiers in the instance extent.
//   Find unconditional formalizer from a participant in a simple association.
//   Find unconditional participant from a formalizer in a simple association.
//   For an associator in a linked association ensure both ends have an instance.
//   For the one end of an associative, find the unconditional associator.
//   For the other end of an associative, find the unconditional associator.
//   For a subtype, be sure a supertype is present.
//   For a supertype, be sure exactly one subtype is present.
// Show only the first violation of any particular rule in each extent.
  .select many o_objs from instances of O_OBJ
  .for each o_obj in o_objs
    .select one ep_pkg related by o_obj->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .assign text = ""
      .select many o_ids related by o_obj->O_ID[R104]
      .for each o_id in o_ids
        .select one o_oida related by o_id->O_OIDA[R105]
        .if ( not_empty o_oida )
          .invoke r = instance_uniqueness( o_id )
          .assign text = text + r.body
        .end if
      .end for
      .// participant
      .invoke r = participant_participation( o_obj )
      .assign text = text + r.body
      .// formalizer
      .invoke r = formalizer_participation( o_obj )
      .assign text = text + r.body
      .// associator
      .invoke r = associator_participation( o_obj )
      .assign text = text + r.body
      .// aone
      .invoke r = aone_participation( o_obj )
      .assign text = text + r.body
      .// aoth
      .invoke r = aoth_participation( o_obj )
      .assign text = text + r.body
      .// subtype
      .invoke r = subtype_participation( o_obj )
      .assign text = text + r.body
      .// supertype
      .invoke r = supertype_participation( o_obj )
      .assign text = text + r.body
      .// iterate
      .invoke r = t_class_instance_iteration( o_obj.Key_Lett, text )
${r.body}
    .end if
  .end for
  .//
.end function
.//
.function ooaofooa_check_referential_integrity .// string
  .invoke r = generate_actions()
${r.body}
.end function
.//
.invoke r = ooaofooa_check_referential_integrity()
${r.body}
.emit to file "../ooa.txt"


Rename login/create form inputs

Rename login/create form inputs

; Application Server.  Layer inserted 2 Sep 06.

; ideas:
; def a general notion of apps of which prompt is one, news another
; give each user a place to store data?  A home dir?

; A user is simply a string: "pg". Use /whoami to test user cookie.

(= hpwfile*   "arc/hpw"
   oidfile*   "arc/openids"
   adminfile* "arc/admins"
   cookfile*  "arc/cooks")

(def asv ((o port 8080))
  (load-userinfo)
  (serve port))

(def load-userinfo ()
  (= hpasswords*   (safe-load-table hpwfile*)
     openids*      (safe-load-table oidfile*)
     admins*       (map string (errsafe (readfile adminfile*)))
     cookie->user* (safe-load-table cookfile*))
  (maptable (fn (k v) (= (user->cookie* v) k))
            cookie->user*))

; idea: a bidirectional table, so don't need two vars (and sets)

(^ cookie->user* (table) user->cookie* (table) user->email* (table) logins* (table))

(def get-ip ((o req (the-req*)))
  (or req!ip "::1"))

(def get-cookie (key (o req (the-req*)))
  (alref req!cooks key))

(def get-user ((o req (the-req*)))
  (let u (aand (get-cookie "user" req)
               (cookie->user* (sym it)))
    (when u (= (logins* u) (get-ip req)))
    u))

(defmemo auth-hash (cookie)
  (shash:string cookie))

(def get-auth ((o user (get-user)))
  (aand user
        (user->cookie* user)
        (auth-hash it)))

(def is-auth (auth (o user (get-user)))
  (is auth (get-auth user)))

(mac when-umatch (user req . body)
  `(if (is ,user (get-user ,req))
       (do ,@body)
       (mismatch-message)))

(def mismatch-message ()
  (prn "Dead link: users don't match."))

(mac when-umatch/r (user req . body)
  `(if (is ,user (get-user ,req))
       (do ,@body)
       "mismatch"))

(defop mismatch req (mismatch-message))

(mac uform (user req after . body)
  `(aform (fn (,req)
            (when-umatch ,user ,req
              ,after))
     ,@body))

(mac urform (user req after . body)
  `(arform (fn (,req)
             (when-umatch/r ,user ,req
               ,after))
     ,@body))

; Like onlink, but checks that user submitting the request is the
; same it was generated for.  For extra protection could log the
; username and ip addr of every genlink, and check if they match.

(mac ulink (user text . body)
  (w/uniq req
    `(linkf ,text (,req)
       (when-umatch ,user ,req ,@body))))

(defop admin req (admin-gate (get-user req)))

(def admin-gate (u)
  (if (admin u)
      (admin-page u)
      (login-page 'login nil
                  (fn (u ip)  (admin-gate u)))))

(def admin (u) (and u (mem u admins*)))

(def user-exists (u) (and u (hpasswords* u) u))

(def admin-page (user . msg)
  (whitepage
    (prbold "Admin: ")
    (hspace 20)
    (pr user " | ")
    (w/link (do (logout-user user)
                (whitepage (pr "Bye " user ".")))
      (pr "logout"))
    (when msg (hspace 10) (map pr msg))
    (br2)
    (aform (fn (req)
             (when-umatch user req
               (with (u (arg req "acct") p (arg req "pw"))
                 (if (or (no u) (no p) (is u "") (is p ""))
                      (pr "Bad data.")
                     (user-exists u)
                      (admin-page user "User already exists: " u)
                      (do (create-acct u p)
                          (admin-page user))))))
      (pwfields "create (server) account"))))

(def cook-user ((o user (get-user)) (o cookie (get-cookie "user")) (o alt))
  (when user
    (let id (if (is cookie t) (new-user-cookie user) cookie)
      (unless alt
        (= (user->cookie* user) id))
      (unless (is (cookie->user* id) user)
        (= (cookie->user* id) user)
        (save-table cookie->user* cookfile*))
      id)))

(def cook-user! ((o user (get-user)) (o cookie (new-user-cookie user)))
  (whenlet c (cook-user user cookie)
    (prcookie c)
    (= (logins* user) (get-ip))
    c))

(def ensure-user ((o user (get-user)))
  (whenlet c (cook-user user)
    ; upgrade old user cookies
    (when (< (len c) 16)
      (cook-user! user))
    user))

(defhook respond-headers (str req f redir)
  (ensure-user)
  nil)

; Unique-ids are only unique per server invocation.

(def new-user-cookie (user)
  (let id (sym:string user "&" (unique-id))
    (if (cookie->user* id) (new-user-cookie user) id)))

(def user-cookies ((o user (get-user)))
  (accum a
    (each (c u) cookie->user*
      (when (is u user)
        (a c)))))

(def logout-user ((o user (get-user)))
  (each c (user-cookies user)
    (wipe (cookie->user* c)))
  (save-table cookie->user* cookfile*)
  (wipe (user->cookie* user))
  (wipe (logins* user)))

(def create-acct (user pw (o email))
  (set (dc-usernames* (downcase user)))
  (set-pw user pw)
  (= (user->email* user) email))

(def disable-acct (user)
  (set-pw user (rand-string 20))
  (logout-user user))

(= bcrypt-work-factor* 10) ; must be >= 10

(def rand-salt ((o work-factor bcrypt-work-factor*))
  (+ "$2b$" (int work-factor) "$" (rand-string 22)))

(def clean-hash (h)
  (last:tokens h))

(def user-pw (user)
  (and user (clean-hash:hpasswords* user)))

(def bcrypt-pw (user pw)
  (aand (<= (len pw) 72) (user-pw user) (is it (bcrypt pw it nil))))

(def sha1-pw (user pw)
  (aand (<= (len pw) 72) (user-pw user) (is it (shash pw))))

(def check-pw (user pw)
  (or (bcrypt-pw user pw)
      (and (sha1-pw user pw)
           (do (set-pw user pw)
               (bcrypt-pw user pw)))))

(def set-pw (user pw)
  (= (hpasswords* user) (bcrypt pw (rand-salt)))
  (save-table hpasswords* hpwfile*))

(def hello-page (user ip)
  (whitepage (prs "hello" user "at" ip)))

(defop login req (login-page 'both))

; switch is one of: register, login, both

; afterward is either a function on the newly created username and
; ip address, in which case it is called to generate the next page
; after a successful login, or a pair of (function url), which means
; call the function, then redirect to the url.

; classic example of something that should just "return" a val
; via a continuation rather than going to a new page.

(def login-page (switch (o msg nil) (o afterward hello-page))
  (whitepage
    (pagemessage msg)
    (when (in switch 'login 'both)
      (login-form "Login" switch login-handler afterward)
      (hook 'login-form afterward)
      (br2))
    (when (in switch 'register 'both)
      (login-form "Create Account" switch create-handler afterward))))

(def login-form (label switch handler afterward)
  (prbold label)
  (br2)
  (fnform (fn (req) (handler req switch afterward))
          (fn () (pwfields (downcase label)))
          (acons afterward)))

(def login-handler (req switch afterward)
  (logout-user (get-user req))
  (aif (good-login (arg req "acct") (arg req "pw") req!ip)
       (login it req!ip (user->cookie* it) afterward)
       (failed-login switch "Bad login." afterward)))

(def create-handler (req switch afterward)
  (logout-user (get-user req))
  (with (user (arg req "acct") pw (arg req "pw") email (arg req "email"))
    (aif (bad-newacct user pw)
         (failed-login switch it afterward)
         (do (create-acct user pw email)
             (login user req!ip (cook-user! user) afterward)))))

(def login (user ip cookie afterward)
  (= (logins* user) ip)
  (prcookie cookie)
  (if (acons afterward)
      (let (f url) afterward
        (f user ip)
        url)
      (do (prn)
          (afterward user ip))))

(def failed-login (switch msg afterward)
  (if (acons afterward)
      (flink (fn ignore (login-page switch msg afterward)))
      (do (prn)
          (login-page switch msg afterward))))

(def prcookie (cook (o key 'user) (o httponly (is key 'user)))
  (prn:string
    "Set-Cookie: " key "=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"
    (if httponly "; HttpOnly")
    (if (srvsecure) "; Secure")))

(def pwfields ((o label "login"))
  (if (headmatch "create" label)
      (inputs (acct  username 20 nil 'plain)
              (pw    password 20 nil)
              (email email?   20 nil 'plain))
      (inputs (acct  username 20 nil 'plain 'autofocus)
              (pw    password 20 nil)))
  (br)
  (submit label))

(^ good-logins* (queue) bad-logins* (queue))

(def good-login (user pw ip)
  (let record (list (seconds) ip user)
    (if (check-pw user pw)
        (do (unless (user->cookie* user) (cook-user! user))
            (enq-limit record good-logins*)
            user)
        (do (enq-limit record bad-logins*)
            nil))))

(def shash (str)
  (w/stdin (instring str)
    (clean-hash:shell "openssl" 'dgst '-sha1)))

(^ dc-usernames* (table))

(def username-taken (user)
  (when (empty dc-usernames*)
    (each (k v) hpasswords*
      (set (dc-usernames* (downcase k)))))
  (dc-usernames* (downcase user)))

(def bad-newacct (user pw)
  (if (no (goodname user 2 15))
       "Usernames can only contain letters, digits, dashes and
        underscores, and should be between 2 and 15 characters long.
        Please choose another."
      (username-taken user)
       "That username is taken. Please choose another."
      (or (no pw) (< (len pw) 4))
       "Passwords should be a least 4 characters long.  Please
        choose another."
       nil))

(def goodname (str (o min 1) (o max nil))
  (and (isa str 'string)
       (>= (len str) min)
       (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
              str)
       (isnt (str 0) #\-)
       (or (no max) (<= (len str) max))
       str))

(defop logout req
  (aif (get-user req)
       (do (logout-user it)
           (pr "Logged out."))
       (pr "You were not logged in.")))

(defop whoami req
  (aif (get-user req)
       (if (admin it)
           (prs it 'at req!ip (tostring:write:the-req*))
           (prs it 'at req!ip))
       (do (pr "You are not logged in. ")
           (w/link (login-page 'both) (pr "Log in"))
           (pr "."))))

(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)

; Eventually figure out a way to separate type name from format of
; input field, instead of having e.g. toks and bigtoks

(def varfield (typ id val)
  (if (in typ 'string 'string1 'url)
       (gentag input type 'text name id value val size formwid*)
      (in typ 'num 'int 'posint 'sym)
       (gentag input type 'text name id value val size numwid*)
      (in typ 'users 'toks)
       (gentag input type 'text name id value (tostring (apply prs val))
                     size formwid*)
      (is typ 'sexpr)
       (gentag input type 'text name id
                     value (tostring (map [do (write _) (sp)] val))
                     size formwid*)
      (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
       (let text (if (in typ 'syms 'bigtoks)
                      (tostring (apply prs val))
                     (is typ 'lines)
                      (tostring (apply pr (intersperse #\newline val)))
                     (in typ 'mdtext 'mdtext2)
                      (unmarkdown val)
                     (no val)
                      ""
                     val)
         (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
                        rows (needrows text formwid* 4)
                        wrap 'virtual
                        style (if (is typ 'doc) "font-size:8.5pt")
                        name id)
           (prn) ; needed or 1 initial newline gets chopped off
           (pr text))
         (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
           (pr " ")
           (tag (font size -2)
             (link "help" formatdoc-url* (gray 175)))))
      (caris typ 'choice)
       (menu id (cddr typ) val)
      (is typ 'yesno)
       (menu id '("yes" "no") (if val "yes" "no"))
      (is typ 'hexcol)
       (gentag input type 'text name id value val)
      (is typ 'time)
       (gentag input type 'text name id value (if val (english-time val) ""))
      (is typ 'date)
       (gentag input type 'text name id value (if val (english-date val) ""))
       (err "unknown varfield type" typ)))

(def text-rows (text wid (o pad 3))
  (+ (trunc (/ (len text) (* wid .8))) pad))

(def needrows (text cols (o pad 0))
  (+ pad (max (+ 1 (count #\newline text))
              (roundup (/ (len text) (- cols 5))))))

(def varline (typ id val (o liveurls))
  (if (in typ 'users 'syms 'toks 'bigtoks)  (apply prs val)
      (is typ 'lines)                       (map prn val)
      (is typ 'yesno)                       (pr (if val 'yes 'no))
      (caris typ 'choice)                   (varline (cadr typ) nil val)
      (is typ 'url)                         (if (and liveurls (valid-url val))
                                                (link val val)
                                                (pr val))
      (text-type typ)                       (pr (or val ""))
                                            (pr val)))

(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))

; Newlines in forms come back as /r/n.  Only want the /ns. Currently
; remove the /rs in individual cases below.  Could do it in aform or
; even in the parsing of http requests, in the server.

; Need the calls to striptags so that news users can't get html
; into a title or comment by editing it.  If want a form that
; can take html, just create another typ for it.

(def readvar (typ str (o fail nil))
  (case (carif typ)
    string  (striptags str)
    string1 (if (blank str) fail (striptags str))
    url     (if (blank str) "" (valid-url str) (clean-url str) fail)
    num     (let n (saferead str) (if (number n) n fail))
    int     (let n (saferead str)
              (if (number n) (round n) fail))
    posint  (let n (saferead str)
              (if (and (number n) (> n 0)) (round n) fail))
    text    (striptags str)
    doc     (striptags str)
    mdtext  (md-from-form str)
    mdtext2 (md-from-form str t)                      ; for md with no links
    sym     (or (sym:car:tokens str) fail)
    syms    (map sym (tokens str))
    sexpr   (errsafe (readall str))
    users   (rem [no (goodname _)] (tokens str))
    toks    (tokens str)
    bigtoks (tokens str)
    lines   (lines str)
    choice  (readvar (cadr typ) str)
    yesno   (is str "yes")
    hexcol  (if (hex>color str) str fail)
    time    (or (errsafe (parse-time str)) fail)
    date    (or (errsafe (parse-date str)) fail)
            (err "unknown readvar type" typ)))

; dates should be tagged date, and just redefine <

(def varcompare (typ)
  (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
       (fn (x y) (> (len x) (len y)))
      (is typ 'date)
       (fn (x y)
         (or (no y) (and x (date< x y))))
       (fn (x y)
         (or (empty y) (and (~empty x) (< x y))))))

; (= fail* (uniq))

(def fail* ()) ; coudn't possibly come back from a form

; Takes a list of fields of the form (type label value view modify) and
; a fn f and generates a form such that when submitted (f label newval)
; will be called for each valid value.  Finally done is called.

(def vars-form (user fields f done (o button "update") (o lasts))
  (taform lasts
          (if (all [no (_ 4)] fields)
              (fn (req))
              (fn (req)
                (when-umatch user req
                  (each (k v) req!args
                    (let name (sym k)
                      (awhen (find [is (cadr _) name] fields)
                        ; added sho to fix bug
                        (let (typ id val sho mod) it
                          (when (and mod v)
                            (let newval (readvar typ v fail*)
                              (unless (is newval fail*)
                                (f name newval))))))))
                  (done))))
     (tab
       (showvars fields))
     (unless (all [no (_ 4)] fields)  ; no modifiable fields
       (br)
       (submit button))))

(def showvars (fields (o liveurls))
  (each (typ id val view mod question (o n 1)) (rem empty fields)
    (when view
      (when question
        (tr (repeat n (td)) (td (prn question))))
      (tr (if question
              (repeat n (td))
              (tag (td valign 'top)  (pr id ":")))
          (td (if mod
                  (varfield typ id val)
                  (varline  typ id val liveurls))))
      (prn))))

; http://daringfireball.net/projects/markdown/syntax

(def md-from-form (str (o nolinks) (o esc))
  (markdown (trim (rem #\return (if esc str (esc-tags str))) 'end) 100 nolinks))

(def markdown (s (o maxurl) (o nolinks))
  (with (ital nil bold nil)
    (tostring
      (forlen i s
        (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
               (do (pr  "

")
                 (let cb (code-block s (- newi spaces 1))
                   (pr cb)
                   (= i (+ (- newi spaces 1) (len cb))))
                 (pr "
"))
               (iflet newi (parabreak s i (if (is i 0) 1 0))
                      (do (unless (is i 0) (pr "
"))
                          (= i (- newi 1)))
                      (and (is (s i) #\*)
                           (or ital
                               (atend i s)
                               (and (~whitec (s (+ i 1)))
                                    (pos #\* s (+ i 1)))))
                       (do (pr (if ital "" ""))
                           (= ital (no ital)))
                      (and (is (s i) #\_)
                           (or bold
                               (atend i s)
                               (and (~whitec (s (+ i 1)))
                                    (pos #\_ s (+ i 1)))))
                       (do (pr (if bold "" ""))
                           (= bold (no bold)))
                      (and (no nolinks)
                           (and (or (litmatch "http://" s i)
                                    (litmatch "https://" s i)
                                    (litmatch "/l/" s i))
                                (or (is i 0) (~in (s (- i 1)) #\" #\>))))
                       (withs (n   (urlend s i)
                               url (clean-url (cut s i n)))
                         (tag (a href url rel 'nofollow)
                           (pr (if (no maxurl) url (ellipsize url maxurl))))
                         (= i (- n 1)))
                       (writec (s i))))))))

(def indented-code (s i (o newlines 0) (o spaces 0))
  (let c (s i)
    (if (nonwhite c)
         (if (and (> newlines 1) (> spaces 1))
             (list i spaces)
             nil)
        (atend i s)
         nil
        (is c #\newline)
         (indented-code s (+ i 1) (+ newlines 1) 0)
         (indented-code s (+ i 1) newlines       (+ spaces 1)))))

; If i is start a paragraph break, returns index of start of next para.

(def parabreak (s i (o newlines 0))
  (let c (s i)
    (if (or (nonwhite c) (atend i s))
        (if (> newlines 1) i nil)
        (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))

; Returns the indices of the next paragraph break in s, if any.

(def next-parabreak (s i)
  (unless (atend i s)
    (aif (parabreak s i)
         (list i it)
         (next-parabreak s (+ i 1)))))

(def paras (s (o i 0))
  (if (atend i s)
      nil
      (iflet (endthis startnext) (next-parabreak s i)
             (cons (cut s i endthis)
                   (paras s startnext))
             (list (trim (cut s i) 'end)))))

; Returns the index of the first char not part of the url beginning
; at i, or len of string if url goes all the way to the end.

; Note that > immediately after a url (http://foo.com>) will cause
; an odd result, because the > gets escaped to something beginning
; with &, which is treated as part of the url.  Perhaps the answer
; is just to esc-tags after markdown instead of before.

; Treats a delimiter as part of a url if it is (a) an open delimiter
; not followed by whitespace or eos, or (b) a close delimiter
; balancing a previous open delimiter.

(def urlend (s i (o indelim))
  (let c (s i)
    (if (atend i s)
         (if ((orf punc whitec opendelim) c)
              i
             (closedelim c)
              (if indelim (+ i 1) i)
             (+ i 1))
        (if (or (whitec c)
                (and (punc c) (whitec (s (+ i 1))))
                (and ((orf whitec punc) (s (+ i 1)))
                     (or (opendelim c)
                         (and (closedelim c) (no indelim)))))
            i
            (urlend s (+ i 1) (or (opendelim c)
                                  (and indelim (no (closedelim c)))))))))

(def opendelim (c)  (in c #\< #\( #\[ #\{))

(def closedelim (c) (in c #\> #\) #\] #\}))

(def code-block (s i)
  (tostring
    (until (let left (- (len s) i 1)
             (or (is left 0)
                 (and (> left 2)
                      (is (s (+ i 1)) #\newline)
                      (nonwhite (s (+ i 2))))))
     (writec (s (++ i))))))

(def unmarkdown (s (o skiplinks))
  (tostring
    (forlen i s
      (if (litmatch "
" s i)
           (do (++ i 2)
               (unless (is i 2) (pr "\n\n")))
          (litmatch "" s i)
           (do (++ i 2) (pr #\*))
          (litmatch "" s i)
           (do (++ i 3) (pr #\*))
          (litmatch "" s i)
           (do (++ i 2) (pr #\_))
          (litmatch "" s i)
           (do (++ i 3) (pr #\_))
          (unless skiplinks
            (litmatch " #\space] s (+ i 9))
             (if endurl
                 (do (pr (cut s (+ i 9) (- endurl 1)))
                     (= i (aif (posmatch "" s endurl)
                               (+ it 3)
                               endurl)))
                 (writec (s i))))
          (litmatch "
" s i)
           (awhen (findsubseq "
" s (+ i 12))
             (pr (cut s (+ i 11) it))
             (= i (+ it 12)))
          (writec (s i))))))

(def english-time (min)
  (let n (mod min 720)
    (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
            ":"
            (let m (mod n 60)
              (if (is m 0) "00"
                  (< m 10) (string "0" m)
                           m))
            (if (is min 0)   " midnight"
                (is min 720) " noon"
                (>= min 720) " pm"
                             " am"))))

(def parse-time (s)
  (let (nums (o label "")) (halve s letter)
    (with ((h (o m 0)) (map int (tokens nums ~digit))
           cleanlabel  (downcase (rem ~alphadig label)))
      (+ (* (if (is h 12)
                 (if (in cleanlabel "am" "midnight")
                     0
                     12)
                (is cleanlabel "am")
                 h
                 (+ h 12))
            60)
          m))))

(= months* '("January" "February" "March" "April" "May" "June" "July"
             "August" "September" "October" "November" "December"))

(def english-date ((y m d))
  (string d " " (months* (- m 1)) " " y))

(= month-names* (obj "january"    1  "jan"        1
                     "february"   2  "feb"        2
                     "march"      3  "mar"        3
                     "april"      4  "apr"        4
                     "may"        5
                     "june"       6  "jun"        6
                     "july"       7  "jul"        7
                     "august"     8  "aug"        8
                     "september"  9  "sept"       9  "sep"      9
                     "october"   10  "oct"       10
                     "november"  11  "nov"       11
                     "december"  12  "dec"       12))

(def monthnum (s) (month-names* (downcase s)))

; Doesn't work for BC dates.

(def parse-date (s)
  (let nums (date-nums s)
    (if (valid-date nums)
        nums
        (err (string "Invalid date: " s)))))

(def date-nums (s)
  (with ((ynow mnow dnow) (date)
         toks             (tokens s ~alphadig))
    (if (all [all digit _] toks)
         (let nums (map int toks)
           (case (len nums)
             1 (list ynow mnow (car nums))
             2 (iflet d (find [> _ 12] nums)
                        (list ynow (find [isnt _ d] nums) d)
                        (cons ynow nums))
               (if (> (car nums) 31)
                   (firstn 3 nums)
                   (rev (firstn 3 nums)))))
        ([all digit _] (car toks))
         (withs ((ds ms ys) toks
                 d          (int ds))
           (aif (monthnum ms)
                (list (or (errsafe (int ys)) ynow)
                      it
                      d)
                nil))
        (monthnum (car toks))
         (let (ms ds ys) toks
           (aif (errsafe (int ds))
                (list (or (errsafe (int ys)) ynow)
                      (monthnum (car toks))
                      it)
                nil))
          nil)))

; To be correct needs to know days per month, and about leap years

(def valid-date ((y m d))
  (and y m d
       (< 0 m 13)
       (< 0 d 32)))

(mac defopl (name parm . body)
  `(defop ,name ,parm
     (if (get-user ,parm)
         (do ,@body)
         (login-page 'both
                     "You need to be logged in to do that."
                     (list (fn (u ip))
                           (string ',name (reassemble-args ,parm)))))))

(def shellquote (str)
  (+ "'" (multisubst (list (list "'" "'\"'\"'")) str) "'"))

(def shell (cmd . args)
  (tostring:system (+ (string cmd) " " (string:intersperse #\space (map shellquote:string (rem nil args))))))

(def GET (url)
  (shell "curl" "-fsSL" (clean-url url)))

(def fetch-title (url)
  (let s (GET url)
    (whenlet p1 (posmatch "<title" s)
      (whenlet p2 (posmatch "</title>" s p1)
        (whenlet p3 (posmatch ">" s p1)
          (trim (cut s (+ p3 1) p2)))))))

(defmemo moment (ms)
  (moment-ms ms))

(def moment-ms ((o ms (msec)))
  (with (secs (trunc (/ ms 1000))
         msecs (mod ms 1000))
    (trim:shell "date" "-ur" secs (+ "+%Y-%m-%dT%H:%M:%S." (leftpad msecs 3 "0") "Z"))))

(def moment-secs ((o secs (seconds)))
  (moment (* 1000 secs)))

(def send-email (from to subject message)
  (tostring:shell "python2" "../sendmail.py" from to subject message))

; Application Server.  Layer inserted 2 Sep 06.

; ideas:
; def a general notion of apps of which prompt is one, news another
; give each user a place to store data?  A home dir?

; A user is simply a string: "pg". Use /whoami to test user cookie.

(= hpwfile*   "arc/hpw"
   oidfile*   "arc/openids"
   adminfile* "arc/admins"
   cookfile*  "arc/cooks")

(def asv ((o port 8080))
  (load-userinfo)
  (serve port))

(def load-userinfo ()
  (= hpasswords*   (safe-load-table hpwfile*)
     openids*      (safe-load-table oidfile*)
     admins*       (map string (errsafe (readfile adminfile*)))
     cookie->user* (safe-load-table cookfile*))
  (maptable (fn (k v) (= (user->cookie* v) k))
            cookie->user*))

; idea: a bidirectional table, so don't need two vars (and sets)

(^ cookie->user* (table) user->cookie* (table) user->email* (table) logins* (table))

(def get-ip ((o req (the-req*)))
  (or req!ip "::1"))

(def get-cookie (key (o req (the-req*)))
  (alref req!cooks key))

(def get-user ((o req (the-req*)))
  (let u (aand (get-cookie "user" req)
               (cookie->user* (sym it)))
    (when u (= (logins* u) (get-ip req)))
    u))

(defmemo auth-hash (cookie)
  (shash:string cookie))

(def get-auth ((o user (get-user)))
  (aand user
        (user->cookie* user)
        (auth-hash it)))

(def is-auth (auth (o user (get-user)))
  (is auth (get-auth user)))

(mac when-umatch (user req . body)
  `(if (is ,user (get-user ,req))
       (do ,@body)
       (mismatch-message)))

(def mismatch-message ()
  (prn "Dead link: users don't match."))

(mac when-umatch/r (user req . body)
  `(if (is ,user (get-user ,req))
       (do ,@body)
       "mismatch"))

(defop mismatch req (mismatch-message))

(mac uform (user req after . body)
  `(aform (fn (,req)
            (when-umatch ,user ,req
              ,after))
     ,@body))

(mac urform (user req after . body)
  `(arform (fn (,req)
             (when-umatch/r ,user ,req
               ,after))
     ,@body))

; Like onlink, but checks that user submitting the request is the
; same it was generated for.  For extra protection could log the
; username and ip addr of every genlink, and check if they match.

(mac ulink (user text . body)
  (w/uniq req
    `(linkf ,text (,req)
       (when-umatch ,user ,req ,@body))))

(defop admin req (admin-gate (get-user req)))

(def admin-gate (u)
  (if (admin u)
      (admin-page u)
      (login-page 'login nil
                  (fn (u ip)  (admin-gate u)))))

(def admin (u) (and u (mem u admins*)))

(def user-exists (u) (and u (hpasswords* u) u))

(def admin-page (user . msg)
  (whitepage
    (prbold "Admin: ")
    (hspace 20)
    (pr user " | ")
    (w/link (do (logout-user user)
                (whitepage (pr "Bye " user ".")))
      (pr "logout"))
    (when msg (hspace 10) (map pr msg))
    (br2)
    (aform (fn (req)
             (when-umatch user req
               (with (u (arg req "u") p (arg req "p"))
                 (if (or (no u) (no p) (is u "") (is p ""))
                      (pr "Bad data.")
                     (user-exists u)
                      (admin-page user "User already exists: " u)
                      (do (create-acct u p)
                          (admin-page user))))))
      (pwfields "create (server) account"))))

(def cook-user ((o user (get-user)) (o cookie (get-cookie "user")) (o alt))
  (when user
    (let id (if (is cookie t) (new-user-cookie user) cookie)
      (unless alt
        (= (user->cookie* user) id))
      (unless (is (cookie->user* id) user)
        (= (cookie->user* id) user)
        (save-table cookie->user* cookfile*))
      id)))

(def cook-user! ((o user (get-user)) (o cookie (new-user-cookie user)))
  (whenlet c (cook-user user cookie)
    (prcookie c)
    (= (logins* user) (get-ip))
    c))

(def ensure-user ((o user (get-user)))
  (whenlet c (cook-user user)
    ; upgrade old user cookies
    (when (< (len c) 16)
      (cook-user! user))
    user))

(defhook respond-headers (str req f redir)
  (ensure-user)
  nil)

; Unique-ids are only unique per server invocation.

(def new-user-cookie (user)
  (let id (sym:string user "&" (unique-id))
    (if (cookie->user* id) (new-user-cookie user) id)))

(def user-cookies ((o user (get-user)))
  (accum a
    (each (c u) cookie->user*
      (when (is u user)
        (a c)))))

(def logout-user ((o user (get-user)))
  (each c (user-cookies user)
    (wipe (cookie->user* c)))
  (save-table cookie->user* cookfile*)
  (wipe (user->cookie* user))
  (wipe (logins* user)))

(def create-acct (user pw (o email))
  (set (dc-usernames* (downcase user)))
  (set-pw user pw)
  (= (user->email* user) email))

(def disable-acct (user)
  (set-pw user (rand-string 20))
  (logout-user user))

(= bcrypt-work-factor* 10) ; must be >= 10

(def rand-salt ((o work-factor bcrypt-work-factor*))
  (+ "$2b$" (int work-factor) "$" (rand-string 22)))

(def clean-hash (h)
  (last:tokens h))

(def user-pw (user)
  (and user (clean-hash:hpasswords* user)))

(def bcrypt-pw (user pw)
  (aand (<= (len pw) 72) (user-pw user) (is it (bcrypt pw it nil))))

(def sha1-pw (user pw)
  (aand (<= (len pw) 72) (user-pw user) (is it (shash pw))))

(def check-pw (user pw)
  (or (bcrypt-pw user pw)
      (and (sha1-pw user pw)
           (do (set-pw user pw)
               (bcrypt-pw user pw)))))

(def set-pw (user pw)
  (= (hpasswords* user) (bcrypt pw (rand-salt)))
  (save-table hpasswords* hpwfile*))

(def hello-page (user ip)
  (whitepage (prs "hello" user "at" ip)))

(defop login req (login-page 'both))

; switch is one of: register, login, both

; afterward is either a function on the newly created username and
; ip address, in which case it is called to generate the next page
; after a successful login, or a pair of (function url), which means
; call the function, then redirect to the url.

; classic example of something that should just "return" a val
; via a continuation rather than going to a new page.

(def login-page (switch (o msg nil) (o afterward hello-page))
  (whitepage
    (pagemessage msg)
    (when (in switch 'login 'both)
      (login-form "Login" switch login-handler afterward)
      (hook 'login-form afterward)
      (br2))
    (when (in switch 'register 'both)
      (login-form "Create Account" switch create-handler afterward))))

(def login-form (label switch handler afterward)
  (prbold label)
  (br2)
  (fnform (fn (req) (handler req switch afterward))
          (fn () (pwfields (downcase label)))
          (acons afterward)))

(def login-handler (req switch afterward)
  (logout-user (get-user req))
  (aif (good-login (arg req "u") (arg req "p") req!ip)
       (login it req!ip (user->cookie* it) afterward)
       (failed-login switch "Bad login." afterward)))

(def create-handler (req switch afterward)
  (logout-user (get-user req))
  (with (user (arg req "u") pw (arg req "p") email (arg req "e"))
    (aif (bad-newacct user pw)
         (failed-login switch it afterward)
         (do (create-acct user pw email)
             (login user req!ip (cook-user! user) afterward)))))

(def login (user ip cookie afterward)
  (= (logins* user) ip)
  (prcookie cookie)
  (if (acons afterward)
      (let (f url) afterward
        (f user ip)
        url)
      (do (prn)
          (afterward user ip))))

(def failed-login (switch msg afterward)
  (if (acons afterward)
      (flink (fn ignore (login-page switch msg afterward)))
      (do (prn)
          (login-page switch msg afterward))))

(def prcookie (cook (o key 'user) (o httponly (is key 'user)))
  (prn:string
    "Set-Cookie: " key "=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"
    (if httponly "; HttpOnly")
    (if (srvsecure) "; Secure")))

(def pwfields ((o label "login"))
  (if (headmatch "create" label)
      (inputs (u username 20 nil 'plain)
              (p password 20 nil)
              (e email?   20 nil 'plain))
      (inputs (u username 20 nil 'plain 'autofocus)
              (p password 20 nil)))
  (br)
  (submit label))

(^ good-logins* (queue) bad-logins* (queue))

(def good-login (user pw ip)
  (let record (list (seconds) ip user)
    (if (check-pw user pw)
        (do (unless (user->cookie* user) (cook-user! user))
            (enq-limit record good-logins*)
            user)
        (do (enq-limit record bad-logins*)
            nil))))

(def shash (str)
  (w/stdin (instring str)
    (clean-hash:shell "openssl" 'dgst '-sha1)))

(^ dc-usernames* (table))

(def username-taken (user)
  (when (empty dc-usernames*)
    (each (k v) hpasswords*
      (set (dc-usernames* (downcase k)))))
  (dc-usernames* (downcase user)))

(def bad-newacct (user pw)
  (if (no (goodname user 2 15))
       "Usernames can only contain letters, digits, dashes and
        underscores, and should be between 2 and 15 characters long.
        Please choose another."
      (username-taken user)
       "That username is taken. Please choose another."
      (or (no pw) (< (len pw) 4))
       "Passwords should be a least 4 characters long.  Please
        choose another."
       nil))

(def goodname (str (o min 1) (o max nil))
  (and (isa str 'string)
       (>= (len str) min)
       (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
              str)
       (isnt (str 0) #\-)
       (or (no max) (<= (len str) max))
       str))

(defop logout req
  (aif (get-user req)
       (do (logout-user it)
           (pr "Logged out."))
       (pr "You were not logged in.")))

(defop whoami req
  (aif (get-user req)
       (if (admin it)
           (prs it 'at req!ip (tostring:write:the-req*))
           (prs it 'at req!ip))
       (do (pr "You are not logged in. ")
           (w/link (login-page 'both) (pr "Log in"))
           (pr "."))))

(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)

; Eventually figure out a way to separate type name from format of
; input field, instead of having e.g. toks and bigtoks

(def varfield (typ id val)
  (if (in typ 'string 'string1 'url)
       (gentag input type 'text name id value val size formwid*)
      (in typ 'num 'int 'posint 'sym)
       (gentag input type 'text name id value val size numwid*)
      (in typ 'users 'toks)
       (gentag input type 'text name id value (tostring (apply prs val))
                     size formwid*)
      (is typ 'sexpr)
       (gentag input type 'text name id
                     value (tostring (map [do (write _) (sp)] val))
                     size formwid*)
      (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
       (let text (if (in typ 'syms 'bigtoks)
                      (tostring (apply prs val))
                     (is typ 'lines)
                      (tostring (apply pr (intersperse #\newline val)))
                     (in typ 'mdtext 'mdtext2)
                      (unmarkdown val)
                     (no val)
                      ""
                     val)
         (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
                        rows (needrows text formwid* 4)
                        wrap 'virtual
                        style (if (is typ 'doc) "font-size:8.5pt")
                        name id)
           (prn) ; needed or 1 initial newline gets chopped off
           (pr text))
         (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
           (pr " ")
           (tag (font size -2)
             (link "help" formatdoc-url* (gray 175)))))
      (caris typ 'choice)
       (menu id (cddr typ) val)
      (is typ 'yesno)
       (menu id '("yes" "no") (if val "yes" "no"))
      (is typ 'hexcol)
       (gentag input type 'text name id value val)
      (is typ 'time)
       (gentag input type 'text name id value (if val (english-time val) ""))
      (is typ 'date)
       (gentag input type 'text name id value (if val (english-date val) ""))
       (err "unknown varfield type" typ)))

(def text-rows (text wid (o pad 3))
  (+ (trunc (/ (len text) (* wid .8))) pad))

(def needrows (text cols (o pad 0))
  (+ pad (max (+ 1 (count #\newline text))
              (roundup (/ (len text) (- cols 5))))))

(def varline (typ id val (o liveurls))
  (if (in typ 'users 'syms 'toks 'bigtoks)  (apply prs val)
      (is typ 'lines)                       (map prn val)
      (is typ 'yesno)                       (pr (if val 'yes 'no))
      (caris typ 'choice)                   (varline (cadr typ) nil val)
      (is typ 'url)                         (if (and liveurls (valid-url val))
                                                (link val val)
                                                (pr val))
      (text-type typ)                       (pr (or val ""))
                                            (pr val)))

(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))

; Newlines in forms come back as /r/n.  Only want the /ns. Currently
; remove the /rs in individual cases below.  Could do it in aform or
; even in the parsing of http requests, in the server.

; Need the calls to striptags so that news users can't get html
; into a title or comment by editing it.  If want a form that
; can take html, just create another typ for it.

(def readvar (typ str (o fail nil))
  (case (carif typ)
    string  (striptags str)
    string1 (if (blank str) fail (striptags str))
    url     (if (blank str) "" (valid-url str) (clean-url str) fail)
    num     (let n (saferead str) (if (number n) n fail))
    int     (let n (saferead str)
              (if (number n) (round n) fail))
    posint  (let n (saferead str)
              (if (and (number n) (> n 0)) (round n) fail))
    text    (striptags str)
    doc     (striptags str)
    mdtext  (md-from-form str)
    mdtext2 (md-from-form str t)                      ; for md with no links
    sym     (or (sym:car:tokens str) fail)
    syms    (map sym (tokens str))
    sexpr   (errsafe (readall str))
    users   (rem [no (goodname _)] (tokens str))
    toks    (tokens str)
    bigtoks (tokens str)
    lines   (lines str)
    choice  (readvar (cadr typ) str)
    yesno   (is str "yes")
    hexcol  (if (hex>color str) str fail)
    time    (or (errsafe (parse-time str)) fail)
    date    (or (errsafe (parse-date str)) fail)
            (err "unknown readvar type" typ)))

; dates should be tagged date, and just redefine <

(def varcompare (typ)
  (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
       (fn (x y) (> (len x) (len y)))
      (is typ 'date)
       (fn (x y)
         (or (no y) (and x (date< x y))))
       (fn (x y)
         (or (empty y) (and (~empty x) (< x y))))))

; (= fail* (uniq))

(def fail* ()) ; coudn't possibly come back from a form

; Takes a list of fields of the form (type label value view modify) and
; a fn f and generates a form such that when submitted (f label newval)
; will be called for each valid value.  Finally done is called.

(def vars-form (user fields f done (o button "update") (o lasts))
  (taform lasts
          (if (all [no (_ 4)] fields)
              (fn (req))
              (fn (req)
                (when-umatch user req
                  (each (k v) req!args
                    (let name (sym k)
                      (awhen (find [is (cadr _) name] fields)
                        ; added sho to fix bug
                        (let (typ id val sho mod) it
                          (when (and mod v)
                            (let newval (readvar typ v fail*)
                              (unless (is newval fail*)
                                (f name newval))))))))
                  (done))))
     (tab
       (showvars fields))
     (unless (all [no (_ 4)] fields)  ; no modifiable fields
       (br)
       (submit button))))

(def showvars (fields (o liveurls))
  (each (typ id val view mod question (o n 1)) (rem empty fields)
    (when view
      (when question
        (tr (repeat n (td)) (td (prn question))))
      (tr (if question
              (repeat n (td))
              (tag (td valign 'top)  (pr id ":")))
          (td (if mod
                  (varfield typ id val)
                  (varline  typ id val liveurls))))
      (prn))))

; http://daringfireball.net/projects/markdown/syntax

(def md-from-form (str (o nolinks) (o esc))
  (markdown (trim (rem #\return (if esc str (esc-tags str))) 'end) 100 nolinks))

(def markdown (s (o maxurl) (o nolinks))
  (with (ital nil bold nil)
    (tostring
      (forlen i s
        (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
               (do (pr  "

")
                 (let cb (code-block s (- newi spaces 1))
                   (pr cb)
                   (= i (+ (- newi spaces 1) (len cb))))
                 (pr "
"))
               (iflet newi (parabreak s i (if (is i 0) 1 0))
                      (do (unless (is i 0) (pr "
"))
                          (= i (- newi 1)))
                      (and (is (s i) #\*)
                           (or ital
                               (atend i s)
                               (and (~whitec (s (+ i 1)))
                                    (pos #\* s (+ i 1)))))
                       (do (pr (if ital "" ""))
                           (= ital (no ital)))
                      (and (is (s i) #\_)
                           (or bold
                               (atend i s)
                               (and (~whitec (s (+ i 1)))
                                    (pos #\_ s (+ i 1)))))
                       (do (pr (if bold "" ""))
                           (= bold (no bold)))
                      (and (no nolinks)
                           (and (or (litmatch "http://" s i)
                                    (litmatch "https://" s i)
                                    (litmatch "/l/" s i))
                                (or (is i 0) (~in (s (- i 1)) #\" #\>))))
                       (withs (n   (urlend s i)
                               url (clean-url (cut s i n)))
                         (tag (a href url rel 'nofollow)
                           (pr (if (no maxurl) url (ellipsize url maxurl))))
                         (= i (- n 1)))
                       (writec (s i))))))))

(def indented-code (s i (o newlines 0) (o spaces 0))
  (let c (s i)
    (if (nonwhite c)
         (if (and (> newlines 1) (> spaces 1))
             (list i spaces)
             nil)
        (atend i s)
         nil
        (is c #\newline)
         (indented-code s (+ i 1) (+ newlines 1) 0)
         (indented-code s (+ i 1) newlines       (+ spaces 1)))))

; If i is start a paragraph break, returns index of start of next para.

(def parabreak (s i (o newlines 0))
  (let c (s i)
    (if (or (nonwhite c) (atend i s))
        (if (> newlines 1) i nil)
        (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))

; Returns the indices of the next paragraph break in s, if any.

(def next-parabreak (s i)
  (unless (atend i s)
    (aif (parabreak s i)
         (list i it)
         (next-parabreak s (+ i 1)))))

(def paras (s (o i 0))
  (if (atend i s)
      nil
      (iflet (endthis startnext) (next-parabreak s i)
             (cons (cut s i endthis)
                   (paras s startnext))
             (list (trim (cut s i) 'end)))))

; Returns the index of the first char not part of the url beginning
; at i, or len of string if url goes all the way to the end.

; Note that > immediately after a url (http://foo.com>) will cause
; an odd result, because the > gets escaped to something beginning
; with &, which is treated as part of the url.  Perhaps the answer
; is just to esc-tags after markdown instead of before.

; Treats a delimiter as part of a url if it is (a) an open delimiter
; not followed by whitespace or eos, or (b) a close delimiter
; balancing a previous open delimiter.

(def urlend (s i (o indelim))
  (let c (s i)
    (if (atend i s)
         (if ((orf punc whitec opendelim) c)
              i
             (closedelim c)
              (if indelim (+ i 1) i)
             (+ i 1))
        (if (or (whitec c)
                (and (punc c) (whitec (s (+ i 1))))
                (and ((orf whitec punc) (s (+ i 1)))
                     (or (opendelim c)
                         (and (closedelim c) (no indelim)))))
            i
            (urlend s (+ i 1) (or (opendelim c)
                                  (and indelim (no (closedelim c)))))))))

(def opendelim (c)  (in c #\< #\( #\[ #\{))

(def closedelim (c) (in c #\> #\) #\] #\}))

(def code-block (s i)
  (tostring
    (until (let left (- (len s) i 1)
             (or (is left 0)
                 (and (> left 2)
                      (is (s (+ i 1)) #\newline)
                      (nonwhite (s (+ i 2))))))
     (writec (s (++ i))))))

(def unmarkdown (s (o skiplinks))
  (tostring
    (forlen i s
      (if (litmatch "
" s i)
           (do (++ i 2)
               (unless (is i 2) (pr "\n\n")))
          (litmatch "" s i)
           (do (++ i 2) (pr #\*))
          (litmatch "" s i)
           (do (++ i 3) (pr #\*))
          (litmatch "" s i)
           (do (++ i 2) (pr #\_))
          (litmatch "" s i)
           (do (++ i 3) (pr #\_))
          (unless skiplinks
            (litmatch " #\space] s (+ i 9))
             (if endurl
                 (do (pr (cut s (+ i 9) (- endurl 1)))
                     (= i (aif (posmatch "" s endurl)
                               (+ it 3)
                               endurl)))
                 (writec (s i))))
          (litmatch "
" s i)
           (awhen (findsubseq "
" s (+ i 12))
             (pr (cut s (+ i 11) it))
             (= i (+ it 12)))
          (writec (s i))))))

(def english-time (min)
  (let n (mod min 720)
    (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
            ":"
            (let m (mod n 60)
              (if (is m 0) "00"
                  (< m 10) (string "0" m)
                           m))
            (if (is min 0)   " midnight"
                (is min 720) " noon"
                (>= min 720) " pm"
                             " am"))))

(def parse-time (s)
  (let (nums (o label "")) (halve s letter)
    (with ((h (o m 0)) (map int (tokens nums ~digit))
           cleanlabel  (downcase (rem ~alphadig label)))
      (+ (* (if (is h 12)
                 (if (in cleanlabel "am" "midnight")
                     0
                     12)
                (is cleanlabel "am")
                 h
                 (+ h 12))
            60)
          m))))

(= months* '("January" "February" "March" "April" "May" "June" "July"
             "August" "September" "October" "November" "December"))

(def english-date ((y m d))
  (string d " " (months* (- m 1)) " " y))

(= month-names* (obj "january"    1  "jan"        1
                     "february"   2  "feb"        2
                     "march"      3  "mar"        3
                     "april"      4  "apr"        4
                     "may"        5
                     "june"       6  "jun"        6
                     "july"       7  "jul"        7
                     "august"     8  "aug"        8
                     "september"  9  "sept"       9  "sep"      9
                     "october"   10  "oct"       10
                     "november"  11  "nov"       11
                     "december"  12  "dec"       12))

(def monthnum (s) (month-names* (downcase s)))

; Doesn't work for BC dates.

(def parse-date (s)
  (let nums (date-nums s)
    (if (valid-date nums)
        nums
        (err (string "Invalid date: " s)))))

(def date-nums (s)
  (with ((ynow mnow dnow) (date)
         toks             (tokens s ~alphadig))
    (if (all [all digit _] toks)
         (let nums (map int toks)
           (case (len nums)
             1 (list ynow mnow (car nums))
             2 (iflet d (find [> _ 12] nums)
                        (list ynow (find [isnt _ d] nums) d)
                        (cons ynow nums))
               (if (> (car nums) 31)
                   (firstn 3 nums)
                   (rev (firstn 3 nums)))))
        ([all digit _] (car toks))
         (withs ((ds ms ys) toks
                 d          (int ds))
           (aif (monthnum ms)
                (list (or (errsafe (int ys)) ynow)
                      it
                      d)
                nil))
        (monthnum (car toks))
         (let (ms ds ys) toks
           (aif (errsafe (int ds))
                (list (or (errsafe (int ys)) ynow)
                      (monthnum (car toks))
                      it)
                nil))
          nil)))

; To be correct needs to know days per month, and about leap years

(def valid-date ((y m d))
  (and y m d
       (< 0 m 13)
       (< 0 d 32)))

(mac defopl (name parm . body)
  `(defop ,name ,parm
     (if (get-user ,parm)
         (do ,@body)
         (login-page 'both
                     "You need to be logged in to do that."
                     (list (fn (u ip))
                           (string ',name (reassemble-args ,parm)))))))

(def shellquote (str)
  (+ "'" (multisubst (list (list "'" "'\"'\"'")) str) "'"))

(def shell (cmd . args)
  (tostring:system (+ (string cmd) " " (string:intersperse #\space (map shellquote:string (rem nil args))))))

(def GET (url)
  (shell "curl" "-fsSL" (clean-url url)))

(def fetch-title (url)
  (let s (GET url)
    (whenlet p1 (posmatch "<title" s)
      (whenlet p2 (posmatch "</title>" s p1)
        (whenlet p3 (posmatch ">" s p1)
          (trim (cut s (+ p3 1) p2)))))))

(defmemo moment (ms)
  (moment-ms ms))

(def moment-ms ((o ms (msec)))
  (with (secs (trunc (/ ms 1000))
         msecs (mod ms 1000))
    (trim:shell "date" "-ur" secs (+ "+%Y-%m-%dT%H:%M:%S." (leftpad msecs 3 "0") "Z"))))

(def moment-secs ((o secs (seconds)))
  (moment (* 1000 secs)))

(def send-email (from to subject message)
  (tostring:shell "python2" "../sendmail.py" from to subject message))


Update blog.arc to not conflict with news.arc

; Blog tool example.  20 Jan 08, rev 21 May 09.

; To run:
; arc> (load "blog.arc")
; arc> (bsv)
; go to http://localhost:8080/blog

(^ postdir* "arc/posts/"  postid* 0  posts* (table))

(= blogtitle* "A Blog")

(deftem post  id nil  title nil  text nil)

(def load-posts ()
  (each id (map int (dir postdir*))
    (= postid*      (max postid* id)
       (posts* id) (temload 'post (string postdir* id)))))

(def save-post (p) (save-table p (string postdir* p!id)))

(def post (id) (posts* (errsafe:int id)))

(mac blogpage body
  `(whitepage
     (center
       (widtable 600
         (tag b (link blogtitle* "blog"))
         (br 3)
         ,@body
         (br 3)
         (w/bars (link "archive")
                 (link "new post" "newpost"))))))

(defop viewpost req (blogop post-page req))

(def blogop (f req)
  (aif (post (arg req "id"))
       (f (get-user req) it)
       (blogpage (pr "No such post."))))

(def post-url (p) (string "/viewpost?id=" p!id))

(def post-page (user p) (blogpage (display-post user p)))

(def display-post (user p)
  (tag b (link p!title (post-url p)))
  (when user
    (sp)
    (link "[edit]" (string "/editpost?id=" p!id)))
  (br2)
  (pr p!text))

(defopl newpost req
  (whitepage
    (aform [let u (get-user _)
             (post-page u (addpost u (arg _ "t") (md-from-form:arg _ "b")))]
      (tab (row "title" (input "t" "" 60))
           (row "text"  (textarea "b" 10 80))
           (row ""      (submit))))))

(def addpost (user title text)
  (let p (inst 'post 'id (++ postid*) 'title title 'text text)
    (save-post p)
    (= (posts* p!id) p)))

(defopl editpost req (blogop edit-post-page req))

(def edit-post-page (user p)
  (whitepage
    (vars-form user
               `((string title ,p!title t t)
                 (mdtext text  ,p!text  t t))
               (fn (name val) (= (p name) val))
               (fn () (save-post p)
                      (post-page user p)))))

(defop archive req
  (blogpage
    (tag ul
      (each p (map post (rev (range 1 postid*)))
        (tag li (link p!title (post-url p)))))))

(defop blog req
  (let user (get-user req)
    (blogpage
      (for i 0 4
        (awhen (posts* (- postid* i))
          (display-post user it)
          (br 3))))))

(def bsv ()
  (ensure-dir postdir*)
  (load-posts)
  (asv))

; Blog tool example.  20 Jan 08, rev 21 May 09.

; To run:
; arc> (load "blog.arc")
; arc> (bsv)
; go to http://localhost:8080/blog

(= postdir* "arc/posts/"  maxid* 0  posts* (table))

(= blogtitle* "A Blog")

(deftem post  id nil  title nil  text nil)

(def load-posts ()
  (each id (map int (dir postdir*))
    (= maxid*      (max maxid* id)
       (posts* id) (temload 'post (string postdir* id)))))

(def save-post (p) (save-table p (string postdir* p!id)))

(def post (id) (posts* (errsafe:int id)))

(mac blogpage body
  `(whitepage
     (center
       (widtable 600
         (tag b (link blogtitle* "blog"))
         (br 3)
         ,@body
         (br 3)
         (w/bars (link "archive")
                 (link "new post" "newpost"))))))

(defop viewpost req (blogop post-page req))

(def blogop (f req)
  (aif (post (arg req "id"))
       (f (get-user req) it)
       (blogpage (pr "No such post."))))

(def permalink (p) (string "viewpost?id=" p!id))

(def post-page (user p) (blogpage (display-post user p)))

(def display-post (user p)
  (tag b (link p!title (permalink p)))
  (when user
    (sp)
    (link "[edit]" (string "editpost?id=" p!id)))
  (br2)
  (pr p!text))

(defopl newpost req
  (whitepage
    (aform [let u (get-user _)
             (post-page u (addpost u (arg _ "t") (arg _ "b")))]
      (tab (row "title" (input "t" "" 60))
           (row "text"  (textarea "b" 10 80))
           (row ""      (submit))))))

(def addpost (user title text)
  (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
    (save-post p)
    (= (posts* p!id) p)))

(defopl editpost req (blogop edit-page req))

(def edit-page (user p)
  (whitepage
    (vars-form user
               `((string title ,p!title t t) (text text ,p!text t t))
               (fn (name val) (= (p name) val))
               (fn () (save-post p)
                      (post-page user p)))))

(defop archive req
  (blogpage
    (tag ul
      (each p (map post (rev (range 1 maxid*)))
        (tag li (link p!title (permalink p)))))))

(defop blog req
  (let user (get-user req)
    (blogpage
      (for i 0 4
        (awhen (posts* (- maxid* i))
          (display-post user it)
          (br 3))))))

(def bsv ()
  (ensure-dir postdir*)
  (load-posts)
  (asv))


dispatch was overriding fnform; I believe this fixes #4

(map load '("strings.arc"
            "code.arc"
            "html.arc"
            "srv.arc"
            "app.arc"
            "http.arc"
            "prompt.arc"))

; We define 'require here, rather than in a file in load/ so that things in
; load/ can use it for load-ordering.
(unless (and (bound 'required-files*) required-files*)
  (= required-files* (table)))

(def require (file)
  " Loads `file' if it has not yet been `require'd.  Can be fooled by changing
    the name ((require \"foo.arc\") as opposed to (require \"./foo.arc\")), but
    this should not be a problem.
    See also [[load]]. "
  (or (required-files* file)
    (do (set required-files*.file)
        (load file))))

(def autoload ((o dirname "load"))
  " 'require each file in `dirname' ending in \".arc\".
    See also [[require]] "
  (each f (dir-exists&dir dirname)
    (if (endmatch ".arc" f) (require (+ dirname "/" f)))))

(autoload)

(map load '("strings.arc"
            "code.arc"
            "html.arc"
            "srv.arc"
            "app.arc"
            "http.arc"
            "dispatch.arc"
            "prompt.arc"))

; We define 'require here, rather than in a file in load/ so that things in
; load/ can use it for load-ordering.
(unless (and (bound 'required-files*) required-files*)
  (= required-files* (table)))

(def require (file)
  " Loads `file' if it has not yet been `require'd.  Can be fooled by changing
    the name ((require \"foo.arc\") as opposed to (require \"./foo.arc\")), but
    this should not be a problem.
    See also [[load]]. "
  (or (required-files* file)
    (do (set required-files*.file)
        (load file))))

(def autoload ((o dirname "load"))
  " 'require each file in `dirname' ending in \".arc\".
    See also [[require]] "
  (each f (dir-exists&dir dirname)
    (if (endmatch ".arc" f) (require (+ dirname "/" f)))))

(autoload)