diff --git a/backup b/backup new file mode 100755 index 0000000..41d65b6 --- /dev/null +++ b/backup @@ -0,0 +1,4 @@ +. /xapi/scripts/profile +cd /xapi/data +rm /xapi/backup/* +$mupip backup -database -online DEFAULT,NODE,NODEX,NODETAG,WAY,WAYX,WAYTAG /xapi/backup diff --git a/changeset.m b/changeset.m new file mode 100644 index 0000000..07aab14 --- /dev/null +++ b/changeset.m @@ -0,0 +1,494 @@ +changeset ; Changeset Class + ; Copyright (C) 2009,2011 Etienne Cherdlu <80n80n@gmail.com> + + +add(sChangeset,delete) ; Public ; Add a changeset + ; #sChangeset = stream object containing changeset + ; + n line,changesetId + ; + s line=sChangeset("current") + ; + s changesetId=$$getAttribute^osmXml(line,"id") + d delete(changesetId) + ; + s ^c(changesetId)=line + ; + q + + +delete(changesetId) ; Public ; Delete a changeset + ; + k ^c(changesetId) + q + + +xml(indent,changesetId,full) ; Public ; Generate xml for changeset + ; + n user,uid,timestamp,version,changeset + n q,bllat,bllon,trlat,trlon + n xml + ; + s xml="" + ; + s indent=indent_" " + ; + s uid=$g(^c(changesetId,"t","@uid")) + s user="" i $g(uid)'="" s user=$g(^user(uid,"name")) + s timestamp=$g(^c(changesetId,"t","@timestamp")) + ; + ; Create the q node if it is not present + i '$d(^c(changesetId,"q")) d + . d bbox(changesetId,.bllat,.bllon,.trlat,.trlon) + . s qsBox=$$bbox^quadString(bllat,bllon,trlat,trlon) + . s ^c(changesetId,"q")=qsBox_$c(1)_bllat_$c(1)_bllon_$c(1)_trlat_$c(1)_trlon + ; + s q=$g(^c(changesetId,"q")) + s bllat=$p(q,$c(1),2) i bllat=999999 s bllat="" + s bllon=$p(q,$c(1),3) i bllon=999999 s bllon="" + s trlat=$p(q,$c(1),4) i trlat=-999999 s trlat="" + s trlon=$p(q,$c(1),5) i trlon=-999999 s trlon="" + ; + s xml=indent_""_$c(13,10) + ; + s key="" + f d i key="" q + . s key=$o(^c(changesetId,"t",key)) i key="" q + . i $e(key,1)="@" q + . s value=^c(changesetId,"t",key) + . s xml=xml_indent_""_$c(13,10) + ; + s xml=xml_indent_""_$c(13,10) + ; + q xml + + +query ; Public ; Generate a list of the last 100 changesets + ; + n changesetId,i,uid,user,timestamp + n q,bllat,bllon,trlat,trlon + ; + d header^http("text/xml") + d xmlProlog^rest("") + d osm^xapi("") + ; + s changesetId="" + f i=1:1:100 d i changesetId="" q + . s changesetId=$o(^c(changesetId),-1) i changesetId="" q + . s uid=$g(^c(changesetId,"t","@uid")) i uid="" q + . s user=$g(^user(uid,"name")) + . s timestamp=$g(^c(changesetId,"t","@timestamp")) + . ; + . ; Create the q node if it is not present + . i '$d(^c(changesetId,"q")) d + . . d bbox(changesetId,.bllat,.bllon,.trlat,.trlon) + . . s qsBox=$$bbox^quadString(bllat,bllon,trlat,trlon) + . . s ^c(changesetId,"q")=qsBox_$c(1)_bllat_$c(1)_bllon_$c(1)_trlat_$c(1)_trlon + . ; + . s q=$g(^c(changesetId,"q")) + . s bllat=$p(q,$c(1),2) i bllat=999999 s bllat="" + . s bllon=$p(q,$c(1),3) i bllon=999999 s bllon="" + . s trlat=$p(q,$c(1),4) i trlat=-999999 s trlat="" + . s trlon=$p(q,$c(1),5) i trlon=-999999 s trlon="" + . ; + . w "",$c(13,10) + . ; + . s k="" + . f d i k="" q + . . s k=$o(^c(changesetId,"t",k)) i k="" q + . . i $e(k,1)="@" q + . . s v=^c(changesetId,"t",k) + . . w " ","",$c(13,10) + . w "",$c(13,10) + w "",$c(13,10) + q + + +upload(changesetId) ; Public ; Upload a single changeset via the API + ; The payload should be an file + ; + k ^response($j) + k ^temp($j) + ; + n sFile,line,indent,rSeq,logId + n element,oldId,newId,version,ok + ; + ; Get the authenticated user (will return a 401) if no authentication provided + i '$$authenticated^user(.uid,.user) q + ; + ; The upload is via the API so the XML content is part of the http payload. + d openPayload^stream(.sFile) + ; + s line=$$read^stream(.sFile) + ; i line'["",$c(13,10) + ; + s rSeq="" + f i=1:1 d i rSeq="" q + . s rSeq=$o(^response($j,rSeq)) i rSeq="" q + . s element=^response($j,rSeq,"element") + . s oldId=^response($j,rSeq,"oldId") + . s newId=^response($j,rSeq,"newId") + . s version=^response($j,rSeq,"version") + . w indent,"<"_element + . i oldId'="" w $$attribute^osmXml("old_id",oldId,indent) + . i newId'="" w $$attribute^osmXml("new_id",newId,indent) + . i version'="" w $$attribute^osmXml("new_version",version,indent) + . w "/>",$c(13,10) + w "",$c(13,10) + ; + d logEnd^xapi(logId,i,"") + ; + q + + +uploadModify(changesetId) ; Create or modify stuff, read all lines until end of modify or create element + ; TODO: Need to pass uid to these methods for authentication + ; + n ok + s ok=1 + ; + f d i (line["")!(line["")!('ok) q + . s line=$$read^stream(.sFile) + . i line[""!('ok) q + . s line=$$read^stream(.sFile) + . i line[" tag + s line=$$read^stream(.sFile) ; Read tag + ; + f i=1:1 d i line="" q + . s line=$$read^stream(.sFile) i line="" q + . i sFile("i")="" s line="" q + . i line?.e1"100 s key=$e(key,1,100)_".." + . . i $l(value)>4000 s value=$e(v,1,4000)_".." + . . i key'="" s ^c(changesetId,"t",key)=value + ; + d header^http("text/plain") + w changesetId + ; + d logEnd^xapi(logId,i,"") + q + + +update(changesetId) ; Public ; Update a single changeset via the API (just the tags get updated using this method) + ; The payload is an file + ; + n uid,user,sFile,key,i,line,value,indent + ; + ; Get the authenticated user (will return a 401) if no authentication provided + i '$$authenticated^user(.uid,.user) q + ; + s logId=$$logStart^xapi($g(%ENV("REQUEST_URI"))_" by "_user,"") + ; + i '$d(^c(changesetId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Check that it's the same user + i $g(^c(changesetId,"t","@uid"))'=uid d error409^http("UserId mismatch: Provided "_uid_", server expected: "_$g(^c(changesetId,"t","@uid"))_" for changeset "_changesetId) q + ; + d openPayload^stream(.sFile) + s line=$$read^stream(.sFile) ; Read tag + s line=$$read^stream(.sFile) ; Read tag + ; + ; Delete all old tags on the changeset + s key="" + f d i key="" q + . s key=$o(^c(changesetId,"t",key)) i key="" q + . i $e(key,1)="@" q + . k ^c(changesetId,"t",key) + ; + ; Add new tags + f i=1:1 d i line="" q + . s line=$$read^stream(.sFile) i line="" q + . i sFile("i")="" s line="" q + . i line?.e1"100 s key=$e(key,1,100)_".." + . . i $l(value)>4000 s value=$e(v,1,4000)_".." + . . i key'="" s ^c(changesetId,"t",key)=value + ; + d close^stream(.sFile) + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,changesetId,0) + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,i,"") + ; + q + + +restChangeset(changesetId) ; Public ; Single changeset query + ; + n logId + ; + ; + s logId=$$logStart^xapi($$decode^xapi("changeset/"_changesetId),"") + ; + ; Bad query? + i changesetId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^c(changesetId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,changesetId,0) + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +download(changesetId) ; Public ; Single changeset query with full content + ; + n logId + n state,nodeId,wayId,relationId,version,a,visible + ; + s logId=$$logStart^xapi($$decode^xapi("changeset/"_changesetId_"/download"),"") + ; + ; Bad query? + i changesetId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^c(changesetId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osmChange^xapi(indent) + ; + s state="" + s nodeId="" + f d i nodeId="" q + . s nodeId=$o(^c(changesetId,"n",nodeId)) i nodeId="" q + . s version="" + . f d i version="" q + . . s version=$o(^c(changesetId,"n",nodeId,"v",version)) i version="" q + . . s a=^c(changesetId,"n",nodeId,"v",version,"a") + . . s visible=$p(a,$c(1),5) + . . i visible="false" d setState(indent_" ",.state,"delete") + . . i visible="",version=1 d setState(indent_" ",.state,"create") + . . i visible="",version'=1 d setState(indent_" ",.state,"modify") + . . w $$xml^nodeVersion(indent_" ",nodeId,changesetId,version,"*") + ; + s wayId="" + f d i wayId="" q + . s wayId=$o(^c(changesetId,"w",wayId)) i wayId="" q + . s version="" + . f d i version="" q + . . s version=$o(^c(changesetId,"w",wayId,"v",version)) i version="" q + . . s visible=$g(^c(changesetId,"w",wayId,"v",version,"t","@visible")) + . . i visible="false" d setState(indent_" ",.state,"delete") + . . i visible="",version=1 d setState(indent_" ",.state,"create") + . . i visible="",version'=1 d setState(indent_" ",.state,"modify") + . . w $$xml^wayVersion(indent_" ",wayId,changesetId,version,"way|nd|@*") + ; + s relationId="" + f d i relationId="" q + . s relationId=$o(^c(changesetId,"r",relationId)) i relationId="" q + . s version="" + . f d i version="" q + . . s version=$o(^c(changesetId,"r",relationId,"v",version)) i version="" q + . . s visible=$g(^c(changesetId,"r",relationId,"v",version,"t","@visible")) + . . i visible="false" d setState(indent_" ",.state,"delete") + . . i visible="",version=1 d setState(indent_" ",.state,"create") + . . i visible="",version'=1 d setState(indent_" ",.state,"modify") + . . w $$xml^relationVersion(indent_" ",relationId,changesetId,version,"relation|@*|member|tag|") + ; + d setState(indent_" ",.state,"") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +setState(indent,oldState,newState) ; + ; + i oldState=newState q + ; + i oldState="create" w indent,"",$c(13,10) + i oldState="modify" w indent,"",$c(13,10) + i oldState="delete" w indent,"",$c(13,10) + ; + i newState="create" w indent,"",$c(13,10) + i newState="modify" w indent,"",$c(13,10) + i newState="delete" w indent,"",$c(13,10) + ; + s oldState=newState + q + + +bbox(changesetId,bllat,bllon,trlat,trlon,recalculate) ; Public ; Get the bbox for a changeset + ; + ; Inputs: + ; recalculate - 0 = used stored value if available (default). The stored value may be wrong if elements have been moved subsequently. + ; 1 = recalculate from scratch (slower). + ; + n seq,ref,type,relation + n bllat1,bllon1,trlat1,trlon1 + ; + s recalculate=$g(recalculate)=1 + ; + ; Use previously calculated values if present + i 'recalculate d i bllat'="" q + . s q=$g(^c(changesetId,"q")) + . s bllat=$p(q,$c(1),2) + . s bllon=$p(q,$c(1),3) + . s trlat=$p(q,$c(1),4) + . s trlon=$p(q,$c(1),5) + ; + s bllat=999999,bllon=999999,trlat=-999999,trlon=-999999 + s bllat1=999999,bllon1=999999,trlat1=-999999,trlon1=-999999 + s nodeId="" + f d i nodeId="" q + . s nodeId=$o(^c(changesetId,"n",nodeId)) i nodeId="" q + . s version="" + . f d i version="" q + . . s version=$o(^c(changesetId,"n",nodeId,"v",version)) i version="" q + . . d bbox^nodeVersion(nodeId,version,.bllat1,.bllon1,.trlat1,.trlon1) + . . i trlat1>trlat s trlat=trlat1 + . . i bllat1trlon s trlon=trlon1 + . . i bllon1trlat s trlat=trlat1 + . i bllat1trlon s trlon=trlon1 + . i bllon1trlat s trlat=trlat1 + . i bllat1trlon s trlon=trlon1 + . i bllon1 + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +toNumber(date) ; Public ; Convert an ISO date to a form suitable for numeric comparison + ; + q $tr(date,"-:TZ","") + +toZulu(timestamp) ; Public ; Convert a internal date/time to ISO zulu + q $tr("CcYy-Mm-DdTHh:Nn:SsZ","CcYyMmDdHhNnSs",timestamp) + +nowZulu() ; Public ; Returns date/time in iso format for now using Zulu / GMT timezone + ; + ; Need to adjust ^date("timezoneOffset") when timezones change! + q $$toZulu($$dtthi^date($$hAddSeconds^date($h,3600*^date("timezoneOffset")))) + + +hAddSeconds(hDateTime,seconds) ; Public ; Add seconds to a date time in $h format + ; + n date,time + ; + s date=$p(hDateTime,",",1) + s time=$p(hDateTime,",",2) + s time=time+seconds + s date=date+(time\86400) + s time=time#86400 + q date_","_time + + + + ; Function index: + ; $$dateval - Validate and transform external date + ; $$datetran - date transformation + ; $$dtthi - transform $h date,time to internal yyyymmddhhmmss + ; $$dttia - transform internal yyyymmddhhmmss to dd-mmm-yy hh:mm + ; $$dttid - transform internal yyyymmddhhmmss to dd/mm/yy hh:mm + ; or mm/dd/yy hh:mm + ; $$dttih - transform internal yyyymmddhhmmss to $h date,time + ; $$now - date and time now as yyyymmddhhmmss + ; $$nowx - date and time now as dd-mmm-yy hh:mm + ; $$today - today in formats dh di da dd delimited by space + ; $$todaya - today as dd-mon-yy + ; $$todayd - today as dd/mm/yy or mm/dd/yy + ; $$todayh - today as $h date + ; $$todayi - today as yyyymmdd + ; $$format - valid date formats error message text + + ; Missing information defaults to day, month and year in argument ti. + ; missing century defaults based on user defined window before and + ; after current year. + + ; Date format based on locale of user. Currently two locales are + ; supported: US and European + + ; Date validation functions accept value of: + ; 1) T + or - days eg. "T+2", "t-5" + ; 2) dd/mm/[cc]yy or mm/dd/[cc]yy eg. "31/12", "31", "/12/88", "/31/1988" + ; 3) dd mon [cc]yy eg. "13-Oct" + ; 4) ddmon[cc]yy eg. "13OCT88", "1jan1987" + ; 5) ddmm[cc]yy or mmdd[cc]yy eg "131088" or "13102001" + + +dayname(dateh) ; Private ; Transform $h format to day of the week + ; + q $p($$datxd," ",dateh#7+1) + + +days(y,m) ; Private ; Get days in month m of year y (or days in year) + ; Get days in month m of year y (or days in year) + ; If only year is passed returns days in year. + ; If year and month number passed returns days in month. + ; Usage: + ; s ddd=$$days(cccyy[,mm]) + ; Inputs: + ; cccyy = year of interest + ; mm = month of interest (optional) + ; Outputs: + ; $$days = number of days in year or month + ; + n v + ; + i '$d(m) s v=365,m=2 i 1 + e s v=$P("31-28-31-30-31-30-31-31-30-31-30-31","-",m) + i +m=2,y#4=0,y#400=0 s v=v+1 + i +m=2,y#4=0,y#100 s v=v+1 + q v + + +datetran(date,source,target) ; Public ; Transform date, formats are: a, i, d or h + ; Usage: + ; s date=$$datetran(date,source,target) + ; Inputs: + ; date = date in source format + ; source = format of input date (a,i,h,d) + ; target = format of output date (a,i,h,d) + ; Outputs: + ; date = date in target format + ; Notes: + ; a - alphabetic format, dd-mmm-[ccc]yy + ; i - internal format, cccyymmdd + ; h - $h format, no of days before or after 31-Dec-1840 + ; d - decimal format, dd/mm/[ccc]yy or mm/dd/[ccc]yy + ; + n cccyy,mm,dd + ; + i date="" q "" + ; + ; First convert to standard format + i source="a" d atoz(date,.cccyy,.mm,.dd) + i source="i" d itoz(date,.cccyy,.mm,.dd) + i source="h" d htoz(date,.cccyy,.mm,.dd) + i source="d" d dtoz(date,.cccyy,.mm,.dd) + ; + ; Now convert standard form to required external format + i target="a" q $$ztoa(cccyy,mm,dd) + i target="i" q $$ztoi(cccyy,mm,dd) + i target="h" q $$ztoh(cccyy,mm,dd) + i target="d" q $$ztod(cccyy,mm,dd) + q error + + +dateval(date,target) ; Public ; Validate and transform date, formats are: a, i, d or h + ; + n cccyy,mm,dd + ; + i date="" q "" + ; + i '$$valx(date,.cccyy,.mm,.dd) q 0 + i target="a" q $$ztoa(cccyy,mm,dd) + i target="i" q $$ztoi(cccyy,mm,dd) + i target="h" q $$ztoh(cccyy,mm,dd) + i target="d" q $$ztod(cccyy,mm,dd) + q 0 + + +valx(datex,cccyy,mm,dd) ; Private ; Validate external date, return year, month and day components + ; Usage: + ; s ok=$$valx(datex,.cccyy,.mm,.dd) + ; Inputs: + ; datex = date in any external format (eg 1/1/97, t+5, 1-Jan) + ; Outputs: + ; $$valx = 1 if date valid, 0 if invalid + ; cccyy = year + ; mm = month + ; dd = day + ; + ; Pare the date into component parts + i '$$parse(datex,.cccyy,.mm,.dd) q 0 + ; + ; Expand and validate + q $$expv(.cccyy,.mm,.dd) + + +parse(datex,cccyy,mm,dd) ; Private ; Parse date in external form + ; + n locale + ; + ; Convert to uppercase + i datex?.e1l.e s datex=$$upper^%vc1str(datex) + ; + ; t, t+n, t-n, +n, -n - today's date plus or minus a bit + i $e(datex,1)="T" q $$t(datex,.cccyy,.mm,.dd) + i $e(datex,1)="+" q $$plus(datex,.cccyy,.mm,.dd) + i $e(datex,1)="-" q $$minus(datex,.cccyy,.mm,.dd) + ; + s locale=$$locale + ; + ; Six plus digits (ddmm[ccc]yy or mmdd[ccc]yy) + i datex?.n,locale="EUROPE" d q 1 + . s dd=$e(datex,1,2) + . s mm=$e(datex,3,4) + . s cccyy=$e(datex,5,$l(datex)) + ; + i datex?.n,locale="US" d q 1 + . s dd=$e(datex,3,4) + . s mm=$e(datex,1,2) + . s cccyy=$e(datex,5,$l(datex)) + ; + ; ddmmm[ccc]yy - break on alpha + i datex?1.2n3a.n d q 1 + . n p1,p2 + . f p1=2:1 i $e(datex,p1)?1a q + . f p2=p1+1:1 i $e(datex,p2)'?1a q + . s dd=$e(datex,1,p1-1) + . s mm=$e(datex,p1,p2-1) + . s mm=$f($$datxmu,mm)-1-$l(mm)/4+1 + . s cccyy=$e(datex,p2,$l(datex)) + ; + ; eepee - Look for a delimiter + i datex?.e1p.e,datex'?1.p d q 1 + . n i,p + . f i=1:1:$l(datex) i $e(datex,i)?1p s p=$e(datex,i) q + . i locale="EUROPE" d + . . s dd=$p(datex,p,1) + . . s mm=$p(datex,p,2) + . i locale="US" d + . . s dd=$p(datex,p,2) + . . s mm=$p(datex,p,1) + . . i datex?.e1p1.a.e d + . . . s dd=$p(datex,p,1) + . . . s mm=$p(datex,p,2) + . i mm'?1.n i mm'="" s mm=$f($$datxmu,mm)-1-$l(mm)/4+1 + . s cccyy=$p(datex,p,3,99) + ; + q 0 + + +t(datex,cccyy,mm,dd) ; Private ; Today +- number of days + ; t|t+nn|t-nn + ; + n offset + ; + i datex="T" d htoz($h,.cccyy,.mm,.dd) q 1 + i datex?1"T+"1.n q $$plus($e(datex,2,99),.cccyy,.mm,.dd) + i datex?1"T-"1.n q $$minus($e(datex,2,99),.cccyy,.mm,.dd) + q 0 + + +plus(datex,cccyy,mm,dd) ; Private ; Today + number of days + ; +nn + ; + n offset + ; + i datex?1"+"1.n d q 1 + . s offset=$e(datex,2,$l(datex)) + . d htoz($h+offset,.cccyy,.mm,.dd) + q 0 + + +minus(datex,cccyy,mm,dd) ; Private ; Today - number of days + ; -nn + ; + n offset + ; + i datex?1"-"1.n d q 1 + . s offset=$e(datex,2,$l(datex)) + . d htoz($h-offset,.cccyy,.mm,.dd) + q 0 + + +format() ; Private ; Valid date formats as text message + ; + n locale + ; + s locale=$$locale + ; + i locale="EUROPE" q "Valid date formats: dd/mm/yy, ddmmyy, dd-mmm-yy, t (today), t+n or t-n" + i locale="US" q "Valid date formats: mm/dd/yy, mmddyy, dd-mmm-yy, t (today), t+n or t-n" + q 1/0 + + +dtthi(horolog) ; Public ; Transform date/time in $h format to date/time in internal format + ; + n datei,timei + ; + s datei=$$datetran(+horolog,"h","i") + s timei=$$tmths^time($p(horolog,",",2)) + q datei_timei + + +dttid(datetime) ; Public ; Transform date/time in internal format to dd/mm/[ccc]yy hh:mm + ; + n datei,timei,dated,timex + ; + d datetime(datetime,.datei,.timei) + s dated=$$datetran(datei,"i","d") + s timex=$$tmti2^time($e(timei,1,4)) + q dated_" "_timex + + +dttih(datetime) ; Public ; Transform date/time in internal format to date/time in $h format + ; + n datei,timei,dateh,timeh + ; + d datetime(datetime,.datei,.timei) + s dateh=$$datetran(datei,"i","h") + s timeh=($e(timei,1,2)*60*60)+($e(timei,3,4)*60)+$e(timei,5,6) + q dateh_","_timeh + + +datetime(datetime,datei,timei) ; Private ; Derive datei and timei from datetime + ; + n length + ; + s length=$l(datetime) + s datei=$e(datetime,1,length-6) + s timei=$e(datetime,length-5,length) + q + + +dttia(datetime) ; Public ; Transform date/time in internal format to date/time in dd-mmm-[ccc]yy hh:mm + ; + n datei,timei,datea,timex + ; + d datetime(datetime,.datei,.timei) + s datea=$$datetran(datei,"i","a") + s timex=$$tmti2^time($e(timei,1,4)) + q datea_" "_timex + + +now() ; Public ; Date and time now as cccyymmddhhmmss + ; + q $$dtthi($h) + + +nowx() ; Public ; Date and time now as dd-mmm-[ccc]yy hh:mm + ; + q $$dttia($$dtthi($h)) + + + +today() ; Public ; Today in formats h i a and d delimited by space + ; derive and use yyyymmdd for performance + ; + n dateh,datei,datea,dated + ; + s dateh=+$h + s datei=$$datetran(dateh,"h","i") + s datea=$$datetran(dateh,"h","a") + s dated=$$datetran(dateh,"h","d") + q dateh_" "_datei_" "_datea_" "_dated + + + +todaya() ; Public ; Today as dd-mmm-[ccc]yy + ; + q $$datetran(+$h,"h","a") + + + +todayd() ; Public ; Today as dd/mm/[ccc]yy or mm/dd/[ccc]yy + ; + q $$datetran(+$h,"h","d") + + + +todayh() ; Public ; Today as $h date + ; + q +$h + + + +todayi() ; Public ; Today as cccyymmdd + ; + q $$datetran(+$h,"h","i") + + + +expv(cccyy,mm,dd) ; Private ; Expand and validate year month and day fields + ; Usage: + ; d expv(.cccyy,.mm,.dd) + ; Inputs: + ; cccyy = year + ; mm = month + ; dd = day + ; Outputs: + ; cccyy = expanded and validated year + ; mm = expanded and validated month + ; dd = expanded and validated day + ; + n todayi + ; + s todayi=$$todayi + ; + i cccyy_mm_dd'?.1"-".n q 0 + ; + ; Year and century default + ; (any year is valid from -infinity to +infinity) + i cccyy="" s cccyy=$$cccyy(todayi) + i $l(cccyy)<2 s cccyy=$e(100+cccyy,2,3) + s cccyy=$$ytocy(cccyy) + ; + ; Month default and validation + i mm="" s mm=$$mm(todayi) + i mm>12 q 0 + i mm<1 q 0 + s mm=$e(100+mm,2,3) + ; + ; Day default and validation + i dd="" s dd=$$dd(todayi) + i dd>$$days(cccyy,mm) q 0 + i dd<1 q 0 + s dd=$e(100+dd,2,3) + q 1 + + + +htoz(dateh,cccyy,mm,dd) ; Private ; Convert $h date to cccyy, mm, dd + ; Algorithm: + ; Convert $h date to number of days since 31 Dec -0001 then + ; iteratively subtract 400 years, then 100 years, then 4 years + ; then 1 year until less than 365 or 366 days remain. + ; Derive month based on number of days remaining. + ; Remainder is the day of the month. + ; adjust is used to adjust the first iteration of each date + ; period depending upon whether it is a leap year or not. + ; There is known to be a problem with year 0000. + ; + n adjust + ; + s adjust=0 + s dateh=dateh+672412 + ; + ; Shortcut if year after 1992 then jump to days in 4 years + ;i dateh>727563 s cccyy=1992,dateh=dateh-727563 g htoz05 + ; + ; Derive year + s cccyy=0 + d htoz10(146097,400,.dateh,.cccyy) ; Number of days in 400 years + i $$leap(cccyy) s adjust=1 + d htoz10(36524,100,.dateh,.cccyy) ; Number of days in 100 years +htoz05 i '$$leap(cccyy) s adjust=-1 + d htoz10(1461,4,.dateh,.cccyy) ; Number of days in 4 years + i $$leap(cccyy) s adjust=1 + d htoz10(365,1,.dateh,.cccyy) ; Number of days in 1 year + ; + ; Derive month and day + i $$leap(cccyy) s adjust=1 + d htoz20 + s dd=dateh + ; + ; Add leading zeros to years 0 through 999 + i $l(cccyy)<4 s cccyy=$e(10000+cccyy,2,5) + s mm=$e(100+mm,2,3) + s dd=$e(100+dd,2,3) + q + + +htoz10(days,years,dateh,y) ; Private ; Iteratively subtract days from dateh until no longer possible + ; for each iteration add years to y. + ; +htoz11 i dateh'>(days+adjust) s adjust=0 q + s dateh=dateh-days-adjust + s y=y+years + s adjust=0 + g htoz11 + + +htoz20 ; Private ; Calculate months + ; + i dateh'>31 s mm=1,dateh=dateh q + i dateh'>(59+adjust) s mm=2,dateh=dateh-31 q + i dateh'>(90+adjust) s mm=3,dateh=dateh-(59+adjust) q + i dateh'>(120+adjust) s mm=4,dateh=dateh-(90+adjust) q + i dateh'>(151+adjust) s mm=5,dateh=dateh-(120+adjust) q + i dateh'>(181+adjust) s mm=6,dateh=dateh-(151+adjust) q + i dateh'>(212+adjust) s mm=7,dateh=dateh-(181+adjust) q + i dateh'>(243+adjust) s mm=8,dateh=dateh-(212+adjust) q + i dateh'>(273+adjust) s mm=9,dateh=dateh-(243+adjust) q + i dateh'>(304+adjust) s mm=10,dateh=dateh-(273+adjust) q + i dateh'>(334+adjust) s mm=11,dateh=dateh-(304+adjust) q + s mm=12,dateh=dateh-(334+adjust) + q + + +ztoh(cccyy,mm,dd) ; Private ; Convert cccyy, mm, dd to $h format (allows negative $h) + ; + n cccyy1,days,month + ; + ; Calculate $h for end of preceeding year + s cccyy1=cccyy-1 + s days=cccyy1*365 + s days=days+(cccyy1\4) ; Add leap years + s days=days-(cccyy1\100) ; Subtract centuries + s days=days+(cccyy1\400) ; Add leap centuries + ; + ; Subtract number of days between 31 December 0000 and 31 December 1840 + s days=days-672046 + ; + ; Now add days in each month up to preceeding month + f month=1:1:mm-1 s days=days+$$days(cccyy,month) + ; + ; Now add days + s days=days+dd + ; + q days + + +ztod(cccyy,mm,dd) ; Private ; Reformat cccyy, mm, dd to dd/mm/[ccc]yy or mm/dd/[ccc]yy + ; + n locale + ; + s locale=$$locale + ; + i locale="EUROPE" q dd_"/"_mm_"/"_$$cytoy(cccyy) + i locale="US" q mm_"/"_dd_"/"_$$cytoy(cccyy) + q 1/0 + + +ztoa(cccyy,mm,dd) ; Private ; Reformat cccyy, mm, dd to dd-mmm-[ccc]yy + ; + q dd_"-"_$p($$datxm," ",mm)_"-"_$$cytoy(cccyy) + + +ztoi(cccyy,mm,dd) ; Private ; Transform cccyy, mm, dd to cccyymmdd format + ; + q cccyy_mm_dd + + +dtoz(dated,cccyy,mm,dd) ; Private ; Convert dd/mm/[ccc]yy or mm/dd/[ccc]yy to cccyy, mm, dd + ; + n locale + ; + s locale=$$locale + ; + i locale="EUROPE" d + . s dd=$p(dated,"/",1) + . s mm=$p(dated,"/",2) + i locale="US" d + . s mm=$p(dated,"/",1) + . s dd=$p(dated,"/",2) + s cccyy=$p(dated,"/",3) + s dd=$e(100+dd,2,3) + s mm=$e(100+mm,2,3) + s cccyy=$$ytocy(cccyy) + q + + +atoz(datea,cccyy,mm,dd) ; Private ; Convert alphabetic date to cccyy, mm, dd + ; + n d,m,y + ; + s d=$p(datea,"-",1) + s m=$p(datea,"-",2) + s y=$p(datea,"-",3) + ; + s dd=$e(100+d,2,3) + s mm=$$month(m) + s cccyy=$$ytocy(y) + q + + +month(mmm) ; Private ; Convert alpha month to numeric month + ; + n mm + ; + s mm=$f($$datxm,mmm)/4 + q $e(100+mm,2,3) + + +itoz(datei,cccyy,mm,dd) ; Private ; Convert internal [ccc]yymmdd date to cccyy, mm, dd format + s dd=$$dd(datei) + s mm=$$mm(datei) + s cccyy=$$cccyy(datei) + q + + +ytocy(year) ; Private ; Convert two digit year to century plus year using window + ; + n window,todayi,ccc,yy,thresh + ; + ; Already in century plus year form + i $l(year)>2 q year + ; + ; Get date window (or default to 50 years) + s window=$g(^%vcvc("date_window")) + i window="" s window=50 + ; + ; Need to know current century and year + s todayi=$$todayi + s ccc=$$ccc(todayi) + s yy=$$yy(todayi) + ; + ; Return the year based on the value entered the current year + ; and the date window + s thresh=yy+window + i thresh>100,(year+100)>thresh q (ccc)_year + i thresh>100 q (ccc+1)_year + i year>thresh q (ccc-1)_year + q (ccc)_year + + +cytoy(year) ; Private ; Attempt to convert century plus year to two digit year using window + ; If year is outside window then will return century and year to + ; avoid ambiguity. + ; + n window,todayi,cccyy,winlo,winhi + ; + ; Already in two digit year form + i $l(year)=2 q year + ; + ; Get date window (or default to 50 years) + s window=$g(^%vcvc("date_window")) + i window="" s window=50 + ; + ; Need to know current century and year + s todayi=$$todayi + s cccyy=$$cccyy(todayi) + ; + ; Calculate window bounds + s winlo=cccyy-(100-window) + s winhi=cccyy+window + ; + ; If within window bounds then return two digit year + i year>winlo,year'>winhi q $e(year,$l(year)-1,$l(year)) + q year + + +locale() ; Private ; Derive locale for user + ; + i $g(%usr)="" q "US" ; Default to US if user not known + ; + s locale=$p($g(^%vcmf("user",%usr)),%,6) + i locale="" q "US" + q locale + + + ; ---------------------- + ; Date lexical functions + ; ---------------------- + +cccyy(datei) ; Private ; Get century from internal date + ; + n length + ; + s length=$l(datei) + q $e(datei,1,length-4) + + +ccc(datei) ; Private ; Get century from internal date + ; + n length + ; + s length=$l(datei) + q $e(datei,1,length-6) + + +yy(datei) ; Private ; Get year from internal date + ; + n length + ; + s length=$l(datei) + q $e(datei,length-5,length-4) + + +mm(datei) ; Private ; Get month from internal date + ; + n length + ; + s length=$l(datei) + q $e(datei,length-3,length-2) + + +dd(datei) ; Private ; Get day from internal date + ; + n length + ; + s length=$l(datei) + q $e(datei,length-1,length) + + + +leap(y) ; Private ; Is year a leap year? + ; + i y#400=0 q 1 + i y#100=0 q 0 + i y#4=0 q 1 + q 0 + + ; --------- + ; Constants + ; --------- + +datxd() ; Private ; Thu Fri Sat Sun Mon Tue Wed + ; + q "Thu Fri Sat Sun Mon Tue Wed" + + +datxm() ; Private ; Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec + ; + q "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" + + +datxmu() ; Private ; JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC + ; + q "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC" + + diff --git a/exportDiff.m b/exportDiff.m new file mode 100644 index 0000000..1f9380a --- /dev/null +++ b/exportDiff.m @@ -0,0 +1,269 @@ +exportDiff ; Export minutely diff + ; Copyright (C) 2010 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +run ; Public ; Run exportDiff + ; Export repeatedly until we catch up with the import or with the current minute + ; + l +^exportDiff("running"):0 e q + k ^exportDiff("stop") + f i '$$main() q + l -^exportDiff("running") + q + + +stop ; Public ; Stop exportDiff + s ^exportDiff("stop")=1 + q + + +main() ; Export + ; + n iMinute,iEndSecond,hEndSecond,loadDiff,iLoadDiff + n sequence,iSequence,file,stateFile + n hSecond + ; + ; Find a minute to process + s iMinute=$g(^exportDiff("minutelyTimestamp")) + s iEndSecond=iMinute_"59" + ; + ; Add a few minutes so that we are sure we have got all updates + s hEndSecond=$$dttih^date(iEndSecond) + s hEndSecond=$$hAddSeconds^date(hEndSecond,60*5) + s iEndSecond=$$dtthi^date(hEndSecond) + ; + ; Do not export until the current minute has passed + i $$toNumber^date($$nowZulu^date())/dev/null" + zsystem "mkdir "_directory2_" 2>/dev/null" + ; + o file:(NEW:STREAM:NOWRAP) + u file + ; + ; Let's do it + d xmlProlog^rest("") + d minute(iMinute) + c file + ; + ; Now zip the file + zsystem "rm -f "_file_".gz" + zsystem "gzip "_file + ; + q file_".gz" + + +createStateFile(sequence,iMinute) ; + ; Sequence = 111222333 (without the 1 prefix which is stored on file) + ; iMinute = ccyymmddhhmm + ; Returns full name, including path, of file created + ; + n directory1,directory2,root,stateFile + n timestamp,iEndSecond,zEndSecond,transactionMax + ; + s directory1=$g(^exportDiff("minutelyDirectory"))_$e(sequence,1,3)_"/" + s directory2=$g(^exportDiff("minutelyDirectory"))_$e(sequence,1,3)_"/"_$e(sequence,4,6)_"/" + s root=directory2_$e(sequence,7,9) + s stateFile=root_".state.txt" + ; + ; Create directories if needed (errors to /dev/null if already exists) + zsystem "mkdir "_directory1_" 2>/dev/null" + zsystem "mkdir "_directory2_" 2>/dev/null" + ; + ; Write state file + o stateFile:NEW + u stateFile + s timestamp=$$nowZulu^date() + s iEndSecond=iMinute_"59" + s zEndSecond=$$toZulu^date(iEndSecond) + s transactionMax=iEndSecond-20100101010101_$e(10000+$r(9999),2,5) ; Random garbage + w "# "_timestamp,! + w "sequenceNumber=",sequence,! + w "txnMaxQueried=",transactionMax,! + w "timestamp=",$p(zEndSecond,":",1)_"\:"_$p(zEndSecond,":",2)_"\:"_$p(zEndSecond,":",3),! + w "txnReadyList=",! + w "txnMax=",transactionMax,! + w "txnActiveList=",! + c stateFile + ; + q stateFile + + +minute(iMinute) ; Emit all changes for a whole minute + ; + n mode,iStart,iEnd,start,end,timestamp,iTimestamp + ; + w "",$c(13,10) + ; + s mode="" + s iStart=iMinute_"00" + s iEnd=iMinute_"59" + s start=$$toZulu^date(iStart) + s end=$$toZulu^date(iEnd) + s timestamp=start + d second(.mode,timestamp) + f d i timestamp="" q + . s timestamp=$o(^export(timestamp)) i timestamp="" q + . s iTimestamp=$$toNumber^date(timestamp) + . i iTimestamp>iEnd s timestamp="" q + . d second(.mode,timestamp) + ; + i mode'="" w "",$c(13,10) + w "",$c(13,10) + q + + +second(mode,timestamp) ; + ; + n changeset,nodeId,wayId,relationId,version,action + ; + s changeset="" + f d i changeset="" q + . s changeset=$o(^export(timestamp,"n",changeset)) i changeset="" q + . s nodeId="" + . f d i nodeId="" q + . . s nodeId=$o(^export(timestamp,"n",changeset,nodeId)) i nodeId="" q + . . s version="" + . . f d i version="" q + . . . s version=$o(^export(timestamp,"n",changeset,nodeId,version)) i version="" q + . . . ; + . . . s action=$$action(changeset,"n",nodeId,version) + . . . i action'=mode s mode=$$changeMode("",mode,action) + . . . ; + . . . w $$xml^nodeVersion("",nodeId,changeset,version,"node|tag|@*") + ; + s changeset="" + f d i changeset="" q + . s changeset=$o(^export(timestamp,"w",changeset)) i changeset="" q + . s wayId="" + . f d i wayId="" q + . . s wayId=$o(^export(timestamp,"w",changeset,wayId)) i wayId="" q + . . s version="" + . . f d i version="" q + . . . s version=$o(^export(timestamp,"w",changeset,wayId,version)) i version="" q + . . . ; + . . . s action=$$action(changeset,"w",wayId,version) + . . . i action'=mode s mode=$$changeMode("",mode,action) + . . . ; + . . . w $$xml^wayVersion("",wayId,changeset,version,"way|@*|nd|tag|") + ; + s changeset="" + f d i changeset="" q + . s changeset=$o(^export(timestamp,"r",changeset)) i changeset="" q + . s relationId="" + . f d i relationId="" q + . . s relationId=$o(^export(timestamp,"r",changeset,relationId)) i relationId="" q + . . s version="" + . . f d i version="" q + . . . s version=$o(^export(timestamp,"r",changeset,relationId,version)) i version="" q + . . . ; + . . . s action=$$action(changeset,"r",relationId,version) + . . . i action'=mode s mode=$$changeMode(" ",mode,action) + . . . ; + . . . w $$xml^relationVersion("",relationId,changeset,version,"relation|@*|member|tag|") + ; + q + + +action(changeset,element,nodeId,version) ; Derive whether it's a create, modify or delete + ; + i version=1 q "create" + i $p($g(^c(changeset,"n",nodeId,"v",version,"a")),$c(1),5)="false" q "delete" + i $g(^c(changeset,"n",nodeId,"v",version,"t","@visible"))="false" q "delete" + q "modify" + + +changeMode(indent,oldMode,newMode) ; Emit mode tags and return current mode + i oldMode'="" w indent_"",$c(13,10) + w indent_"<"_newMode_">",$c(13,10) + q newMode + + + +setup ; Public ; Setup exportDiff + ; + n url,startDate,in + ; + s startDate=$g(^loadDiff("dateTime")) + ; +setup10 ; + w !,"URL? <",url,"> " r in i in="" s in=url w in + i in="" w " Eh?" g setup10 + s url=in + ; +setup20 ; + w !,"Start date/time ccyymmddhhmm? " + i startDate'="" w "<",startDate,"> " + r in i in="" s in=startDate w in + i in'?12n w " Eh?" g setup20 + s startDate=in + ; + s ^loadDiff("url")=url + s ^loadDiff("dateTime")=startDate + q + + + diff --git a/fosm_up b/fosm_up new file mode 100755 index 0000000..189d5f8 --- /dev/null +++ b/fosm_up @@ -0,0 +1,6 @@ +#!/bin/bash +# Start up a xapi daemon +source profile +export GTMCI=$zappy/scripts/xapi.ci +cd $zappy/data +($zappy/scripts/xapid /dev/null 2>>xapid.err &) diff --git a/http.m b/http.m new file mode 100644 index 0000000..c34eb9e --- /dev/null +++ b/http.m @@ -0,0 +1,93 @@ +http ; serverLink http library functions + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + q + + +word(fileName) ; Public ; Word document (as attachment) + ; + w "Status: 200 OK",! + w "Content-Type: application/msword; name="_fileName,! + w "Content-Disposition: attachment; filename="_fileName,! + w ! + q + + +excel(fileName) ; Public ; In-line excel spreadsheet + ; + w "Status: 200 OK",! + w "Content-Type: application/vnd.ms-excel; name="_fileName,! + w "Content-Disposition: inline; filename="_fileName,! + w ! + q + + +header(type) ; Public ; Print simple/minimal http header + ; + w "Status: 200 OK",! + w "Content-Type: ",type,! + i $d(%session) d cookie^session + w ! + q + + +gone ; Public ; Print 410 gone header + ; + w "Status: 410 Gone",! + w ! + q + + +notFound ; Public ; Print 404 Not Found header + ; + w "Status: 404 Not Found",! + w ! + q + + +xml(filename) ; Public ; Generate xml attachment header + ; + w "Status: 200 OK",! + w "Content-Type: text/xml",! + w "Content-Disposition: attachment; filename=",filename,! + w ! + q + + +error ; Public ; Server-side error + ; NB send a content-type record because IE 6.0 may otherwise try to download the content (erroneously). + ; + w "Status: 500 Internal Server Error",! + w "Content-Type: text/html",! + w ! + q + + +error409(message) ; Public ; Generate a 409 error + ; + w "Status: 409 Conflict",! + w "Content-Type: text/plain",! + w "Error: ",message,! + w ! + ; + q + + +redirect(location) ; Public ; Server-side redirect + ; + w "Location: ",location,! + w ! + q diff --git a/init b/init new file mode 100755 index 0000000..e26e689 --- /dev/null +++ b/init @@ -0,0 +1,4 @@ +#!/bin/bash +source profile +cd $zappy/data +$gtm diff --git a/load.m b/load.m new file mode 100644 index 0000000..73133c4 --- /dev/null +++ b/load.m @@ -0,0 +1,32 @@ +load ; Load Monitor + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + + l ^load:0 e q ; Lood monitor already running + + s logFile="muninLoad.log" + s ok=1 + f d i 'ok q + . i $g(^load("run"))=0 s ok=0 q + . s request="" + . f c=0:1 s request=$o(^requestx(request)) i request="" q + . s ^load("log",$h)=c + . ; + . o logFile:NEW u logFile w c,! c logFile + . ; + . h ^load("interval") + q diff --git a/loadDiff b/loadDiff new file mode 100755 index 0000000..861efc4 --- /dev/null +++ b/loadDiff @@ -0,0 +1,3 @@ +. profile +cd /$zappy/data +$gtmrun ^loadDiff xapiDiff diff --git a/loadDiff.m b/loadDiff.m new file mode 100644 index 0000000..ef5fdf9 --- /dev/null +++ b/loadDiff.m @@ -0,0 +1,283 @@ +LoadDiff ; Load planet diff file with fully indexed tags + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + +run ; Public ; Run loadDiff + ; + l +^loadDiff("running"):0 e q + k ^loadDiff("stop") + f i '$$file() q:$g(^loadDiff("stop"))=1 h 30 + l -^loadDiff("running") + q + + +stop ; Public ; Stop loadDiff + s ^loadDiff("stop")=1 + q + + +file() ; Public ; Get the next file and process it + ; + n dateTime,hDateTime1,hDateTime2,dateTime1,dateTime2,filegz,file + n sFile + ; + s lastFile=^loadDiff("lastFile") + ; + ; Increment file name + s nextFile=lastFile + s nextFile=$e(1000000000+lastFile+1,2,10) + s file=$e(nextFile,7,9)_".osc" + s filegz=file_".gz" + s state=$e(nextFile,7,9)_".state.txt" + zsystem "rm -f "_filegz + zsystem "rm -f "_file + zsystem "rm -f "_state + ; + s stateUrl=^loadDiff("url")_$e(nextFile,1,3)_"/"_$e(nextFile,4,6)_"/"_$e(nextFile,7,9)_".state.txt" + zsystem "wget "_stateUrl + o state:(READ:EXCEPTION="g fail"):0 e q 0 ; File does not exist yet + u state r header,sequenceNumber,txnMaxQueried,timestamp + c state + ; + s timestamp=$tr($p(timestamp,"=",2),"\","") + ; + s fileUrl=^loadDiff("url")_$e(nextFile,1,3)_"/"_$e(nextFile,4,6)_"/"_$e(nextFile,7,9)_".osc.gz" + zsystem "wget "_fileUrl + ; + zsystem "gunzip "_filegz + ; + ; ====== TRANSACTION START ================================================================================= + ; tstart * + ; i $trestart u 0 w !,"restart",! + c file ; If this is a restart then the file may already have been opened, so close it to be sure. + d oneFile(file,.sFile) + ; + ; Only update dateTime after the file has been loaded successfully + s ^loadDiff("timestamp")=timestamp + s ^osmPlanet("date")=$tr($e(timestamp,1,10),"-","") + s ^loadDiff("lastFile")=nextFile + ; + ; tcommit + ; ====== TRANSACTION END =================================================================================== + ; + ; Tidy up + zsystem "rm "_file + zsystem "rm "_state + ; + ; Someone wants us to stop + i $g(^loadDiff("stop"))=1 q 0 + ; + q 1 + + +fail ; Error handler if file does not exist + q 0 + + +setup ; Public ; Setup loadDiff + ; + n url,startDate,in + ; + s url=$g(^loadDiff("url")) i url="" s url="http://ftp.heanet.ie/mirrors/openstreetmap.org/minute/" + s startDate=$g(^loadDiff("dateTime")) + ; +setup10 ; + w !,"URL? <",url,"> " r in i in="" s in=url w in + i in="" w " Eh?" g setup10 + s url=in + ; +setup20 ; + w !,"Start date/time ccyymmddhhmm? " + i startDate'="" w "<",startDate,"> " + r in i in="" s in=startDate w in + i in'?12n w " Eh?" g setup20 + s startDate=in + ; + s ^loadDiff("url")=url + s ^loadDiff("dateTime")=startDate + q + + ; Strategy: + ; 1) Import everything into the changeset. + ; 2) Process all the relations in the changeset (don't delete a relation if it is in use by some relation that is not in the changeset) + ; 3) Process all ways. Do not delete ways if they are in use by relations that are not in this changeset) + ; 4) Process all nodes. Do not delete nodes if they are in use by any ways (unless deleted in this changeset) + +oneFile(filename,sFile) ; Public ; Load data from filename + ; + n q,ccyymmdd + n line + n gNodeDeleteCount,gWayDeleteCount,gNodeModifyCount,gWayModifyCount,gRelDeleteCount,gRelModifyCount,fileId + ; + s q="""" + s gNodeDeleteCount=0 + s gWayDeleteCount=0 + s gRelDeleteCount=0 + s gNodeModifyCount=0 + s gWayModifyCount=0 + s gRelModifyCount=0 + ; + s fileId=filename + k ^loadDiff(fileId) + s ^loadDiff(fileId,"start")=$h + s ^loadDiff(fileId,"pid")=$j + k ^temp($j,"loadDiff") + ; + ; + ; Read the file + d openFile^stream(.sFile,filename) + s line=$$read^stream(.sFile) ; prolog + s line=$$read^stream(.sFile) ; + ; + f d i line["" q + . s line=$$read^stream(.sFile) + . i sFile("recordCount")#10000=0 d checkpoint + . i line["version q + . ; + . ; Has the element been forked + . s fork=0 + . i currentVersion'="" d + . . s currentChangesetId=^nodeVersion(nodeId,"v",currentVersion) + . . s currentA=$g(^c(currentChangesetId,"n",nodeId,"v",currentVersion)) ; The previous version may never have been in a changeset + . . s fork=$p(currentA,$c(1),6) + . ; + . i fork d q + . . ; + . . ; Log conflict against user who edited in fosm + . . s currentUid=$p(currentA,$c(1),4) + . . i currentUid="" q + . . d log^conflict("node",nodeId,currentUid,a,"Edited in fosm") + . ; + . ; If the node is to be deleted, but is still in-use then don't delete it. Instead add it to the conflict file + . ; for manual inspection + . i visible="false",$d(^wayByNode(nodeId)) d log^conflict("node",nodeId,uid,a,"Deleted in OSM but still in use in fosm") q + . ; + . d addNodeFromChangeset^node(changeset,nodeId,version) + q + + + + +delete ; Delete some stuff, read all lines until end of delete element + f d i line["" q + . s line=$$read^stream(.sFile) + . i sFile("recordCount")#10000=0 d checkpoint + . i line["")!(line["") q + . s line=$$read^stream(.sFile) + . i sFile("recordCount")#10000=0 d checkpoint + . i line[" + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + ; Loads nodes and segments from a planet.osm. Replaces any existing nodes and segments + ; Deletes any nodes and segments that are not in planet.osm. + + d add("all") + ;d delete + q + +loadNodes d add("node") + q + +loadWays d add("way") + q + +loadRelations d add("relation") + q + + +add(session) ; Look for things that need to be added + ; + n q,ccyymmdd + n sPipe,line + n gNodeCount,gNodeAdd,gNodeModified + n gWayCount,gWayAdd,gWayModified + n gRelCount,gRelAdd,gRelModified + n gNodeUser + ; + s q="""" + s gNodeCount=0 + s gNodeAdd=0 ; Count of missing nodes added + s gNodeModified=0 ; Count of nodes added that had different timestamps + s gWayCount=0 + s gWayAdd=0 ; Count of missing ways added + s gWayModified=0 ; Count of ways added that had different timestamps + s gRelCount=0 + s gRelAdd=0 ; Count of missing ways added + s gRelModified=0 ; Count of ways added that had different timestamps + s gNodeUser=0 + ; + ;k ^loadPlanet("element","node") + ;k ^loadPlanet("element","way") + ;k ^loadPlanet("element","relation") + k ^loadPlanet(session) + ; + s ^loadPlanet(session,"start")=$h + s ^loadPlanet(session,"pid")=$j + ; + ; + ; Read the file + s pipename="planet.pipe" + i session="node" s pipename="node.pipe" + i session="way" s pipename="way.pipe" + i session="relation" s pipename="relation.pipe" + d openPipe^stream(.sPipe,pipename) + s line=$$read^stream(.sPipe) ; prolog + s line=$$read^stream(.sPipe) ; + ; + f d i line="" q + . s line=$$read^stream(.sPipe) + . i sPipe("recordCount")#100000=0 d + . . s ^loadPlanet(session,"currentLineCount")=sPipe("recordCount") + . . s ^loadPlanet(session,"currentNodeCount")=gNodeCount + . . s ^loadPlanet(session,"currentNodesAdded")=gNodeAdd + . . s ^loadPlanet(session,"currentNodesModified")=gNodeModified + . . s ^loadPlanet(session,"currentWayCount")=gWayCount + . . s ^loadPlanet(session,"currentWaysAdded")=gWayAdd + . . s ^loadPlanet(session,"currentWaysModified")=gWayModified + . . s ^loadPlanet(session,"currentRelCount")=gRelCount + . . s ^loadPlanet(session,"currentRelationsAdded")=gRelAdd + . . s ^loadPlanet(session,"currentRelationsModified")=gRelModified + . . s ^loadPlanet(session,"currentNodeUser")=gNodeUser + . i line["" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + ; s ^loadPlanet("element","node",id)=timestamp + i '$d(^nodeVersion(id)) s gNodeAdd=gNodeAdd+1 d add^node(.sPipe) q + ; + s qsBox=$$qsBox^node(id) + s oldTimestamp=$p($g(^e(qsBox,"n",id,"a")),$c(1),3) + i oldTimestamp="" s oldTimestamp=$g(^e(qsBox,"n",id,"t","@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gNodeModified=gNodeModified+1 d add^node(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +addWay ; Private ; Check for ways that need to be added + ; + n id,timestamp,oldTimestamp + ; + s id=$p($p(line,"id="_q,2),q,1) + i id="" q + ; + ; ; Patch to add version tag + ; ; ********************************** + ; i '$d(^way(id)) q + ; i $d(^waytag(id,"@version")) q + ; s gWayAdd=gWayAdd+1 + ; s version=$p($p(line,"version=""",2),"""",1) i version="" q + ; s ^waytag(id,"@version")=version + ; s ^count("way","@version","*")=$g(^count("way","@version","*"))+1 + ; s ^count("way","@version",version)=$g(^count("way","@version",version))+1 + ; s qsBox=^way(id) + ; s ^wayx("@version",version,qsBox,id)="" + ; s ^wayx("@version","*",qsBox,id)="" + ; s ^wayx("*",version,qsBox,id)="" + ; i line["/>" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + ;s ^loadPlanet("element","way",id)=timestamp + i '$d(^way(id)) s gWayAdd=gWayAdd+1 d add^way(.sPipe) q + ; + s oldTimestamp=$g(^waytag(id,"@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gWayModified=gWayModified+1 d add^way(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +addRelation ; Private ; Check for relations that need to be added + ; + n id,timestamp,oldTimestamp + ; + s id=$p($p(line,"id="_q,2),q,1) + i id="" q + ; + ; ; Patch to add version tag + ; ; ********************************** + ; i '$d(^relation(id)) q + ; i $d(^relationtag(id,"@version")) q + ; s gRelAdd=gRelAdd+1 + ; s version=$p($p(line,"version=""",2),"""",1) i version="" q + ; s ^relationtag(id,"@version")=version + ; s ^count("relation","@version","*")=$g(^count("relation","@version","*"))+1 + ; s ^count("relation","@version",version)=$g(^count("relation","@version",version))+1 + ; s qsBox=^relation(id) + ; s ^relationx("@version",version,qsBox,id)="" + ; s ^relationx("@version","*",qsBox,id)="" + ; s ^relationx("*",version,qsBox,id)="" + ; i line["/>" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + ;s ^loadPlanet("element","relation",id)=timestamp + i '$d(^relation(id)) s gRelAdd=gRelAdd+1 d add^relation(.sPipe) q + ; + s oldTimestamp=$g(^relationtag(id,"@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gRelModified=gRelModified+1 d add^relation(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +delete ; Check for deletions + ; + n planetDate + n itemCount,deleteCount,id,itemDate,date + ; + w !,"Planet date ccyymmdd: " r planetDate i planetDate'?8n q + w ! + ; + ; Delete nodes + s itemCount=0,deleteCount=0 + s id="" + f d i id="" q + . s id=$o(^nodeVersion(id)) i id="" q + . s itemCount=itemCount+1 i itemCount#1000000=0 w "#" + . i $d(^loadPlanet("element","node",id)) q + . s itemDate=$p($g(^e($$qsBox^node(id),"n",id,"a")),$c(1),3) + . i itemDate="" s itemDate=$g(^e($$qsBox^node(id),"n",id,"t","@timestamp")) + . i itemDate="" q + . s date=$tr($e(itemDate,1,10),"-","") + . i date + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + ; Loads nodes and segments from a planet.osm. Replaces any existing nodes and segments + ; Deletes any nodes and segments that are not in planet.osm. + + d add + ;d delete + q + + +add ; Look for things that need to be added + ; + n q,ccyymmdd + n sPipe,line + n gNodeCount,gNodeAdd,gNodeModified + n gWayCount,gWayAdd,gWayModified + n gRelCount,gRelAdd,gRelModified + n gNodeUser + ; + s q="""" + s gNodeCount=0 + s gNodeAdd=0 ; Count of missing nodes added + s gNodeModified=0 ; Count of nodes added that had different timestamps + s gWayCount=0 + s gWayAdd=0 ; Count of missing ways added + s gWayModified=0 ; Count of ways added that had different timestamps + s gRelCount=0 + s gRelAdd=0 ; Count of missing ways added + s gRelModified=0 ; Count of ways added that had different timestamps + s gNodeUser=0 + ; + ;k ^osmLoadPlanet("node") + ;k ^osmLoadPlanet("way") + ;k ^osmLoadPlanet("relation") + k ^osmLoadPlanet("addWay") + ; + s ^osmLoadPlanet("addWay","start")=$h + s ^osmLoadPlanet("addWay","pid")=$j + ; + ; + ; Read the file + d openPipe^stream(.sPipe,"planetWay.pipe") + s line=$$read^stream(.sPipe) ; prolog + s line=$$read^stream(.sPipe) ; + ; + f d i line="" q + . s line=$$read^stream(.sPipe) + . i sPipe("recordCount")#100000=0 d + . . s ^osmLoadPlanet("addWay","currentLineCount")=sPipe("recordCount") + . . s ^osmLoadPlanet("addWay","currentNodeCount")=gNodeCount + . . s ^osmLoadPlanet("addWay","currentNodesAdded")=gNodeAdd + . . s ^osmLoadPlanet("addWay","currentNodesModified")=gNodeModified + . . s ^osmLoadPlanet("addWay","currentWayCount")=gWayCount + . . s ^osmLoadPlanet("addWay","currentWaysAdded")=gWayAdd + . . s ^osmLoadPlanet("addWay","currentWaysModified")=gWayModified + . . s ^osmLoadPlanet("addWay","currentRelCount")=gRelCount + . . s ^osmLoadPlanet("addWay","currentRelationsAdded")=gRelAdd + . . s ^osmLoadPlanet("addWay","currentRelationsModified")=gRelModified + . . s ^osmLoadPlanet("addWay","currentNodeUser")=gNodeUser + . ;i line["" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + s ^osmLoadPlanet("node",id)=timestamp + i '$d(^nodeVersion(id)) s gNodeAdd=gNodeAdd+1 d add^node(.sPipe) q + ; + s oldTimestamp=$p($g(^e($$qsBox^node(id),"n",id,"a")),$c(1),3) + i oldTimestamp="" s oldTimestamp=$g(^e($$qsBox^node(id),"n",id,"t","@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gNodeModified=gNodeModified+1 d add^node(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +addWay ; Private ; Check for ways that need to be added + ; + n id,timestamp,oldTimestamp + ; + s id=$p($p(line,"id="_q,2),q,1) + i id="" q + ; + ; ; Patch to add version tag + ; ; ********************************** + ; i '$d(^way(id)) q + ; i $d(^waytag(id,"@version")) q + ; s gWayAdd=gWayAdd+1 + ; s version=$p($p(line,"version=""",2),"""",1) i version="" q + ; s ^waytag(id,"@version")=version + ; s ^count("way","@version","*")=$g(^count("way","@version","*"))+1 + ; s ^count("way","@version",version)=$g(^count("way","@version",version))+1 + ; s qsBox=^way(id) + ; s ^wayx("@version",version,qsBox,id)="" + ; s ^wayx("@version","*",qsBox,id)="" + ; s ^wayx("*",version,qsBox,id)="" + ; i line["/>" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + ;s ^osmLoadPlanet("way",id)=timestamp + i '$d(^way(id)) s gWayAdd=gWayAdd+1 d add^way(.sPipe) q + ; + s oldTimestamp=$g(^waytag(id,"@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gWayModified=gWayModified+1 d add^way(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +addRelation ; Private ; Check for relations that need to be added + ; + n id,timestamp,oldTimestamp + ; + s id=$p($p(line,"id="_q,2),q,1) + i id="" q + ; + ; ; Patch to add version tag + ; ; ********************************** + ; i '$d(^relation(id)) q + ; i $d(^relationtag(id,"@version")) q + ; s gRelAdd=gRelAdd+1 + ; s version=$p($p(line,"version=""",2),"""",1) i version="" q + ; s ^relationtag(id,"@version")=version + ; s ^count("relation","@version","*")=$g(^count("relation","@version","*"))+1 + ; s ^count("relation","@version",version)=$g(^count("relation","@version",version))+1 + ; s qsBox=^relation(id) + ; s ^relationx("@version",version,qsBox,id)="" + ; s ^relationx("@version","*",qsBox,id)="" + ; s ^relationx("*",version,qsBox,id)="" + ; i line["/>" q + ; ; + ; f d i line["" q + ; . s line=$$read^stream(.sPipe) + ; q + ; ; + ; ; ********************************** + s timestamp=$p($p(line,"timestamp="_q,2),q,1) + s ^osmLoadPlanet("relation",id)=timestamp + i '$d(^relation(id)) s gRelAdd=gRelAdd+1 d add^relation(.sPipe) q + ; + s oldTimestamp=$g(^relationtag(id,"@timestamp")) + i $$toNumber^date(timestamp)>$$toNumber^date(oldTimestamp) s gRelModified=gRelModified+1 d add^relation(.sPipe) q + ; + i line["/>" q + ; + f d i line["" q + . s line=$$read^stream(.sPipe) + q + + +delete ; Check for deletions + ; + n planetDate + n itemCount,deleteCount,id,itemDate,date + ; + w !,"Planet date ccyymmdd: " r planetDate i planetDate'?8n q + w ! + ; + ; Delete nodes + s itemCount=0,deleteCount=0 + s id="" + f d i id="" q + . s id=$o(^nodeVersion(id)) i id="" q + . s itemCount=itemCount+1 i itemCount#1000000=0 w "#" + . i $d(^osmLoadPlanet("node",id)) q + . s itemDate=$p($g(^e($$qsBox^node(id),"n",id,"a")),$c(1),3) + . i itemDate="" s itemDate=$g(^e($$qsBox^node(id),"n",id,"t","@timestamp")) + . i itemDate="" q + . s date=$tr($e(itemDate,1,10),"-","") + . i date + ; + ; This program is free software: you can redistribute it and/or modify + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +requests ; Public ; Generate list of most recent requests + ; + d header^http("text/html") + ; + w "",! + w "",! + w "

Recent xapi requests on ",^osmPlanet("instance"),"

",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + ; + s logId="" + f i=1:1:50 d i logId="" q + . s logId=$o(^log(logId),-1) i logId="" q + . w "",! + . w "",! + . w "",! + . w "",! + . w "",! + . w "",! + ; + w "
",! + w "
IdRequestStart timeDuration
",logId,"",^log(logId,"request"),"",^log(logId,"start"),"",$g(^log(logId,"duration")),"
",! + w "",! + w "",! + q + + diff --git a/mapReduce.m b/mapReduce.m new file mode 100644 index 0000000..ca73b26 --- /dev/null +++ b/mapReduce.m @@ -0,0 +1,73 @@ +mapReduce ; Map reduce + + +map(class) ; Public ; Map something + d @("mapInit^"_class) + d @("mapMain^"_class) + d @("mapFinal^"_class) + q + + ; Usage: + ; d map^mapReduce(class,[taskId]) + ; + n root,length,key,global + ; + s taskId=$g(taskId) + ; + d @("mapInit^"_class_"(taskId)") + ; + ; Iterate through all mapped instances of this class (globals prefixed with % and the class name are considered to be instances) + s root="^%"_class,length=$l(root) + s global=root + f d i global="" q + . s global=$o(@global) i global="" q + . i $e(global,1,length)'=root s global="" q + . s key=$e(global,length+1,$l(global)) + . d @("mapMain^"_class_"(key,global,taskId)") + ; + d @("mapFinal^"_class_"(taskId)") + q + + +reduce(class) ; Public ; Reduce something + ; + n root,length,key,global + ; + d @("reduceInit^"_class) + ; + ; Iterate through all mapped instances of this class (globals prefixed with % and the class name are considered to be instances) + s root="^%"_class,length=$l(root) + s global=root + f d i global="" q + . s global=$o(@global) i global="" q + . i $e(global,1,length)'=root s global="" q + . s key=$e(global,length+1,$l(global)) + . d @("reduceMain^"_class_"(key,global)") + ; + d @("reduceFinal^"_class) + ; + q + + + +restMap(string) ; Public ; Map request for a class + ; + n step,nodeId,full,logId,indent + ; + ; Get next step (class) + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s class=step + ; + ; Get next step (token) + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s taskId=step + ; + ; One choices here: + ; /map// - Send a map task to a class + ; + d map(class,taskId) + ; + ; Send 200 response + d header^http("text/xml") + ; + q diff --git a/migrate.m b/migrate.m new file mode 100644 index 0000000..3674468 --- /dev/null +++ b/migrate.m @@ -0,0 +1,162 @@ +migrate ; Migrate database + ; + + + +wayByNode ; + ; + n c,nodeId,wayId + ; + s c=0 + s nodeId="",wayId="" + f d i nodeId="" q + . s nodeId=$o(^node(nodeId)) i nodeId="" q + . f d i wayId="" q + . . s wayId=$o(^node(nodeId,wayId)) i wayId="" q + . . s ^wayByNode(nodeId,wayId)="" + . . k ^node(nodeId,wayId) + . . s c=c+1 + . . i c#10000=0 w "." + w "Complete: ",c," records migrated",! + q + + +nodekv ; + w "." + m ^count("node")=^count("nodekv") + k ^count("nodekv") + ; + w "." + m ^count("node","@timestamp")=^count("node","osm:timestamp") + k ^count("node","osm:timestamp") + ; + w "." + m ^count("node","@user")=^count("node","osm:user") + k ^count("node","osm:user") + ; + w "." + m ^count("node","@xapi:users")=^count("node","osm:users") + k ^count("node","osm:users") + ; + w "." + m ^nodex("@timestamp")=^nodex("osm:timestamp") + k ^nodex("osm:timestamp") + ; + w "." + m ^nodex("@user")=^nodex("osm:user") + k ^nodex("osm:user") + ; + w "." + m ^nodex("@xapi:users")=^nodex("osm:users") + k ^nodex("osm:users") + q + + + +waykv ; + w "." + m ^count("way")=^count("waykv") + k ^count("waykv") + ; + w "." + m ^count("way","@timestamp")=^count("way","osm:timestamp") + k ^count("way","osm:timestamp") + ; + w "." + m ^count("way","@user")=^count("way","osm:user") + k ^count("way","osm:user") + ; + w "." + m ^count("way","@xapi:users")=^count("way","osm:users") + k ^count("way","osm:users") + ; + w "." + m ^wayx("@timestamp")=^wayx("osm:timestamp") + k ^wayx("osm:timestamp") + ; + w "." + m ^wayx("@user")=^wayx("osm:user") + k ^wayx("osm:user") + ; + w "." + m ^wayx("@xapi:users")=^wayx("osm:users") + k ^wayx("osm:users") + q + + +relkv ; + w "." + m ^count("relation")=^count("relationkv") + k ^count("relationkv") + ; + w "." + m ^count("relation","@timestamp")=^count("relation","osm:timestamp") + k ^count("relation","osm:timestamp") + ; + w "." + m ^count("relation","@user")=^count("relation","osm:user") + k ^count("relation","osm:user") + ; + w "." + m ^count("relation","@xapi:users")=^count("relation","osm:users") + k ^count("relation","osm:users") + ; + w "." + m ^relationx("@timestamp")=^relationx("osm:timestamp") + k ^relationx("osm:timestamp") + ; + w "." + m ^relationx("@user")=^relationx("osm:user") + k ^relationx("osm:user") + ; + w "." + m ^relationx("@xapi:users")=^relationx("osm:users") + k ^relationx("osm:users") + q + +nodetag ; + s id="",c=0 + f d i id="" q + . s id=$o(^nodetag(id)) i id="" q + . i $d(^nodetag(id,"osm:timestamp")) s ^nodetag(id,"@timestamp")=^nodetag(id,"osm:timestamp") k ^nodetag(id,"osm:timestamp") + . i $d(^nodetag(id,"osm:user")) s ^nodetag(id,"@user")=^nodetag(id,"osm:user") k ^nodetag(id,"osm:user") + . i $d(^nodetag(id,"osm:users")) s ^nodetag(id,"@xapi:users")=^nodetag(id,"osm:users") k ^nodetag(id,"osm:users") + . ; i $d(^nodetag(id,"osm:uid")) s ^nodetag(id,"@uid")=^nodetag(id,"osm:uid") k ^nodetag(id,"osm:uid") + . s c=c+1 i c#1000000=0 w "." + q + + +waytag ; + s id="",c=0 + f d i id="" q + . s id=$o(^waytag(id)) i id="" q + . i $d(^waytag(id,"osm:timestamp")) s ^waytag(id,"@timestamp")=^waytag(id,"osm:timestamp") k ^waytag(id,"osm:timestamp") + . i $d(^waytag(id,"osm:user")) s ^waytag(id,"@user")=^waytag(id,"osm:user") k ^waytag(id,"osm:user") + . i $d(^waytag(id,"osm:users")) s ^waytag(id,"@xapi:users")=^waytag(id,"osm:users") k ^waytag(id,"osm:users") + . ; i $d(^waytag(id,"osm:uid")) s ^waytag(id,"@uid")=^waytag(id,"osm:uid") k ^waytag(id,"osm:uid") + . s c=c+1 i c#1000000=0 w "." + q + + +reltag ; + s id="",c=0 + f d i id="" q + . s id=$o(^relationtag(id)) i id="" q + . i $d(^relationtag(id,"osm:timestamp")) s ^relationtag(id,"@timestamp")=^relationtag(id,"osm:timestamp") k ^relationtag(id,"osm:timestamp") + . i $d(^relationtag(id,"osm:user")) s ^relationtag(id,"@user")=^relationtag(id,"osm:user") k ^relationtag(id,"osm:user") + . i $d(^relationtag(id,"osm:users")) s ^relationtag(id,"@xapi:users")=^relationtag(id,"osm:users") k ^relationtag(id,"osm:users") + . ; i $d(^relationtag(id,"osm:uid")) s ^relationtag(id,"@uid")=^relationtag(id,"osm:uid") k ^relationtag(id,"osm:uid") + . s c=c+1 i c#1000000=0 w "." + q + + +orderedMembers ; Delete all relation data and reload from a planet + ; + k ^relation + k ^relationMx + k ^relationx + k ^relationtag + ; + ; Now load from a planet file using loadPlanet.m + q + diff --git a/node.m b/node.m new file mode 100644 index 0000000..be5bf51 --- /dev/null +++ b/node.m @@ -0,0 +1,867 @@ +node ; Node Class (new structure using ^element instead of ^node and ^nodetag) + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + + ; add(sNode,delete) ; Public ; Add a node + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,changeset,qsOld + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + s qsOld="" + ; + s currentVersion=0,fork=0 + i $d(^nodeVersion(nodeId,"v")) d + . s qsOld=$$qsBox(nodeId) + . s fork=$p($g(^e(qsOld,"n",nodeId,"a")),$c(1),6) + ; + i ($$currentVersion(nodeId)>version)!(fork) d q ; Don't load older versions + . ; + . ; Log conflict + . s uid=$p($g(^e(qsOld,"n",nodeId,"a")),$c(1),4) + . i uid="" q + . ; + . s seq=$g(^conflict(uid))+1 + . s ^conflict(uid)=seq + . s ^conflict(uid,seq,"@type")="node" + . s ^conflict(uid,seq,"@id")=nodeId + . s ^conflict(uid,seq,"@changeset")=changeset + . s ^conflict(uid,seq,"@version")=version + . s ^conflict(uid,seq,"@uid")=$$getAttribute^osmXml(line,"uid") + . s ^conflict(uid,seq,"@timestamp")=$$getAttribute^osmXml(line,"timestamp") + . s ^conflict(uid,seq,"@visible")=$s(delete:"false",1:"true") + . ; + . ; Skip rest of node element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sNode) + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^e(qsOld,"n",nodeId,"l") + . s ^e(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^c(changeset)) s ^c(changeset)="" + i '$d(^c(changeset,"n",nodeId)) s ^c(changeset,"n",nodeId)="" + s ^c(changeset,"n",nodeId,"v",version)="" + s ^c(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + i user["'" s user=$$xmlEscapeApostrophe(user) + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; Update - node attributes + i qsOld'="",qsOld'=qsBox k ^e(qsOld,"n",nodeId,"a") + s visible="" i delete s visible="false" + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_$c(1) + s ^e(qsBox,"n",nodeId,"a")=a + s ^c(changeset,"n",nodeId,"v",version,"a")=a + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Update process elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^e(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^e(qsOld,"n",nodeId) + ; + ; Create export index + s ^export($$nowZulu^date(),"n",changeset,nodeId,version)="" + ; + ; Update user class + d add^user(uid,user) + ; + d onEdit^user(uid) + q + + +import(sNode,delete) ; Public ; Import a node and add it to the changeset + ; #sNode = stream object containing node + ; + n line,nodeId,version,changeset + n lat,lon,qsNew,timestamp,user,uid + n visible,fork,a + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsNew=$$llToQs^quadString(lat,lon) + ; + ; Update - changeset + i '$d(^c(changeset)) s ^c(changeset)="" + i '$d(^c(changeset,"n",nodeId)) s ^c(changeset,"n",nodeId)="" + s ^c(changeset,"n",nodeId,"v",version)="" + s ^c(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + i user["'" s user=$$xmlEscapeApostrophe(user) + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; Update - node attributes + s visible="" i delete s visible="false" + s fork=0 + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_fork_$c(1)_qsNew + s ^c(changeset,"n",nodeId,"v",version,"a")=a + s ^temp($j,"loadDiff","n",nodeId,"a")=a + ; + ; Update process elements + i line'["/>" f d i line'["" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s key=$$getAttribute^osmXml(line,"k") i key="" q + i $l(key)>100 s key=$e(key,1,100)_".." + s value=$$getAttribute^osmXml(line,"v") + i value["'" s value=$$xmlEscapeApostrophe(value) + i $l(value)>4000 s value=$e(value,1,4000)_".." + ; + d importTag(qsNew,nodeId,key,value,changeset,version) + q + + +importTag(qsNew,nodeId,key,newValue,newChangeset,newVersion) ; Private ; Add key/value pair for a node to the changeset + ; + ; Usage: + ; d updateTag(qsNew,nodeId,key,newValue,newChangeset,newVersion) + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; + n u,intNewValue + ; + ; Get internal value for the key or assign one + s u=$g(^keyx(key)) + i u="" d + . l +^key + . s (u,^key)=^key+1 + . s ^key(u)=key + . s ^keyx(key)=u + . l -^key + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + ; Add the tag to the node definition in the changeset + s ^c(newChangeset,"n",nodeId,"v",newVersion,"u",u)=newValue + ; + q + + +addNodeFromChangeset(changeset,nodeId,version) ; Public ; Add a node from a changeset + ; + n qsOld,a,timestamp,delete,qsNew,l + n u,key,value,intValue + ; + s qsOld=$g(^nodeVersion(nodeId,"q")) + ; + s a=^c(changeset,"n",nodeId,"v",version,"a") + s timestamp=$p(a,$c(1),3) + s delete=($p(a,$c(1),5)="false") + s qsNew=$p(a,$c(1),7) + s l=^c(changeset,"n",nodeId,"v",version,"l") + ; + ; Old changesets don't have the qs stored on them + i qsNew="" s qsNew=$$llToQs^quadString($p(l,$c(1),1),$p(l,$c(1),2)) + ; + ; Update - node + i 'delete d + . ; + . ; If the qs key has changed then delete the old entries + . i qsOld'="",qsOld'=qsNew d + . . k ^e(qsOld,"n",nodeId,"l") + . . k ^e(qsOld,"n",nodeId,"a") + . ; + . ; Update the node with new values + . s ^e(qsNew,"n",nodeId,"l")=l + . s ^e(qsNew,"n",nodeId,"a")=$p(a,$c(1),1,6) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsNew + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Update process elements + s u="" + f d i u="" q + . s u=$o(^c(changeset,"n",nodeId,"v",version,"u",u)) i u="" q + . s value=^c(changeset,"n",nodeId,"v",version,"u",u) + . d addTagFromChangeset(qsOld,qsNew,nodeId,u,value,changeset,version,delete) + ; + ; Delete all tags that are not on the new version of the node + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^e(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^c(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^e(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^e(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^e(qsOld,"n",nodeId) + ; + ; Create export index + s ^export($$nowZulu^date(),"n",changeset,nodeId,version)="" + ; + ; Update metrics + i version=1 s ^metric("nodeCount")=$g(^metric("nodeCount"))+1 + i delete s ^metric("nodeCount")=$g(^metric("nodeCount"))-1 + ; + q + + +addTagFromChangeset(qsOld,qsNew,nodeId,u,newValue,changeset,version,delete) ; Private ; Update (add/modify/delete) a key/value pair for a node + ; + ; Usage: + ; d updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) + ; qsOld - qs of the old node. Null if this is a new node with no previous version + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; delete - 1 if the whole node is being deleted, 0 if this is an update + ; + n key,oldValue,intNewValue,intOldValue + ; + s key=^key(u) + ; + s oldValue="" + i qsOld'="" s oldValue=$g(^e(qsOld,"n",nodeId,"u",u)) + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + s intOldValue=oldValue + i $l(oldValue)>100 s intOldValue=$e(oldValue,1,100)_".." + ; + ; Delete the tag and it's indexes if the node is being deleted + i delete d + . ; k ^e(qsOld,"n",nodeId,"u",u) ; Don't actually need to do this becaue the whole node will be deleted anyway + . i intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + ; Add/Update the tag for the element + e d + . i (oldValue'=newValue)!(qsOld'=qsNew) d ; Optimisation, can be used when all t tags have gone + . . i qsOld'="",qsOld'=qsNew k ^e(qsOld,"n",nodeId,"u",u) + . . i qsNew'="" s ^e(qsNew,"n",nodeId,"u",u)=newValue + . ; + . ; Update the two key/value indexes + . i (intOldValue'=intNewValue)!(qsOld'=qsNew) d + . . i qsOld'="",intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . . i qsNew'="",intNewValue'="" s ^nodex(key,intNewValue,qsNew,nodeId)="" + . . i qsOld'="" k ^nodex(key,"*",qsOld,nodeId) + . . i qsNew'="" s ^nodex(key,"*",qsNew,nodeId)="" + ; + q + + + +addDiff(sNode,delete,changeset) ; Public ; Add a node from the diff upload API (not from the OSM import) + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,qsOld,ok + n a,visible,fork + ; + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s timestamp=$$nowZulu^date() + ; + ; New nodes + s ok=1 + i nodeId<0 d + . s oldId=nodeId + . l +^id("node") + . s nodeId=^id("node")+1 + . s ^id("node")=nodeId + . l -^id("node") + . s newId=nodeId + . s version=1 + . s qsOld="" + . ; + . ; Add to new item map + . s ^temp($j,"node",oldId)=newId + ; + ; Existing nodes + e d i 'ok q 0 + . s version=$$getAttribute^osmXml(line,"version") + . ; check version match + . i $$currentVersion(nodeId)'=version d error409^http("Version mismatch: Provided "_version_", server had: "_$$currentVersion(nodeId)_" of Node "_nodeId) s ok=0 q ; Version mismatch + . s oldId=nodeId + . s newId=nodeId + . s version=version+1 + . s qsOld=$$qsBox(nodeId) + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^e(qsOld,"n",nodeId,"l") + . s ^e(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^c(changeset)) s ^c(changeset)="" + i '$d(^c(changeset,"n",nodeId)) s ^c(changeset,"n",nodeId)="" + s ^c(changeset,"n",nodeId,"v",version)="" + s ^c(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s uid=$g(^c(changeset,"t","@uid")) + s user=^user(uid,"name") + i user["'" s user=$$xmlEscapeApostrophe(user) + ; + ; Update - node attributes + i qsOld'="",qsOld'=qsBox k ^e(qsOld,"n",nodeId,"a") + s visible="" i delete s visible="false" + s fork=1 + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_fork_$c(1) + s ^e(qsBox,"n",nodeId,"a")=a + s ^c(changeset,"n",nodeId,"v",version,"a")=a + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Process any elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^e(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^e(qsOld,"n",nodeId) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + s rSeq=$g(^response($j))+1 + s ^response($j)=rSeq + ; + i delete s newId="",version="" + ; + s ^response($j,rSeq,"oldId")=oldId + s ^response($j,rSeq,"newId")=newId + s ^response($j,rSeq,"version")=version + s ^response($j,rSeq,"element")="node" + ; + d onEdit^user(uid) + ; + q 1 + + + + + +sUpdateTag(sNode,qsOld,qsNew,nodeId,changeset,version,delete) ; Private load a tag and add it + ; + n line,key,value + ; + s line=sNode("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s key=$$getAttribute^osmXml(line,"k") i key="" q + i $l(key)>100 s key=$e(key,1,100)_".." + s value=$$getAttribute^osmXml(line,"v") + i value["'" s value=$$xmlEscapeApostrophe(value) + i $l(value)>4000 s value=$e(value,1,4000)_".." + ; + d updateTag(qsOld,qsNew,nodeId,key,value,changeset,version,delete) + q + + +updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) ; Private ; Update (add/modify/delete) a key/value pair for a node + ; + ; Usage: + ; d updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) + ; qsOld - qs of the old node. Null if this is a new node with no previous version + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; delete - 1 if the whole node is being deleted, 0 if this is an update + ; + n u,oldValue,intNewValue,intOldValue + ; + ; Get internal value for the key or assign one + s u=$g(^keyx(key)) + i u="" d + . l +^key + . s (u,^key)=^key+1 + . s ^key(u)=key + . s ^keyx(key)=u + . l -^key + ; + s oldValue="" + i qsOld'="" s oldValue=$g(^e(qsOld,"n",nodeId,"u",u)) + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + s intOldValue=oldValue + i $l(oldValue)>100 s intOldValue=$e(oldValue,1,100)_".." + ; + ; Always add the tag to the node definition in the changeset + s ^c(newChangeset,"n",nodeId,"v",newVersion,"u",u)=newValue + ; + ; Delete the tag and it's indexes if the node is being deleted + i delete d + . ; k ^e(qsOld,"n",nodeId,"u",u) ; Don't actually need to do this becaue the whole node will be deleted anyway + . i intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + ; Add/Update the tag for the element + e d + . i (oldValue'=newValue)!(qsOld'=qsNew) d ; Optimisation, can be used when all t tags have gone + . . i qsOld'="",qsOld'=qsNew k ^e(qsOld,"n",nodeId,"u",u) + . . i qsNew'="" s ^e(qsNew,"n",nodeId,"u",u)=newValue + . ; + . ; Update the two key/value indexes + . i (intOldValue'=intNewValue)!(qsOld'=qsNew) d + . . i qsOld'="",intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . . i qsNew'="",intNewValue'="" s ^nodex(key,intNewValue,qsNew,nodeId)="" + . . i qsOld'="" k ^nodex(key,"*",qsOld,nodeId) + . . i qsNew'="" s ^nodex(key,"*",qsNew,nodeId)="" + ; + q + + +delete(nodeId) ; Public ; Delete a node + ; + n key,u,value,qsBox + ; + s qsBox=$$qsBox(nodeId) i qsBox="" q + ; + s u="" + f d i u="" q + . s u=$o(^e(qsBox,"n",nodeId,"u",u)) i u="" q + . s value=^e(qsBox,"n",nodeId,"u",u) + . s key=^key(u) + . i $l(value)>100 s value=$e(value,1,100)_".." + . i value'="" k ^nodex(key,value,qsBox,nodeId) + . k ^nodex(key,"*",qsBox,nodeId) + ; + k ^e(qsBox,"n",nodeId) + ; + q + + +xml(indent,nodeId,select,qsBox) ; Public ; Generate xml for node + ; + ; indent = XML indent + ; nodeId = id of node to emit + ; select [deprecated] = attributes and sub-elements to emit + ; qsBox [optional] = qsBox of element if known (faster if provided) + ; + n latlon,a,user,uid,uidUser,timestamp,version,changeset + n xml + ; + i $g(qsBox)="" s qsBox=$$qsBox(nodeId) i qsBox="" q "" + ; + s xml="" + ; + s latlon=$g(^e(qsBox,"n",nodeId,"l")) i latlon="" q "" + s a=^e(qsBox,"n",nodeId,"a") + s version=$p(a,$c(1),1) + s changeset=$p(a,$c(1),2) + s timestamp=$p(a,$c(1),3) + s uid=$p(a,$c(1),4) + s user="" i uid'="" s user=$g(^user(uid,"name")) + ; + s xml=xml_indent_""_$c(13,10) + ; + s xml=xml_$$xmlTags(nodeId,indent,qsBox) + s xml=xml_indent_""_$c(13,10) + ; + q xml + + +xmlTags(id,indent,qsBox) ; Private ; Generate xml for node's tags + ; + n k,u,xml + ; + s xml="" + ; + s indent=indent_" " + ; + ; Compiled keys + s u="" + f d i u="" q + . s u=$o(^e(qsBox,"n",id,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + ; + q xml + + +qsBox(nodeId) ; Public ; Get quadString for a node + ; + q $g(^nodeVersion(nodeId,"q")) + + +bbox(nodeId,bllat,bllon,trlat,trlon) ; Public ; Get bbox for a node + ; + n latlon,lat,lon,qsBox + ; + s qsBox=$$qsBox(nodeId) i qsBox="" q + ; + s latlon=$g(^e(qsBox,"n",nodeId,"l")) + s lat=$p(latlon,$c(1),1) + s lon=$p(latlon,$c(1),2) + ; + s trlat=lat + s bllat=lat + s trlon=lon + s bllon=lon + q + + +xmlEscapeApostrophe(string) ; Private ; Escape apostrophe + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +hasRealTag(id) ; Public ; Does this node have a real tag? + ; + n qsBox + ; + s qsBox=$$qsBox(id) + ; + i $d(^e(qsBox,"n",id,"u")) q 1 + ; + q 0 + + +versionAtChangeset(nodeId,changeset,nodeChangeset,nodeVersion) ; Public ; Get the changeset and version that was current at a given changeset time + ; + ; Usage: + ; d versionAtChangeset^node(nodeId,changeset,.nodeChangeset,.nodeVersion) i nodeChangeset="" ... + ; Output: + ; nodeChangeset - null if not found + ; nodeVersion - null if not found + ; + s nodeChangeset=changeset + s nodeVersion="" + i '$d(^nodeVersion(nodeId,"c",nodeChangeset)) s nodeChangeset=$o(^nodeVersion(nodeId,"c",nodeChangeset),-1) i nodeChangeset="" q + s nodeVersion=$o(^nodeVersion(nodeId,"c",nodeChangeset,""),-1) i nodeVersion="" s nodeChangeset="" q + ; + q + + +restNode(string) ; Public ; Single node query + ; + n step,nodeId,full,logId,indent + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s nodeId=step + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Four choices here: + ; - current node only + ; ways - all ways that use the node + ; #version - specific version of node + ; #version/ways - all ways that used this version of the node + ; history - all versions of this node + s full=0 + i step="" s full=0 + i step="ways" d restWaysByNode(nodeId) q + i step="relations" d restRelationsByNode(nodeId) q + i step="history" d restNodeHistory(nodeId) q + i step?1.n d restNode^nodeVersion(nodeId,step,string) q + ; + s logId=$$logStart^xapi("node/"_nodeId,"") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i '$d(^e(qsBox,"n",nodeId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + i $p($g(^e(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,nodeId,"node|@*|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +restWaysByNode(nodeId) ; Public ; Ways by Node + ; + n indent,logId,wayId,count + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/ways","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^e(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + s wayId="" + f d i wayId="" q + . s wayId=$o(^wayByNode(nodeId,wayId)) i wayId="" q + . w $$xml^way(indent,wayId,"way|@*|nd|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restRelationsByNode(nodeId) ; Public ; Relations by Node + ; + n indent,logId,relationId,count + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/relations","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^e(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + s relationId="" + f d i relationId="" q + . s relationId=$o(^relationMx("node",nodeId,relationId)) i relationId="" q + . w $$xml^relation(indent,relationId,"relation|@*|member|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodes(step,string) ; Public ; Multi node query + ; + n logId,count,indent + n nodeIds,nodeId,ok,i,version,changesetId + ; + s count=0 + s logId=$$logStart^xapi($$decode^xapi(step),"") + ; + s nodeIds=$p(step,EQUALS,2) + ; + ; Validate query + s ok=1 + f i=1:1:$l(nodeIds,",") d i 'ok q + . s nodeId=$p(nodeIds,",",i) + . i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . ; Is it there? + . i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . ; s qsBox=$$qsBox(nodeId) + . ; i '$d(^e(qsBox,"n",nodeId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + . ; i $p($g(^e(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + i 'ok q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + f i=1:1:$l(nodeIds,",") d + . s nodeId=$p(nodeIds,",",i) + . s version=$o(^nodeVersion(nodeId,"v",""),-1) i version="" q + . s changesetId=^nodeVersion(nodeId,"v",version) + . w $$xml^nodeVersion(indent,nodeId,changesetId,version,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodeHistory(nodeId) ; Public ; All versions of node + ; + n logId,count,indent + n version,changeset + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/history","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Iterate all versions + s version="" + f d i version="" q + . s version=$o(^nodeVersion(nodeId,"v",version)) i version="" q + . s changeset=^nodeVersion(nodeId,"v",version) + . ; + . w $$xml^nodeVersion(indent,nodeId,changeset,version,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +currentVersion(nodeId) ; Public ; Return the current version number of a node + ; + ; Usage: s currentVersion=$$currentVersion^node(nodeId) + ; Input: + ; nodeId - node id, must not be null + ; Output: + ; currentVersion - if the node does not exists then null is returned + ; + q $o(^nodeVersion(nodeId,"v",""),-1) + diff --git a/nodeNew.m b/nodeNew.m new file mode 100644 index 0000000..78de0a7 --- /dev/null +++ b/nodeNew.m @@ -0,0 +1,757 @@ +node ; Node Class (new structure using ^element instead of ^node and ^nodetag) + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +add(sNode,delete) ; Public ; Add a node + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,changeset,qsOld + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + s qsOld="" + ; + s currentVersion=0,fork=0 + i $d(^nodeVersion(nodeId)) d + . s qsOld=$$qsBox(nodeId) + . i $d(^element(qsOld,"n",nodeId,"a")) d + . . s fork=$p(^element(qsOld,"n",nodeId,"a"),$c(1),6) + . e d + . . s fork=$d(^element(qsOld,"n",nodeId,"t","@fork")) + ; + i ($$currentVersion(nodeId)>version)!(fork) d q ; Don't load older versions + . ; + . ; Log conflict + . i $d(^element(qsOld,"n",nodeId,"a")) d + . . s uid=$p(^element(qsOld,"n",nodeId,"a"),$c(1),4) + . e d + . . s uid=$g(^element(qsOld,"n",nodeId,"t","@uid")) + . i uid="" q + . ; + . s seq=$g(^conflict(uid))+1 + . s ^conflict(uid)=seq + . s ^conflict(uid,seq,"@type")="node" + . s ^conflict(uid,seq,"@id")=nodeId + . s ^conflict(uid,seq,"@changeset")=changeset + . s ^conflict(uid,seq,"@version")=version + . s ^conflict(uid,seq,"@uid")=$$getAttribute^osmXml(line,"uid") + . s ^conflict(uid,seq,"@timestamp")=$$getAttribute^osmXml(line,"timestamp") + . s ^conflict(uid,seq,"@visible")=$s(delete:"false",1:"true") + . ; + . ; Skip rest of node element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sNode) + ; + ;d delete(nodeId) + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^element(qsOld,"n",nodeId,"l") + . s ^element(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^changeset(changeset)) s ^changeset(changeset)="" + i '$d(^changeset(changeset,"n",nodeId)) s ^changeset(changeset,"n",nodeId)="" + s ^changeset(changeset,"n",nodeId,"v",version)="" + s ^changeset(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + i user["'" s user=$$xmlEscapeApostrophe(user) + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; Update - node attributes + i qsOld'="",qsOld'=qsBox k ^element(qsBox,"n",nodeId,"a") + s visible="" i delete s visible="false" + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_$c(1) + s ^element(qsBox,"n",nodeId,"a")=a + s ^changeset(changeset,"n",nodeId,"v",version,"a")=a + ; + ; d updateTag(qsOld,qsBox,nodeId,"@timestamp",timestamp,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@user",user,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@uid",uid,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@version",version,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@changeset",changeset,changeset,version,delete) + ; i delete d updateTag(qsOld,qsBox,nodeId,"@visible","false",changeset,version,delete) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Update process elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"t",key) + ; + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^element(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^changeset(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^element(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^element(qsOld,"n",nodeId) + ; + ; Create quad string indexes on each of the tags in the node + ; i 'delete d indexTags(qsBox,nodeId,version) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + ; Update user class + d add^user(uid,user) + ; + d onEdit^user(uid) + q + + +addDiff(sNode,delete) ; Public ; Add a node from the diff upload API + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,changeset,qsOld,ok + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s changeset=$$getAttribute^osmXml(line,"changeset") + s timestamp=$$nowZulu^date() + ; + ; New nodes + i nodeId<0 d + . s oldId=nodeId + . l +^id("node") + . s nodeId=^id("node")+1 + . s ^id("node")=nodeId + . l -^id("node") + . s newId=nodeId + . s version=1 + . s qsOld="" + . ; + . ; Add to new item map + . s ^temp($j,"node",oldId)=newId + ; + ; Existing nodes + s ok=1 + e d i 'ok q 0 + . s version=$$getAttribute^osmXml(line,"version") + . ; check version match + . i $$currentVersion(nodeId)'=version d error409^http("Version mismatch: Provided "_version_", server had: "_$$currentVersion(nodeId)_" of Node "_nodeId) s ok=0 q ; Version mismatch + . s oldId=nodeId + . s newId=nodeId + . s version=version+1 + . s qsOld=$$qsBox(nodeId) + . ; d delete(nodeId) ; delete old version + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^element(qsOld,"n",nodeId,"l") + . s ^element(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^changeset(changeset)) s ^changeset(changeset)="" + i '$d(^changeset(changeset,"n",nodeId)) s ^changeset(changeset,"n",nodeId)="" + s ^changeset(changeset,"n",nodeId,"v",version)="" + s ^changeset(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s uid=$g(^changeset(changeset,"t","@uid")) + s user=^user(uid,"name") + i user["'" s user=$$xmlEscapeApostrophe(user) + ; + ; Update - node attributes + i qsOld'="",qsOld'=qsBox k ^element(qsBox,"n",nodeId,"a") + s visible="" i delete s visible="false" + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_$c(1) + s ^element(qsBox,"n",nodeId,"a")=a + s ^changeset(changeset,"n",nodeId,"v",version,"a")=a + ; + ; d updateTag(qsOld,qsBox,nodeId,"@timestamp",timestamp,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@user",user,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@uid",uid,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@version",version,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@changeset",changeset,changeset,version,delete) + ; d updateTag(qsOld,qsBox,nodeId,"@fork",1,changeset,version,delete) + ; i delete d updateTag(qsOld,qsBox,nodeId,"@visible","false",changeset,version,delete) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Process any elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"t",key) + ; + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^element(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^changeset(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^element(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^element(qsOld,"n",nodeId) + ; + ; Create quad string indexes on each of the tags in the node + ; i 'delete d indexTags(qsBox,nodeId,version) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + s rSeq=$g(^response($j))+1 + s ^response($j)=rSeq + ; + i delete s newId="",version="" + ; + s ^response($j,rSeq,"oldId")=oldId + s ^response($j,rSeq,"newId")=newId + s ^response($j,rSeq,"version")=version + s ^response($j,rSeq,"element")="node" + ; + d onEdit^user(uid) + ; + q 1 + + +addTag(sNode,qsBox,nodeId,changeset,version,delete) ; Private ; Load a tag and add it + ; + n line,k,v + ; + s line=sNode("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s k=$$getAttribute^osmXml(line,"k") i k="" q + i $l(k)>100 s k=$e(k,1,100)_".." + s v=$$getAttribute^osmXml(line,"v") + i v["'" s v=$$xmlEscapeApostrophe(v) + i $l(v)>4000 s v=$e(v,1,4000)_".." + ; + i 'delete s ^element(qsBox,"n",nodeId,"t",k)=v + s ^changeset(changeset,"n",nodeId,"v",version,"t",k)=v + ; + q + +sUpdateTag(sNode,qsOld,qsNew,nodeId,changeset,version,delete) ; Private load a tag and add it + ; + n line,key,value + ; + s line=sNode("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s key=$$getAttribute^osmXml(line,"k") i key="" q + i $l(key)>100 s key=$e(key,1,100)_".." + s value=$$getAttribute^osmXml(line,"v") + i value["'" s value=$$xmlEscapeApostrophe(value) + i $l(value)>4000 s value=$e(value,1,4000)_".." + ; + d updateTag(qsOld,qsNew,nodeId,key,value,changeset,version,delete) + q + + +indexTags(qsBox,nodeId,version) ; Private ; Create quad string index entries for a single node + ; + n k,u,v + ; + s k="" + f d i k="" q + . s k=$o(^element(qsBox,"n",nodeId,"t",k)) i k="" q + . i k="@xapi:users" q + . i k="@version" q + . i k="@timestamp" q + . i k="@fork" q + . s v=^element(qsBox,"n",nodeId,"t",k) + . i $l(v)>100 s v=$e(v,1,100)_".." + . i v="" q + . s ^nodex(k,v,qsBox,nodeId)="" + . s ^nodex(k,"*",qsBox,nodeId)="" + ; + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",nodeId,"u",u)) i u="" q + . s v=^element(qsBox,"n",nodeId,"u",u) + . s k=^key(u) + . i $l(v)>100 s v=$e(v,1,100)_".." + . i v="" q + . s ^nodex(k,v,qsBox,nodeId)="" + . s ^nodex(k,"*",qsBox,nodeId)="" + ; + ; TODO: Index @changeset, @uid, @user pieces from "a" + q + + +updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) ; Private ; Update (add/modify/delete) a key/value pair for a node + ; + ; Usage: + ; d updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) + ; qsOld - qs of the old node. Null if this is a new node with no previous version + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; delete - 1 if the whole node is being deleted, 0 if this is an update + ; + n u,oldValue,intNewValue,intOldValue + ; + ; Get internal value for the key or assign one + s u=$g(^keyx(key)) + i u="" d + . s (u,^key)=^key+1 + . s ^key(u)=key + . s ^keyx(key)=u + ; + s oldValue="" + i qsOld'="" d + . i $e(key,1)="@",$d(^element(qsOld,"n",nodeId,"a")) d + . . s a=^element(qsOld,"n",nodeId,"a") + . . i key="@version" s oldValue=$p(a,$c(1),1) q + . . i key="@changeset" s oldValue=$p(a,$c(1),2) q + . . i key="@timestamp" s oldValue=$p(a,$c(1),3) q + . . i key="@uid" s oldValue=$p(a,$c(1),4) q + . . i key="@visible" s oldValue=$p(a,$c(1),5) q + . . i key="@fork" s oldValue=$p(a,$c(1),6) q + . . i key="@user" s oldValue=$g(^user($p(a,$c(1),4),"name")) q + . e d + . . s oldValue=$g(^element(qsOld,"n",nodeId,"t",key)) + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + s intOldValue=oldValue + i $l(oldValue)>100 s intOldValue=$e(oldValue,1,100)_".." + ; + ; Always add the tag to the node definition in the changeset + ; s ^changeset(newChangeset,"n",nodeId,"v",newVersion,"t",key)=newValue + s ^changeset(newChangeset,"n",nodeId,"v",newVersion,"u",u)=newValue + ; + ; Delete the tag and it's indexes if the node is being deleted + i delete d + . ; k ^element(qsOld,"n",nodeId,"t",key) ; Don't actually need to do this becaue the whole node will be deleted anyway + . i intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + ; Add/Update the tag for the element + e d + . i (oldValue'=newValue)!(qsOld'=qsNew) d + . . i qsOld'="",qsOld'=qsNew k ^element(qsOld,"n",nodeId,"u",u) + . . i qsNew'="" s ^element(qsNew,"n",nodeId,"u",u)=newValue + . ; + . ; Update the two key/value indexes + . i (intOldValue'=intNewValue)!(qsOld'=qsNew) d + . . i key="@version" q + . . i key="@timestamp" q + . . i key="@fork" q + . . i qsOld'="",intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . . i qsNew'="",intNewValue'="" s ^nodex(key,intNewValue,qsNew,nodeId)="" + . . i qsOld'="" k ^nodex(key,"*",qsOld,nodeId) + . . i qsNew'="" s ^nodex(key,"*",qsNew,nodeId)="" + ; + q + + +delete(nodeId) ; Public ; Delete a node + ; + n key,u,value,qsBox + ; + s qsBox=$$qsBox(nodeId) i qsBox="" q + ; + s key="" + f d i key="" q + . s key=$o(^element(qsBox,"n",nodeId,"t",key)) i key="" q + . s value=^element(qsBox,"n",nodeId,"t",key) + . i $l(value)>100 s value=$e(value,1,100)_".." + . i value'="" k ^nodex(key,value,qsBox,nodeId) + . k ^nodex(key,"*",qsBox,nodeId) + ; + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",nodeId,"u",u)) i u="" q + . s value=^element(qsBox,"n",nodeId,"u",u) + . s key=^key(u) + . i $l(value)>100 s value=$e(value,1,100)_".." + . i value'="" k ^nodex(key,value,qsBox,nodeId) + . k ^nodex(key,"*",qsBox,nodeId) + ; + k ^element(qsBox,"n",nodeId) + ; + q + + +xml(indent,nodeId,select) ; Public ; Generate xml for node + ; + n latlon,a,user,uid,uidUser,timestamp,version,changeset + n xml,qsBox + ; + s qsBox=$$qsBox(nodeId) + ; + s xml="" + ; + s indent=indent_" " + ; + s latlon=$g(^element(qsBox,"n",nodeId,"l")) i latlon="" q "" + i $d(^element(qsBox,"n",nodeId,"a")) d + . s a=^element(qsBox,"n",nodeId,"a") + . s version=$p(a,$c(1),1) + . s changeset=$p(a,$c(1),2) + . s timestamp=$p(a,$c(1),3) + . s uid=$p(a,$c(1),4) + . s user=$g(^user(uid,"name")) + e d + . s version=$g(^element(qsBox,"n",nodeId,"t","@version")) + . s changeset=$g(^element(qsBox,"n",nodeId,"t","@changeset")) + . s timestamp=$g(^element(qsBox,"n",nodeId,"t","@timestamp")) + . s uid=$g(^element(qsBox,"n",nodeId,"t","@uid")) + . s user=$g(^element(qsBox,"n",nodeId,"t","@user")) + ; + s xml=xml_indent_""_$c(13,10) + ; + s xml=xml_$$xmlTags(nodeId,indent,qsBox) + s xml=xml_indent_""_$c(13,10) + ; + q xml + + +xmlTags(id,indent,qsBox) ; Private ; Generate xml for node's tags + ; + n k,u,xml + ; + s xml="" + ; + s indent=indent_" " + ; + ; Raw keys + s k="" + f d i k="" q + . s k=$o(^element(qsBox,"n",id,"t",k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzzzzz" q ; Skip attributes + . s xml=xml_indent_""_$c(13,10) + ; + ; Compiled keys + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",id,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + ; + q xml + + +qsBox(nodeId) ; Public ; Get quadString for a node + ; + q $g(^nodeVersion(nodeId,"q")) + + +bbox(nodeId,bllat,bllon,trlat,trlon) ; Public ; Get bbox for a node + ; + n latlon,lat,lon,qsBox + ; + s qsBox=$$qsBox(nodeId) + ; + s latlon=$g(^element(qsBox,"n",nodeId,"l")) + s lat=$p(latlon,$c(1),1) + s lon=$p(latlon,$c(1),2) + ; + s trlat=lat + s bllat=lat + s trlon=lon + s bllon=lon + q + + +xmlEscapeApostrophe(string) ; Private ; Escape apostrophe + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +hasRealTag(id) ; Public ; Does this node have a real tag? + ; + n hasRealTag,tag,qsBox + ; + s qsBox=$$qsBox(id) + ; + i $d(^element(qsBox,"n",id,"u")) q 1 + ; + s hasRealTag=0 + s tag="" + f d i tag="" q + . s tag=$o(^element(qsBox,"n",id,"t",tag)) i tag="" q + . i $e(tag,1)="@" s tag="@zzzzzzzzzzzzzzzz" q + . s hasRealTag=1,tag="" + ; + q hasRealTag + + +versionAtChangeset(nodeId,changeset,nodeChangeset,nodeVersion) ; Public ; Get the changeset and version that was current at a given changeset time + ; + ; Usage: + ; d versionAtChangeset^node(nodeId,changeset,.nodeChangeset,.nodeVersion) i nodeChangeset="" ... + ; Output: + ; nodeChangeset - null if not found + ; nodeVersion - null if not found + ; + s nodeChangeset=changeset + s nodeVersion="" + i '$d(^nodeVersion(nodeId,"c",nodeChangeset)) s nodeChangeset=$o(^nodeVersion(nodeId,"c",nodeChangeset),-1) i nodeChangeset="" q + s nodeVersion=$o(^nodeVersion(nodeId,"c",nodeChangeset,""),-1) i nodeVersion="" s nodeChangeset="" q + ; + q + + +restNode(string) ; Public ; Single node query + ; + n step,nodeId,full,logId,indent + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s nodeId=step + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Four choices here: + ; - current node only + ; ways - all ways that use the node + ; #version - specific version of node + ; #version/ways - all ways that used this version of the node + ; history - all versions of this node + s full=0 + i step="" s full=0 + i step="ways" d restWaysByNode(nodeId) q + i step="history" d restNodeHistory(nodeId) q + i step?1.n d restNode^nodeVersion(nodeId,step,string) q + ; + s logId=$$logStart^xapi("node/"_nodeId,"") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,nodeId,"node|@*|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +restWaysByNode(nodeId) ; Public ; Ways by Node + ; + n indent,logId,wayId,count + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/ways","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + s wayId="" + f d i wayId="" q + . s wayId=$o(^wayByNode(nodeId,wayId)) i wayId="" q + . w $$xml^way(indent,wayId,"way|@*|nd|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodes(step,string) ; Public ; Multi node query + ; + n logId,count,indent + n nodeIds,nodeId,ok,i + ; + s count=0 + s logId=$$logStart^xapi($$decode^xapi(step),"") + ; + s nodeIds=$p(step,EQUALS,2) + ; + ; Validate query + s ok=1 + f i=1:1:$l(nodeIds,",") d i 'ok q + . s nodeId=$p(nodeIds,",",i) + . i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . ; Is it there? + . i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . s qsBox=$$qsBox(nodeId) + . i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + . i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + i 'ok q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + f i=1:1:$l(nodeIds,",") d + . s nodeId=$p(nodeIds,",",i) + . w $$xml(indent,nodeId,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodeHistory(nodeId) ; Public ; All versions of node + ; + n logId,count,indent + n version,changeset + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/history","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Iterate all versions + s version="" + f d i version="" q + . s version=$o(^nodeVersion(nodeId,"v",version)) i version="" q + . s changeset=^nodeVersion(nodeId,"v",version) + . ; + . w $$xml^nodeVersion(indent,nodeId,changeset,version,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +currentVersion(nodeId) ; Public ; Return the current version number of a node + ; + ; Usage: s currentVersion=$$currentVersion^node(nodeId) + ; Input: + ; nodeId - node id, must not be null + ; Output: + ; currentVersion - if the node does not exists then null is returned + ; + q $o(^nodeVersion(nodeId,"v",""),-1) + diff --git a/nodeVersion.m b/nodeVersion.m new file mode 100644 index 0000000..a4e564b --- /dev/null +++ b/nodeVersion.m @@ -0,0 +1,213 @@ +nodeVersion ; Node Version Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +xmlChangeset(indent,nodeId,changeset,select) ; Public ; Generate xml for a node at a given changeset + ; + n nodeChangeset,nodeVersion + ; + d versionAtChangeset^node(nodeId,changeset,.nodeChangeset,.nodeVersion) i nodeChangeset="" q "" + ; + q $$xml(indent,nodeId,nodeChangeset,nodeVersion,select) + + +xml(indent,nodeId,changeset,version,select) ; Public ; Generate xml for a node version + ; + n latlon,a,user,users,uid,timestamp,visible + n xml + ; + s xml="" + ; + s indent=indent_" " + ; + s latlon=$g(^c(changeset,"n",nodeId,"v",version,"l")) i latlon="" q "" + i $d(^c(changeset,"n",nodeId,"v",version,"a")) d + . s a=^c(changeset,"n",nodeId,"v",version,"a") + . ; s version=$p(a,$c(1),1) ; We already have this value + . ; s changeset=$p(a,$c(1),2) ; We already have this + . s timestamp=$p(a,$c(1),3) + . s uid=$p(a,$c(1),4) + . s user="" i uid'="" s user=$g(^user(uid,"name")) + . s visible=$p(a,$c(1),5) i visible="" s visible="true" + e d + . ; s version=$g(^c(changeset,"n",nodeId,"v",version,"t","@version")) ; We already have this value + . ; s changeset=$g(^c(changeset,"n",nodeId,"v",version,"t","@changeset")) ; We already have this value + . s timestamp=$g(^c(changeset,"n",nodeId,"v",version,"t","@timestamp")) + . s uid=$g(^c(changeset,"n",nodeId,"v",version,"t","@uid")) + . s user=$g(^c(changeset,"n",nodeId,"v",version,"t","@user")) + . s visible=$g(^c(changeset,"n",nodeId,"v",version,"t","@visible"),"true") + ; + s xml=xml_indent_""_$c(13,10) + ; + s xml=xml_$$xmlTags(indent,nodeId,changeset,version,select) + s xml=xml_indent_""_$c(13,10) + ; + q xml + + +xmlTags(indent,id,changeset,version,select) ; Public ; Generate xml for node's tags + ; + n k,u,xml + ; + s xml="" + ; + s indent=indent_" " + ; + s k="" + f d i k="" q + . s k=$o(^c(changeset,"n",nodeId,"v",version,"t",k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzz" q + . i $d(^c(changeset,"n",nodeId,"v",version,"t",k))#10=0 q + . s xml=xml_indent_""_$c(13,10) + ; + s u="" + f d i u="" q + . s u=$o(^c(changeset,"n",nodeId,"v",version,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + ; + q xml + + +restNode(nodeId,step,string) ; Public ; Single node query for specific version + ; + n logId,version,changeset,indent + ; + ; Get next step + s version=step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Two choices here: + ; - specific version of node only + ; ways - all ways that use this version of the node + i step="ways" d restWaysByNode(nodeId,version) q + ; + s logId=$$logStart^xapi("node/"_nodeId_"/"_version,"") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + i version'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId,"v",version)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s changeset=^nodeVersion(nodeId,"v",version) + ; + ; Is the history present for this node + i '$d(^c(changeset,"n",nodeId,"v",version)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,nodeId,changeset,version,"node|@*|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +restWaysByNode(nodeId,version) ; Public ; Ways used by a specific version of a node + ; + n logId,count,indent + n changeset,nodeStartChangeset,nodeEndChangeset,wayStartChangeset,wayEndChangeset,wayId + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/"_version_"/ways","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + i version'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId,"v",version)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is the history present for this node + s changeset=^nodeVersion(nodeId,"v",version) + i '$d(^c(changeset,"n",nodeId,"v",version)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Find the start and end of the selected node version + s nodeStartChangeset=^nodeVersion(nodeId,"v",version) + s nodeEndChangeset=$g(^nodeVersion(nodeId,"v",version+1)) + ; + ; Iterate all changesets that happened before the node got replaced + s wayStartChangeset="" + f d i wayStartChangeset="" q + . s wayStartChangeset=$o(^nodeVersion(nodeId,"c",wayStartChangeset)) i wayStartChangeset="" q + . i nodeEndChangeset'="",nodeEndChangesetwayEndChangeset q + . . ; + . . ; So this version of this way (w) was created before this node version (v) got replaced and + . . ; and it (w) did not get replaced until after this node version (v) got replaced. + . . w $$xmlChangeset^wayVersion(indent,wayId,wayStartChangeset,"way|@*|nd|tag|") + . . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +bbox(nodeId,version,bllat,bllon,trlat,trlon) ; Public ; Get bbox for a node version + ; + n changesetId,l,lat,lon + ; + s changesetId=^nodeVersion(nodeId,"v",version) + s l=^c(changesetId,"n",nodeId,"v",version,"l") + s lat=$p(l,$c(1),1) + s lon=$p(l,$c(1),2) + ; + s trlat=lat + s bllat=lat + s trlon=lon + s bllon=lon + q diff --git a/node_old.m b/node_old.m new file mode 100644 index 0000000..1f4a99f --- /dev/null +++ b/node_old.m @@ -0,0 +1,749 @@ +node ; Node Class (new structure using ^element instead of ^node and ^nodetag) + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +add(sNode,delete) ; Public ; Add a node + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,changeset,qsOld + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + s qsOld="" + ; + s currentVersion=0,fork=0 + i $d(^nodeVersion(nodeId)) d + . s qsOld=$$qsBox(nodeId) + . i $d(^element(qsOld,"n",nodeId,"a")) d + . . s fork=$p(^element(qsOld,"n",nodeId,"a"),$c(1),6) + . e d + . . s fork=$d(^element(qsOld,"n",nodeId,"t","@fork")) + ; + i ($$currentVersion(nodeId)>version)!(fork) d q ; Don't load older versions + . ; + . ; Log conflict + . i $d(^element(qsOld,"n",nodeId,"a")) d + . . s uid=$p(^element(qsOld,"n",nodeId,"a"),$c(1),4) + . e d + . . s uid=$g(^element(qsOld,"n",nodeId,"t","@uid")) + . i uid="" q + . ; + . s seq=$g(^conflict(uid))+1 + . s ^conflict(uid)=seq + . s ^conflict(uid,seq,"@type")="node" + . s ^conflict(uid,seq,"@id")=nodeId + . s ^conflict(uid,seq,"@changeset")=changeset + . s ^conflict(uid,seq,"@version")=version + . s ^conflict(uid,seq,"@uid")=$$getAttribute^osmXml(line,"uid") + . s ^conflict(uid,seq,"@timestamp")=$$getAttribute^osmXml(line,"timestamp") + . s ^conflict(uid,seq,"@visible")=$s(delete:"false",1:"true") + . ; + . ; Skip rest of node element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sNode) + ; + ;d delete(nodeId) + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^element(qsOld,"n",nodeId,"l") + . s ^element(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^changeset(changeset)) s ^changeset(changeset)="" + i '$d(^changeset(changeset,"n",nodeId)) s ^changeset(changeset,"n",nodeId)="" + s ^changeset(changeset,"n",nodeId,"v",version)="" + s ^changeset(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + i user["'" s user=$$xmlEscapeApostrophe(user) + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; Update - node attributes + ; i qsOld'="",qsOld'=qsBox k ^element(qsBox,"n",nodeId,"a") + ; s visible="" i delete s visible="false" + ; s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_$c(1) + ; s ^element(qsBox,"n",nodeId,"a")=a + ; s ^changeset(changeset,"n",nodeId,"v",version,"a")=a + ; + d updateTag(qsOld,qsBox,nodeId,"@timestamp",timestamp,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@user",user,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@uid",uid,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@version",version,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@changeset",changeset,changeset,version,delete) + i delete d updateTag(qsOld,qsBox,nodeId,"@visible","false",changeset,version,delete) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Update process elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^element(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^changeset(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^element(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + i delete,qsOld'="" k ^element(qsOld,"n",nodeId) + ; + ; Create quad string indexes on each of the tags in the node + ; i 'delete d indexTags(qsBox,nodeId,version) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + ; Update user class + d add^user(uid,user) + ; + d onEdit^user(uid) + q + + +addDiff(sNode,delete) ; Public ; Add a node from the diff upload API + ; #sNode = stream object containing node + ; + n line,nodeId,users,lat,lon,timestamp,user,uid,version,changeset,qsOld,ok + ; + s line=sNode("current") + ; + s nodeId=$$getAttribute^osmXml(line,"id") + s changeset=$$getAttribute^osmXml(line,"changeset") + s timestamp=$$nowZulu^date() + ; + ; New nodes + i nodeId<0 d + . s oldId=nodeId + . l +^id("node") + . s nodeId=^id("node")+1 + . s ^id("node")=nodeId + . l -^id("node") + . s newId=nodeId + . s version=1 + . s qsOld="" + . ; + . ; Add to new item map + . s ^temp($j,"node",oldId)=newId + ; + ; Existing nodes + s ok=1 + e d i 'ok q 0 + . s version=$$getAttribute^osmXml(line,"version") + . ; check version match + . i $$currentVersion(nodeId)'=version d error409^http("Version mismatch: Provided "_version_", server had: "_$$currentVersion(nodeId)_" of Node "_nodeId) s ok=0 q ; Version mismatch + . s oldId=nodeId + . s newId=nodeId + . s version=version+1 + . s qsOld=$$qsBox(nodeId) + . ; d delete(nodeId) ; delete old version + ; + s lat=$$getAttribute^osmXml(line,"lat") + s lon=$$getAttribute^osmXml(line,"lon") + i lon["e" s lon=+$tr(lon,"e","E") + s qsBox=$$llToQs^quadString(lat,lon) + ; + ; Update - node + i 'delete d + . i qsOld'="",qsOld'=qsBox k ^element(qsOld,"n",nodeId,"l") + . s ^element(qsBox,"n",nodeId,"l")=lat_$c(1)_lon + ; + ; Update - changeset + i '$d(^changeset(changeset)) s ^changeset(changeset)="" + i '$d(^changeset(changeset,"n",nodeId)) s ^changeset(changeset,"n",nodeId)="" + s ^changeset(changeset,"n",nodeId,"v",version)="" + s ^changeset(changeset,"n",nodeId,"v",version,"l")=lat_$c(1)_lon + ; + s uid=$g(^changeset(changeset,"t","@uid")) + s user=^user(uid,"name") + i user["'" s user=$$xmlEscapeApostrophe(user) + ; + ; Update - node attributes + d updateTag(qsOld,qsBox,nodeId,"@timestamp",timestamp,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@user",user,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@uid",uid,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@version",version,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@changeset",changeset,changeset,version,delete) + d updateTag(qsOld,qsBox,nodeId,"@fork",1,changeset,version,delete) + i delete d updateTag(qsOld,qsBox,nodeId,"@visible","false",changeset,version,delete) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsBox + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Process any elements + i line'["/>" f d i line'["100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"t",key) + ; + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^element(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^changeset(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^element(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"t",key) + + i delete,qsOld'="" k ^element(qsOld,"n",nodeId) + ; + ; Create quad string indexes on each of the tags in the node + ; i 'delete d indexTags(qsBox,nodeId,version) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + s rSeq=$g(^response($j))+1 + s ^response($j)=rSeq + ; + i delete s newId="",version="" + ; + s ^response($j,rSeq,"oldId")=oldId + s ^response($j,rSeq,"newId")=newId + s ^response($j,rSeq,"version")=version + s ^response($j,rSeq,"element")="node" + ; + d onEdit^user(uid) + ; + q 1 + + +addTag(sNode,qsBox,nodeId,changeset,version,delete) ; Private ; Load a tag and add it + ; + n line,k,v + ; + s line=sNode("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s k=$$getAttribute^osmXml(line,"k") i k="" q + i $l(k)>100 s k=$e(k,1,100)_".." + s v=$$getAttribute^osmXml(line,"v") + i v["'" s v=$$xmlEscapeApostrophe(v) + i $l(v)>4000 s v=$e(v,1,4000)_".." + ; + i 'delete s ^element(qsBox,"n",nodeId,"t",k)=v + s ^changeset(changeset,"n",nodeId,"v",version,"t",k)=v + ; + q + +sUpdateTag(sNode,qsOld,qsNew,nodeId,changeset,version,delete) ; Private load a tag and add it + ; + n line,key,value + ; + s line=sNode("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sNode) + ; + s key=$$getAttribute^osmXml(line,"k") i key="" q + i $l(key)>100 s key=$e(key,1,100)_".." + s value=$$getAttribute^osmXml(line,"v") + i value["'" s value=$$xmlEscapeApostrophe(value) + i $l(value)>4000 s value=$e(value,1,4000)_".." + ; + d updateTag(qsOld,qsNew,nodeId,key,value,changeset,version,delete) + q + + +indexTags(qsBox,nodeId,version) ; Private ; Create quad string index entries for a single node + ; + n k,u,v + ; + s k="" + f d i k="" q + . s k=$o(^element(qsBox,"n",nodeId,"t",k)) i k="" q + . i k="@xapi:users" q + . i k="@version" q + . i k="@timestamp" q + . i k="@fork" q + . s v=^element(qsBox,"n",nodeId,"t",k) + . i $l(v)>100 s v=$e(v,1,100)_".." + . i v="" q + . s ^nodex(k,v,qsBox,nodeId)="" + . s ^nodex(k,"*",qsBox,nodeId)="" + ; + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",nodeId,"u",u)) i u="" q + . s v=^element(qsBox,"n",nodeId,"u",u) + . s k=^key(u) + . i $l(v)>100 s v=$e(v,1,100)_".." + . i v="" q + . s ^nodex(k,v,qsBox,nodeId)="" + . s ^nodex(k,"*",qsBox,nodeId)="" + ; + ; TODO: Index @changeset, @uid, @user pieces from "a" + q + + +setTag(qsBox,nodeId,k,v,changeset,version,delete) ; Private ; Add a tag + ; + i k="" q + i 'delete s ^element(qsBox,"n",nodeId,"t",k)=v + s ^changeset(changeset,"n",nodeId,"v",version,"t",k)=v + ; + q + + +updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) ; Private ; Update (add/modify/delete) a key/value pair for a node + ; + ; Usage: + ; d updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) + ; qsOld - qs of the old node. Null if this is a new node with no previous version + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; delete - 1 if the whole node is being deleted, 0 if this is an update + ; + n oldValue,intNewValue,intOldValue + ; + s oldValue="" + i qsOld'="" d + . i $e(key,1)="@",$d(^element(qsOld,"n",nodeId,"a")) d + . . s a=^element(qsOld,"n",nodeId,"a") + . . i key="@version" s oldValue=$p(a,$c(1),1) q + . . i key="@changeset" s oldValue=$p(a,$c(1),2) q + . . i key="@timestamp" s oldValue=$p(a,$c(1),3) q + . . i key="@uid" s oldValue=$p(a,$c(1),4) q + . . i key="@visible" s oldValue=$p(a,$c(1),5) q + . . i key="@fork" s oldValue=$p(a,$c(1),6) q + . . i key="@user" s oldValue=$g(^user($p(a,$c(1),4),"name")) q + . e d + . . s oldValue=$g(^element(qsOld,"n",nodeId,"t",key)) + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + s intOldValue=oldValue + i $l(oldValue)>100 s intOldValue=$e(oldValue,1,100)_".." + ; + ; Always add the tag to the node definition in the changeset + s ^changeset(newChangeset,"n",nodeId,"v",newVersion,"t",key)=newValue + ; + ; Delete the tag and it's indexes if the node is being deleted + i delete d + . ; k ^element(qsOld,"n",nodeId,"t",key) ; Don't actually need to do this becaue the whole node will be deleted anyway + . i intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + ; Add/Update the tag for the element + e d + . i (oldValue'=newValue)!(qsOld'=qsNew) d + . . i qsOld'="",qsOld'=qsNew k ^element(qsOld,"n",nodeId,"t",key) + . . i qsNew'="" s ^element(qsNew,"n",nodeId,"t",key)=newValue + . ; + . ; Update the two key/value indexes + . i (intOldValue'=intNewValue)!(qsOld'=qsNew) d + . . i key="@version" q + . . i key="@timestamp" q + . . i key="@fork" q + . . i qsOld'="",intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . . i qsNew'="",intNewValue'="" s ^nodex(key,intNewValue,qsNew,nodeId)="" + . . i qsOld'="" k ^nodex(key,"*",qsOld,nodeId) + . . i qsNew'="" s ^nodex(key,"*",qsNew,nodeId)="" + ; + q + + +delete(nodeId) ; Public ; Delete a node + ; + n key,u,value,qsBox + ; + s qsBox=$$qsBox(nodeId) i qsBox="" q + ; + s key="" + f d i key="" q + . s key=$o(^element(qsBox,"n",nodeId,"t",key)) i key="" q + . s value=^element(qsBox,"n",nodeId,"t",key) + . i $l(value)>100 s value=$e(value,1,100)_".." + . i value'="" k ^nodex(key,value,qsBox,nodeId) + . k ^nodex(key,"*",qsBox,nodeId) + ; + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",nodeId,"u",u)) i u="" q + . s value=^element(qsBox,"n",nodeId,"u",u) + . s key=^key(u) + . i $l(value)>100 s value=$e(value,1,100)_".." + . i value'="" k ^nodex(key,value,qsBox,nodeId) + . k ^nodex(key,"*",qsBox,nodeId) + ; + k ^element(qsBox,"n",nodeId) + ; + q + + +xml(indent,nodeId,select) ; Public ; Generate xml for node + ; + n latlon,a,user,uid,uidUser,timestamp,version,changeset + n xml,qsBox + ; + s qsBox=$$qsBox(nodeId) + ; + s xml="" + ; + s indent=indent_" " + ; + s latlon=$g(^element(qsBox,"n",nodeId,"l")) i latlon="" q "" + i $d(^element(qsBox,"n",nodeId,"a")) d + . s a=^element(qsBox,"n",nodeId,"a") + . s version=$p(a,$c(1),1) + . s changeset=$p(a,$c(1),2) + . s timestamp=$p(a,$c(1),3) + . s uid=$p(a,$c(1),4) + . s user=$g(^user(uid,"name")) + e d + . s version=$g(^element(qsBox,"n",nodeId,"t","@version")) + . s changeset=$g(^element(qsBox,"n",nodeId,"t","@changeset")) + . s timestamp=$g(^element(qsBox,"n",nodeId,"t","@timestamp")) + . s uid=$g(^element(qsBox,"n",nodeId,"t","@uid")) + . s user=$g(^element(qsBox,"n",nodeId,"t","@user")) + ; + s xml=xml_indent_""_$c(13,10) + ; + s xml=xml_$$xmlTags(nodeId,indent,qsBox) + s xml=xml_indent_""_$c(13,10) + ; + q xml + + +xmlTags(id,indent,qsBox) ; Private ; Generate xml for node's tags + ; + n k,u,xml + ; + s xml="" + ; + s indent=indent_" " + ; + ; Raw keys + s k="" + f d i k="" q + . s k=$o(^element(qsBox,"n",id,"t",k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzzzzz" q ; Skip attributes + . s xml=xml_indent_""_$c(13,10) + ; + ; Compiled keys + s u="" + f d i u="" q + . s u=$o(^element(qsBox,"n",id,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + ; + q xml + + +qsBox(nodeId) ; Public ; Get quadString for a node + ; + q $g(^nodeVersion(nodeId,"q")) + + +bbox(nodeId,bllat,bllon,trlat,trlon) ; Public ; Get bbox for a node + ; + n latlon,lat,lon,qsBox + ; + s qsBox=$$qsBox(nodeId) + ; + s latlon=$g(^element(qsBox,"n",nodeId,"l")) + s lat=$p(latlon,$c(1),1) + s lon=$p(latlon,$c(1),2) + ; + s trlat=lat + s bllat=lat + s trlon=lon + s bllon=lon + q + + +xmlEscapeApostrophe(string) ; Private ; Escape apostrophe + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +hasRealTag(id) ; Public ; Does this node have a real tag? + ; + n hasRealTag,tag,qsBox + ; + s qsBox=$$qsBox(id) + ; + s hasRealTag=0 + s tag="" + f d i tag="" q + . s tag=$o(^element(qsBox,"n",id,"t",tag)) i tag="" q + . i $e(tag,1)="@" s tag="@zzzzzzzzzzzzzzzz" q + . s hasRealTag=1,tag="" + ; + i $d(^element(qsBox,"n",id,"u")) s hasRealTag=1 + ; + q hasRealTag + + +versionAtChangeset(nodeId,changeset,nodeChangeset,nodeVersion) ; Public ; Get the changeset and version that was current at a given changeset time + ; + ; Usage: + ; d versionAtChangeset^node(nodeId,changeset,.nodeChangeset,.nodeVersion) i nodeChangeset="" ... + ; Output: + ; nodeChangeset - null if not found + ; nodeVersion - null if not found + ; + s nodeChangeset=changeset + s nodeVersion="" + i '$d(^nodeVersion(nodeId,"c",nodeChangeset)) s nodeChangeset=$o(^nodeVersion(nodeId,"c",nodeChangeset),-1) i nodeChangeset="" q + s nodeVersion=$o(^nodeVersion(nodeId,"c",nodeChangeset,""),-1) i nodeVersion="" s nodeChangeset="" q + ; + q + + +restNode(string) ; Public ; Single node query + ; + n step,nodeId,full,logId,indent + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s nodeId=step + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Four choices here: + ; - current node only + ; ways - all ways that use the node + ; #version - specific version of node + ; #version/ways - all ways that used this version of the node + ; history - all versions of this node + s full=0 + i step="" s full=0 + i step="ways" d restWaysByNode(nodeId) q + i step="history" d restNodeHistory(nodeId) q + i step?1.n d restNode^nodeVersion(nodeId,step,string) q + ; + s logId=$$logStart^xapi("node/"_nodeId,"") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + w $$xml(indent,nodeId,"node|@*|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +restWaysByNode(nodeId) ; Public ; Ways by Node + ; + n indent,logId,wayId,count + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/ways","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + s qsBox=$$qsBox(nodeId) + i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + s wayId="" + f d i wayId="" q + . s wayId=$o(^wayByNode(nodeId,wayId)) i wayId="" q + . w $$xml^way(indent,wayId,"way|@*|nd|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodes(step,string) ; Public ; Multi node query + ; + n logId,count,indent + n nodeIds,nodeId,ok,i + ; + s count=0 + s logId=$$logStart^xapi($$decode^xapi(step),"") + ; + s nodeIds=$p(step,EQUALS,2) + ; + ; Validate query + s ok=1 + f i=1:1:$l(nodeIds,",") d i 'ok q + . s nodeId=$p(nodeIds,",",i) + . i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . ; Is it there? + . i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . s qsBox=$$qsBox(nodeId) + . i $p($g(^element(qsBox,"n",nodeId,"a")),$c(1),5)="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + . i $g(^element(qsBox,"n",nodeId,"t","@visible"))="false" d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + i 'ok q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + f i=1:1:$l(nodeIds,",") d + . s nodeId=$p(nodeIds,",",i) + . w $$xml(indent,nodeId,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restNodeHistory(nodeId) ; Public ; All versions of node + ; + n logId,count,indent + n version,changeset + ; + s count=0 + s logId=$$logStart^xapi("node/"_nodeId_"/history","") + ; + ; Bad query? + i nodeId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^nodeVersion(nodeId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Iterate all versions + s version="" + f d i version="" q + . s version=$o(^nodeVersion(nodeId,"v",version)) i version="" q + . s changeset=^nodeVersion(nodeId,"v",version) + . ; + . w $$xml^nodeVersion(indent,nodeId,changeset,version,"node|@*|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +currentVersion(nodeId) ; Public ; Return the current version number of a node + ; + ; Usage: s currentVersion=$$currentVersion^node(nodeId) + ; Input: + ; nodeId - node id, must not be null + ; Output: + ; currentVersion - if the node does not exists then null is returned + ; + q $o(^nodeVersion(nodeId,"v",""),-1) + diff --git a/oauth.m b/oauth.m new file mode 100644 index 0000000..c2773e3 --- /dev/null +++ b/oauth.m @@ -0,0 +1,217 @@ +oauth ; oauth methods + ; + + + ; authenticated() ; Public ; Authenticate the user using the provided oauth credentials + ; + ; Sets %ENV("REMOTE_USER") if a valid oauth_token was provided. Leaves it undefined if + ; no token was provided. + ; + n query,accessToken + ; + d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2,$l(%ENV("REQUEST_URI")))) + ; + s accessToken=$g(query("oauth_token")) + i accessToken="" q 0 + i '$d(^oauth("access",accessToken)) d error^http q + s uid=^oauth("access",accessToken,"uid") + s name=^user(uid,"name") + ; + s %ENV("REMOTE_USER")=name + q 1 + + +requestToken ; Public ; Provide a request token to anyone who asks for it + ; + n query,authorization,version,nonce,signatureMethod,consumerKey,token,timestamp,signature + n tokenSecret + ; + ; Inspect the authorization header first + s authorization=$g(%ENV("REDIRECT_HTTP_AUTHORIZATION")) + i $p(authorization," ",1)="OAuth" d + . s version=$p($p(authorization,"oauth_version=""",2),"""",1) + . s nonce=$p($p(authorization,"oauth_nonce=""",2),"""",1) + . s signatureMethod=$p($p(authorization,"oauth_signature_method=""",2),"""",1) + . s consumerKey=$p($p(authorization,"oauth_consumer_key=""",2),"""",1) + . s token=$p($p(authorization,"oauth_token=""",2),"""",1) + . s timestamp=$p($p(authorization,"oauth_timestamp=""",2),"""",1) + . s signature=$p($p(authorization,"oauth_signature=""",2),"""",1) + ; + ; Otherwise it may be in the query string + i authorization="" d + . d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2,$l(%ENV("REQUEST_URI")))) + . s version=$g(query("oauth_version")) + . s nonce=$g(query("oauth_nonce")) + . s signatureMethod=$g(query("oauth_signature_method")) + . s consumerKey=$g(query("oauth_consumer_key")) + . s token=$g(query("oauth_token")) + . s timestamp=$g(query("oauth_timestamp")) + . s signature=$g(query("oauth_signature")) + ; + ; Validate that the consumer key is known to us + i consumerKey="" d error401 q + i '$d(^oauth("consumer",consumerKey)) d error401 q + ; + s token=$$token(16) + s tokenSecret=$$token(16) + s ^oauth("request",token,"consumerKey")=consumerKey + s ^oauth("request",token,"tokenSecret")=tokenSecret + s ^oauth("request",token,"createdAt")=$$nowZulu^date() + ; + d header^http("text/plain") + w "oauth_token="_token_"&oauth_token_secret="_tokenSecret,$c(13,10) + q + + +error401 ; Send http 401 response + w "Status: 401 Authorization Required",! + w "WWW-Authenticate: Basic realm=""FOSM""",! + w "Content-Type: text/html",! + w ! + w "",! + w "",! + w "",! + w "Error",! + w "",! + w "",! + w "

401 Unauthorized.

",! + w "",! + q + + + +authorize ; Public ; Ask the user to log in and authorize the request token + ; + n query + ; + d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2,$l(%ENV("REQUEST_URI")))) + ; + ; Check that the request token is one that was issued by us + s token=$g(query("oauth_token")) + i $l(token)'=16 d error^http q ; Check for null or overlong tokens (typical of hacking attacks) + ; + i '$d(^oauth("request",token)) d error^http q ; Not a token that we recognize + ; + ; TODO: is the user already authenticated? + i $d(^session(%session,"authenticated")) + ; + ; Set up a redirect + s ^session(%session,"redirect")="authenticated^oauth("""_token_""")" + ; + ; Get registered consumer details + s consumerKey=^oauth("request",token,"consumerKey") + s consumerName=^oauth("consumer",consumerKey,"name") + ; + ; Ask the user to authenticate + d header^http("text/xml") + d prolog^osmXml("/login.xsl") + w "
",! + w "",! + w "You have made a request to allow "_consumerName_" to have access to your account so that",! + w "it can read your user setting and edit content using your credentials.",! + w "It is possible for malicious applications to masquerade as "_consumerName_" and",! + w "trick you into authenticating at this site.",! + w "If you initiated this request from a web-site or application that you do not trust",! + w "then we recommend that you do not proceed.",! + w "",! + w "",! + ; + q + + +authenticated(token) ; Public ; Authorize the request token for the logged in user + ; + ; TODO: need to add roles to authentication else the consumer could do everything + ;i '$$authenticated^user(.uid,.name) d error^http q + s uid=$g(^session(%session,"uid")) + i uid="" d error^http q + s name=^user(uid,"name") + ; + s ^oauth("request",token,"uid")=uid + s consumerKey=^oauth("request",token,"consumerKey") + s consumerName=^oauth("consumer",consumerKey,"name") + ; + d header^http("text/html") + w "",! + w "",! + w "FOSM :: Access to "_consumerName_"confirmed",! + w "",! + w "",! + w "

You have granted access to "_consumerName_" to access your account at www.fosm.org

",! + w "

Now return to "_consumerName_" to continue with the authentication process

",! + q + + +accessToken ; Public ; Provide an access token if the user has authorized the request token + ; + n query,authorization,version,nonce,signatureMethod,consumerKey,requestToken,timestamp,signature + n accessToken,accessTokenSecret,uid + ; + ; Inspect the authorization header first + s authorization=$g(%ENV("REDIRECT_HTTP_AUTHORIZATION")) + i $p(authorization," ",1)="OAuth" d + . s version=$p($p(authorization,"oauth_version=""",2),"""",1) + . s nonce=$p($p(authorization,"oauth_nonce=""",2),"""",1) + . s signatureMethod=$p($p(authorization,"oauth_signature_method=""",2),"""",1) + . s consumerKey=$p($p(authorization,"oauth_consumer_key=""",2),"""",1) + . s requestToken=$p($p(authorization,"oauth_token=""",2),"""",1) + . s timestamp=$p($p(authorization,"oauth_timestamp=""",2),"""",1) + . s signature=$p($p(authorization,"oauth_signature=""",2),"""",1) + ; + ; Otherwise it may be in the query string + i authorization="" d + . d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2,$l(%ENV("REQUEST_URI")))) + . s version=$g(query("oauth_version")) + . s nonce=$g(query("oauth_nonce")) + . s signatureMethod=$g(query("oauth_signature_method")) + . s consumerKey=$g(query("oauth_consumer_key")) + . s requestToken=$g(query("oauth_token")) + . s timestamp=$g(query("oauth_timestamp")) + . s signature=$g(query("oauth_signature")) + ; + ; Validate that the consumer key is known to us + i consumerKey="" d error401 q + i '$d(^oauth("consumer",consumerKey)) d error401 q + ; + ; Check that the request token is one that was issued by us + i $l(requestToken)'=16 d error^http q ; Check for null or overlong tokens (typical of hacking attacks) + ; + i '$d(^oauth("request",requestToken)) d error401 q ; Not a token that we recognize + ; + ; Has it been authorized yet? + s uid=$g(^oauth("request",requestToken,"uid")) i uid="" d error401 q + ; + ; Generate an access token and another secret + s accessToken=$$token(22) + s accessTokenSecret=$$token(41) + s ^oauth("access",accessToken)="" + s ^oauth("access",accessToken,"consumerKey")=consumerKey + s ^oauth("access",accessToken,"nonce")=nonce + s ^oauth("access",accessToken,"signature")=signature + s ^oauth("access",accessToken,"signatureMethod")=signatureMethod + s ^oauth("access",accessToken,"timestamp")=timestamp + s ^oauth("access",accessToken,"requestToken")=requestToken + s ^oauth("access",accessToken,"accessTokenSecret")=accessTokenSecret + s ^oauth("access",accessToken,"uid")=uid + s ^oauth("access",accessToken,"createdAt")=$$nowZulu^date() + ; + w "Status: 200 OK",! + w "Set-Cookie: _osm_session=b15b254a2db61f53c0792d17d2eab208; path=/; HttpOnly",! + w "Content-Type: text/html",! + w "Content-Length: 95",! + w ! + w "oauth_token="_accessToken_"&oauth_token_secret="_accessTokenSecret + q + + +token(length) ; Generate random token + ; + n token,i + ; + s token="" + f i=1:1:length s token=token_$e("abcdefghijklmnopqrstuvwxyz0123456789",$r(35)+1) + q token + + diff --git a/openssl.m b/openssl.m new file mode 100644 index 0000000..0ac2c2f --- /dev/null +++ b/openssl.m @@ -0,0 +1,76 @@ +openssl ; openssl wrapper class + + +dgst(string,type) ; Public ; Generate a message digest + ; Usage: + ; s digest=$$dgst^openssl(string,type) + ; Inputs: + ; string = plain text input + ; type = message digest type (sha, sha1, sha512, etc) + ; Outputs: + ; $$dgst = digest of plain text input + ; + n i,f,g,x + ; + i $g(type)="" s type="sha1" + ; + s io=$i + s f="/tmp/openssl.digest.input."_$j_".tmp" + s g="/tmp/openssl.digest.output."_$j_".tmp" + ; + o f:NEW + u f w string + c f + ; + zsystem "/usr/bin/openssl dgst -"_type_" <"_f_" >"_g + o f + c f:DELETE + ; + o g:READ + u g r x + c g:DELETE + ; + u io + ; + q x + + + +enc(string,cipher,password,mode) ; Public + ; Usage: + ; s output=$$enc^openssl(string,cipher,password,mode) + ; Inputs: + ; string = plain text input + ; cipher = encryption cipher (bf, des, aes256, etc) + ; password = password for encryption + ; mode = e - encrypt, d - decrypt + ; Outputs: + ; $$enc = encrypted or decrypted string + ; Notes: + ; All encrypted strings are base64 encoded + ; + n i,f,g,x + ; + i string="" q "" ; Don't try to decrypt nothing + ; + i $g(cipher)="" s type="bf" + ; + s io=$i + s f="/tmp/openssl.cipher.input."_$j_".tmp" + s g="/tmp/openssl.cipher.output."_$j_".tmp" + ; + o f:NEW + u f w string + c f + ; + zsystem "/usr/bin/openssl enc -"_cipher_" -"_mode_" -a -A -salt -pass pass:"_password_" -in "_f_" -out "_g + o f + c f:DELETE + ; + o g:READ + u g r x + c g:DELETE + ; + u io + ; + q x diff --git a/osmXml.m b/osmXml.m new file mode 100644 index 0000000..e8143fc --- /dev/null +++ b/osmXml.m @@ -0,0 +1,149 @@ +osmXml ; XML Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + + +prolog(xslTemplate) ; Public ; Write xml Prolog and xsl stylesheet elements + ; + w "",! + i xslTemplate'="" w "",! + ; + q + + +allAttributes(object,indent,select) ; Public ; Get all attributes for an object + ; Usage: + ; d xmlAttributes^%vcXml(.oObject,indent,select) + ; Inputs: + ; oObject - reference to (ie the $name of) an object (either in memory or on disk) + ; indent - string of spaces to indent output by + ; select - XPath style selection string eg "element|element|@attributes" + ; Outputs: + ; STDOUT - list of attributes value pairs + ; + n attribute + ; + s attribute="" + f d i attribute="" q + . s attribute=$o(@object@(attribute)) i attribute="" q + . i $d(@object@(attribute))#10=1 w $$attribute(attribute,@object@(attribute),indent,select) + . i indent'="" w ! + q + +genAttributes(object,indent,select) ; Public ; Generate all attributes for an object as a string + ; Usage: + ; d xmlAttributes^%vcXml(.oObject,indent,select) + ; Inputs: + ; oObject - reference to (ie the $name of) an object (either in memory or on disk) + ; indent - string of spaces to indent output by + ; select - XPath style selection string eg "element|element|@attributes" + ; Outputs: + ; STDOUT - list of attributes value pairs + ; + n attribute,xml + s xml="" + ; + s attribute="" + f d i attribute="" q + . s attribute=$o(@object@(attribute)) i attribute="" q + . i $d(@object@(attribute))#10=1 s xml=xml_$$attribute(attribute,@object@(attribute),indent,select) + . i indent'="" s xml=xml_$c(13,10) + q xml + + +attribute(name,value,indent,select,bAddCrlf) ; Public ; Create xml attribute + ; Usage: + ; w $$attribute(name,value,[indent],[select],[bAddCrlf]),crlf + ; Inputs: + ; name - attribute name + ; value - attribute value (unescaped data) + ; indent - string of spaces to indent output by (defaults to one space) + ; select - XPath style selection string eg "@attribute|@attribute|..." + ; bAddCrlf - If passed and true, append the crlf terminator to the output + ; Outputs: + ; $$attribute - attribute value pair with escaped data + ; + i '$$selAttribute($g(select),"@"_name) q "" + q $g(indent)_" "_name_"='"_$$toXml(value)_"'"_$s($g(bAddCrlf):crlf,1:"") + + +selAttribute(select,attribute) ; Public ; Is attribute in selection filter + ; + i select="" q 1 ; No filter + i ("|"_select_"|")["|@*|" q 1 + i ("|"_select_"|")[("|"_attribute_"|") q 1 + q 0 + + +utf8(string) ; Private ; Convert an ASCII string to UTF-8 + ; + q string + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . s out=out_$$utf8c(c) + q out + + +utf8c(c) ; Private ; Convert an ASCII character to UTF-8 + ; + n a + ; + s a=$a(c) + i a<128 q c + i a<2048 q $c(192+(a\64),128+(a#64)) + i a<65536 q $c(224+(a\4096),128+((a\64)#64),128+(a#64)) + i a<2097152 q $c(240+(a\262144),128+((a\4096)#64),128+((a\64)#64),128+(a#64)) + i a<67108863 q $c(248+(a\16777216),128+((a\262144)#64),128+((a\4096)#64),128+((a\64)#64),128+(a#64)) + q $c(252+(a\1073741824),128+((a\16777216)#64),128+((a\262144)#64),128+((a\4096)#64),128+((a\64)#64),128+(a#64)) + + +toXml(string) ; Public ; Escape a string as an xml attribute value + ; Usage: + ; s xmlString=$$toXml(string) + ; Inputs: + ; string = string to be escaped + ; Outputs: + ; $$toXml = escaped string + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "<>""&'"_$c(13,10)[c s out=out_"&#"_$a(c)_";" q + . s out=out_c + q out + + +select(select,element) ; Public ; Is element in selection filter + ; + i ("|"_select_"|")[("|"_element_"|") q 1 + q 0 + + +getAttribute(line,attribute) ; Public ; Parse out the value of an attribute from a line of xml + ; + n start,q + ; + s start=$f(line,attribute_"=") + i 'start q "" + ; + s q=$e(line,start) + q $p($e(line,start+1,$l(line)),q,1) diff --git a/planetDump.m b/planetDump.m new file mode 100644 index 0000000..5f59c7d --- /dev/null +++ b/planetDump.m @@ -0,0 +1,137 @@ +planetDump ; Dump the planet + ; Copyright (C) 2010 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + ; Public ; Run planet dump + ; Dump all nodes, ways and relations. + ; + ; + l +^planetDump("running"):0 e q + d main + l -^planetDump("running") + q + + + +main ; + n iDateTile,file + ; + s iDateTime=$$toNumber^date($$nowZulu^date()) + s file=$$createPlanetFile(iDateTime) + q + +createPlanetFile(iDateTime) ; + ; + ; iDateTime = ccyymmddhhmmss + ; + n directory,tempFile,zipFile,pipe + ; + s directory=$g(^planetDump("directory")) + s pipe=directory_"earth.pipe" + s tempFile=directory_"earth-"_iDateTime_".temp" + s zipFile=directory_"earth-"_iDateTime_".osm.bz2" + zsystem "rm "_pipe_"; mkfifo "_pipe_"; bzip2 -9 <"_pipe_" >"_tempFile_" &" + ; + o pipe:(nowrap:stream:fifo) + ; + ; Let's do it + u pipe + d xmlProlog^rest("") + d dump() + ; + c pipe + ; + zsystem "mv "_tempFile_" "_zipFile + ; + q "" + + + +dump() ; Emit everything + ; + ; + w "",$c(13,10) + ; + d nodes + d ways + d relations + ; + w "",$c(13,10) + q + + +nodes ; + n q,n,count + ; + k ^planetDump("nodeCount") + k ^planetDump("nodeCheckpoint") + ; + s count=0 + s q="" + f d i q="" q + . s q=$o(^e(q)) i q="" q + . s n="" + . f d i n="" q + . . s n=$o(^e(q,"n",n)) i n="" q + . . w $$xml^node("",n,"",q) + . . s count=count+1 + . . i count#10000=0 d + . . . s ^planetDump("nodeCount")=count + . . . s ^planetDump("nodeCheckpoint")=q_"|"_n + ; + q + + +ways ; + n w,count + ; + k ^planetDump("wayCount") + k ^planetDump("wayCheckpoint") + ; + s count=0 + s w="" + f d i w="" q + . s w=$o(^way(w)) i w="" q + . w $$xml^way("",w,"way|nd|tag|@*") + . s count=count+1 + . i count#10000=0 d + . . s ^planetDump("wayCount")=count + . . s ^planetDump("wayCheckpoint")=w + ; + q + + +relations ; + ; + n r,count + ; + k ^planetDump("relationCount") + k ^planetDump("relationCheckpoint") + ; + s count=0 + s r="" + f d i r="" q + . s r=$o(^relation(r)) i r="" q + . w $$xml^relation("",r,"relation|member|tag|@*") + . s count=count+1 + . i count#10000=0 d + . . s ^planetDump("relationCount")=count + . . s ^planetDump("relationCheckpoint")=r + ; + q diff --git a/profile b/profile new file mode 100755 index 0000000..9880824 --- /dev/null +++ b/profile @@ -0,0 +1,13 @@ +zappy='/pine02' ; export zappy +gtm_dist="$zappy/gtm"; export gtm_dist +gtmx="$zappy/gtmx"; export gtmx +gtmgbldir="$zappy/data/xapi_small.gld"; export gtmgbldir +gtmroutines="$zappy/scripts/o($zappy/scripts $zappy/serenji $gtmx $gtm_dist)"; export gtmroutines +gtm="$gtmx/gtmrun ^direct gtm"; export gtm +gtmrun="$gtmx/gtmrun" ; export gtmrun +mupip="$gtm_dist/mupip"; export mupip +lke="$gtm_dist/lke"; export lke +gde="$gtmx/gtmrun ^GDE"; export gde +dse="$gtm_dist/dse"; export dse +PATH=$PATH:$zappy/scripts:$zappy/gtmx:$zappy/gtm +gtm_repl_instance="fosm01";export gtm_repl_instance diff --git a/profile_logStats1 b/profile_logStats1 new file mode 100755 index 0000000..91488cb --- /dev/null +++ b/profile_logStats1 @@ -0,0 +1,29 @@ +################################################################# +# # +# Copyright 2001, 2006 Fidelity Information Services, Inc # +# # +# This source code contains the intellectual property # +# of its copyright holder(s), and is made available # +# under a license. If you do not know the terms of # +# the license, please stop and do not read further. # +# # +################################################################# +zappy='/home/etienne' ; export zappy +gtm_dist="$zappy/gtm"; export gtm_dist +gtmx="$zappy/gtmx"; export gtmx +gtmgbldir="logStats1.gld"; export gtmgbldir +if [ "$gtm_chset" = "UTF-8" ] ; then + if [ -e $gtm_dist/utf8 ] ; then + gtm_dist="$gtm_dist/utf8"; export gtm_dist + fi +fi +gtmroutines="$zappy/scripts06/o($zappy/scripts06 $zappy/serenji $gtmx $gtm_dist)"; export gtmroutines +gtm="$gtmx/gtmrun ^direct gtm"; export gtm +gtmrun="$gtmx/gtmrun" ; export gtmrun +mupip="$gtm_dist/mupip"; export mupip +lke="$gtm_dist/lke"; export lke +gde="$gtmx/gtmrun ^GDE"; export gde +dse="$gtm_dist/dse"; export dse +PATH=$PATH:$gtm_dist +gtm_repl_instname="logStats1";export gtm_repl_instname +gtm_repl_instance="deadEnd"; export gtm_repl_instance diff --git a/profile_master b/profile_master new file mode 100755 index 0000000..eb91b9f --- /dev/null +++ b/profile_master @@ -0,0 +1,28 @@ +################################################################# +# # +# Copyright 2001, 2006 Fidelity Information Services, Inc # +# # +# This source code contains the intellectual property # +# of its copyright holder(s), and is made available # +# under a license. If you do not know the terms of # +# the license, please stop and do not read further. # +# # +################################################################# +zappy='/home/etienne' ; export zappy +gtm_dist="$zappy/gtm"; export gtm_dist +gtmx="$zappy/gtmx"; export gtmx +gtmgbldir="master.gld"; export gtmgbldir +if [ "$gtm_chset" = "UTF-8" ] ; then + if [ -e $gtm_dist/utf8 ] ; then + gtm_dist="$gtm_dist/utf8"; export gtm_dist + fi +fi +gtmroutines="$zappy/scripts06/o($zappy/scripts06 $zappy/serenji $gtmx $gtm_dist)"; export gtmroutines +gtm="$gtmx/gtmrun ^direct gtm"; export gtm +gtmrun="$gtmx/gtmrun" ; export gtmrun +mupip="$gtm_dist/mupip"; export mupip +lke="$gtm_dist/lke"; export lke +gde="$gtmx/gtmrun ^GDE"; export gde +dse="$gtm_dist/dse"; export dse +PATH=$PATH:$gtm_dist +gtm_repl_instance="master";export gtm_repl_instance diff --git a/profile_source b/profile_source new file mode 100755 index 0000000..658c17c --- /dev/null +++ b/profile_source @@ -0,0 +1,13 @@ +zappy='/home/etienne' ; export zappy +gtm_dist="$zappy/gtm"; export gtm_dist +gtmx="$zappy/gtmx"; export gtmx +gtmgbldir="source.gld"; export gtmgbldir +gtmroutines="$zappy/scripts06/o($zappy/scripts06 $zappy/serenji $gtmx $gtm_dist)"; export gtmroutines +gtm="$gtmx/gtmrun ^direct gtm"; export gtm +gtmrun="$gtmx/gtmrun" ; export gtmrun +mupip="$gtm_dist/mupip"; export mupip +lke="$gtm_dist/lke"; export lke +gde="$gtmx/gtmrun ^GDE"; export gde +dse="$gtm_dist/dse"; export dse +PATH=$PATH:$gtm_dist +gtm_repl_instance="source.repl";export gtm_repl_instance diff --git a/purgeJournal b/purgeJournal new file mode 100755 index 0000000..455cdc4 --- /dev/null +++ b/purgeJournal @@ -0,0 +1,4 @@ +. /xapi/scripts/profile +cd /xapi/data +$gtmrun ^purgeJournal purgeJournal + diff --git a/purgeJournal.m b/purgeJournal.m new file mode 100644 index 0000000..848b3de --- /dev/null +++ b/purgeJournal.m @@ -0,0 +1,27 @@ +purgeJournal ; Purge Journal files + ; Purge all files except the last one for each database + + n f,file,list,database,lastDatabase,lastFile + ; + s f="/tmp/purgeJournal_"_$j_".tmp" + zsystem "ls -b1 ../journal/*.mjl_* > "_f + ; + o f + f d i $zeof q + . u f r file i $zeof q + . i file'="" s list(file)="" + ; + c f:DELETE + ; + s lastDatabase="" + s lastFile="" + s file="" + f d i file="" q + . s file=$o(list(file)) + . s database=$p(file,".mjl",1) + . i database=lastDatabase zsystem "rm "_lastFile + . ; + . i file="" q + . s lastDatabase=database + . s lastFile=file + q diff --git a/quadString.m b/quadString.m new file mode 100644 index 0000000..95bb8f5 --- /dev/null +++ b/quadString.m @@ -0,0 +1,148 @@ +quadString ; QuadString Library + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + +llToQs(lat,lon) ; Public ; Convert lat/lon to quadString + ; + n qsTile,latIncrement,lonIncrement,zoom + ; + s qsTile="" + s latIncrement=90 + s lonIncrement=180 + ; + f zoom=1:1:15 d + . s latIncrement=latIncrement/2 + . s lonIncrement=lonIncrement/2 + . i lat<0,lon<0 s lat=lat+latIncrement,lon=lon+lonIncrement,qsTile=qsTile_"c" q + . i lat<0 s lat=lat+latIncrement,lon=lon-lonIncrement,qsTile=qsTile_"d" q + . i lon<0 s lat=lat-latIncrement,lon=lon+lonIncrement,qsTile=qsTile_"a" q + . s lat=lat-latIncrement,lon=lon-lonIncrement,qsTile=qsTile_"b" q + ; + q qsTile + + +qsToLl(qsItem) ; Public ; Convert quadString to lat/lon + ; + n lat,lon + ; + s lat=0,lon=0 + ; + d qsToLl1(qsItem,.lat,.lon,90,180) + ; + q lat_","_lon + + +qsToLl1(qsItem,lat,lon,latIncrement,lonIncrement) ; + ; + n tile + ; + s tile=$e(qsItem,1) i tile="" q + ; + s latIncrement=latIncrement/2 + s lonIncrement=lonIncrement/2 + ; + i tile="a" s lat=lat+latIncrement,lon=lon-lonIncrement + i tile="b" s lat=lat+latIncrement,lon=lon+lonIncrement + i tile="c" s lat=lat-latIncrement,lon=lon-lonIncrement + i tile="d" s lat=lat-latIncrement,lon=lon+lonIncrement + ; + d qsToLl1($e(qsItem,2,$l(qsItem)),.lat,.lon,latIncrement,lonIncrement) + ; + q + + +qsToBbox(qsItem,bllat,bllon,trlat,trlon) ; Public ; Convert quadString to bbox + ; + s bllat=-90,bllon=-180,trlat=90,trlon=180 + ; + d qsToBbox1(qsItem,.bllat,.bllon,.trlat,.trlon,90,180) + ; + q + + +qsToBbox1(qsItem,bllat,bllon,trlat,trlon,latIncrement,lonIncrement) ; + ; + n tile + ; + s tile=$e(qsItem,1) + ; + i tile="a" s bllat=bllat+latIncrement,trlon=trlon-lonIncrement + i tile="b" s bllat=bllat+latIncrement,bllon=bllon+lonIncrement + i tile="c" s trlat=trlat-latIncrement,trlon=trlon-lonIncrement + i tile="d" s trlat=trlat-latIncrement,bllon=bllon+lonIncrement + ; + i $l(qsItem)>1 d qsToBbox1($e(qsItem,2,$l(qsItem)),.bllat,.bllon,.trlat,.trlon,latIncrement/2,lonIncrement/2) + ; + q + +qsRoot(qsRoot,qsItem) ; Public ; Return common root of two quadStrings + ; + n x + ; + f x=$l(qsRoot):-1:0 i $e(qsItem,1,x)=$e(qsRoot,1,x) s qsRoot=$e(qsRoot,1,x) q + q qsRoot + + +bbox(bllat,bllon,trlat,trlon) ; Public ; Return quadString for a given bounding box + ; + n qsbl,qstl,qsbr,qstr,qsRoot + ; + s qsbl=$$llToQs(bllat,bllon) + s qstl=$$llToQs(trlat,bllon) + s qsbr=$$llToQs(bllat,trlon) + s qstr=$$llToQs(trlat,trlon) + s qsRoot=qsbl + s qsRoot=$$qsRoot^quadString(qsRoot,qstl) + s qsRoot=$$qsRoot^quadString(qsRoot,qsbr) + s qsRoot=$$qsRoot^quadString(qsRoot,qstr) + ; + q qsRoot + + +bboxInQs(bbox,qsItem) ; Public ; Is any part of this bbox contained within this quadString? + ; + n bllat,bllon,trlat,trlon + ; + d qsToBbox(qsItem,.bllat,.bllon,.trlat,.trlon) + ; + q $$overlap(bllat,bllon,trlat,trlon,bbox("bllat"),bbox("bllon"),bbox("trlat"),bbox("trlon")) + + +incrementQs(qsItem) ; Public ; Add 1 to a quadTile number (eg aaa+1=aab, abd+1=aca) + ; + n rest,last + ; + ; ddd+1 returns null + i $tr(qsItem,"d","")="" q "" + ; + s rest=$e(qsItem,1,$l(qsItem)-1) + s last=$e(qsItem,$l(qsItem)) + ; + i last="d" s rest=$$incrementQs(rest) q rest + i last="c" s last="d" + i last="b" s last="c" + i last="a" s last="b" + q rest_last + + +overlap(bllat1,bllon1,trlat1,trlon1,bllat2,bllon2,trlat2,trlon2) ; + ; + ; Algorithm from http://www.siliconchisel.com/Articles/Development_&_Tools/Fast_Window_Overlap_Checking_Algorithm/ + ; + i ((trlat1-bllat2)<0)'=((bllat1-trlat2)<0),((bllon1-trlon2)<0)'=((trlon1-bllon2)<0) q 1 + ; + q 0 diff --git a/relation.m b/relation.m new file mode 100644 index 0000000..956c6f6 --- /dev/null +++ b/relation.m @@ -0,0 +1,691 @@ +relation ; Relation Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + + +add(sRelation,delete) ; Public ; Add a relation + ; #sRelation = stream object containing a relation in osm xml format + ; + n line,relationId,users,lat,lon,timestamp,user,qsBox,uid,version,changeset + n bllat,bllon,trlat,trlon + n currentUid,a,blockedByUid + ; + s line=sRelation("current") + ; + s relationId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; Don't load older versions + i ($g(^relationtag(relationId,"@version"))>version) d q + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sRelation) + ; + ; Conflict checks + s currentUid=$g(^relationtag(relationId,"@uid"),0) + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid + ; + ; Don't load forked elements + i ($d(^relationtag(relationId,"@fork"))) d q + . ; + . ; Log conflict + . d log^conflict("relation",relationId,currentUid,a,"Edited in fosm") + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sRelation) + ; + ; Don't load edits from blocked users + i uid'="",$g(^user(uid,"osmImport"))="block" d q + . s blockedByUid=$g(^user(uid,"blockedByUid"),uid) + . ; + . ; Log conflict + . d log^conflict("relation",relationId,blockedByUid,a,"User #"_uid_" ("_^user(uid,"name")_") blocked by "_blockedByUid) + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sRelation) + ; + d delete(relationId,delete) + ; + d setTag(relationId,"@timestamp",timestamp,changeset,version,delete) + d setTag(relationId,"@user",user,changeset,version,delete) + d setTag(relationId,"@uid",uid,changeset,version,delete) + d setTag(relationId,"@version",version,changeset,version,delete) + d setTag(relationId,"@changeset",changeset,changeset,version,delete) + i delete d setTag(relationId,"@visible","false",changeset,version,delete) + ; + ; Changeset by version index + s ^relationVersion(relationId,"v",version)=changeset + s ^relationVersion(relationId,"c",changeset,version)="" + ; + ; Changeset headers + s ^c(changeset)="" + s ^c(changeset,"r",relationId)="" + s ^c(changeset,"r",relationId,"v",version)="" + ; + s sequenceNo=0 + i line'["/>" f d i line["" q + . s line=$$read^stream(.sRelation) + . i line["" f d i line["" q + . s line=$$read^stream(.sRelation) + . i line["" f d i line["/>" q + . s line=line_$$read^stream(.sRelation) + ; + s type=$$getAttribute^osmXml(line,"type") i type="" q + s role=$$getAttribute^osmXml(line,"role") ; null roles are permitted + s ref=$$getAttribute^osmXml(line,"ref") i ref="" q + i ref<0 s ref=$g(^temp($j,type,ref)) ; TODO: This could be a forward reference - if undef then allocate at this point and use when we get to it. + ; + i type'="" d + . i 'delete s ^relation(relationId,"seq",sequenceNo,"type")=type + . s ^c(changeset,"r",relationId,"v",version,"s",sequenceNo,"t")=type + ; + i ref'="" d + . i 'delete s ^relation(relationId,"seq",sequenceNo,"ref")=ref + . s ^c(changeset,"r",relationId,"v",version,"s",sequenceNo,"i")=ref + ; + i 'delete s ^relation(relationId,"seq",sequenceNo,"role")=role + s ^c(changeset,"r",relationId,"v",version,"s",sequenceNo,"r")=role + ; + i 'delete s ^relationMx(type,ref,relationId)="" + q + + +addTag(sRelation,relationId,changeset,version,delete) ; Private ; Load a tag and add it + ; + n line,k,v + ; + s line=sRelation("current") + i line'["/>" f d i line["/>" q + . s line=line_$$read^stream(.sRelation) + ; + s k=$$getAttribute^osmXml(line,"k") i k="" q + i $l(k)>100 s k=$e(k,1,100)_".." + s v=$$getAttribute^osmXml(line,"v") + i v["'" s v=$$xmlEscapeApostrophe(v) + i $l(v)>4000 s v=$e(v,1,4000)_".." + d setTag(relationId,k,v,changeset,version,delete) + q + + +setTag(relationId,k,v,changeset,version,delete) ; Private ; Add a tag + ; + i k="" q + i 'delete s ^relationtag(relationId,k)=v + s ^c(changeset,"r",relationId,"v",version,"t",k)=v + q + + +getTag(relationId,tag) ; Public ; Get the value of a tag for a relation + ; + i relationId="" q "" + ; + q $g(^relationtag(relationId,tag)) + + +indexTags(relationId) ; Private ; Create index entries for a single relation + ; + n k,v + n bllat,bllon,trlat,trlon + ; + d bbox(relationId,.bllat,.bllon,.trlat,.trlon) + s qsBox=$$bbox^quadString(bllat,bllon,trlat,trlon) + i qsBox="" s qsBox="*" + ; + ; If a relation has no members, then it will not have any spatial extent. Use # to indicate this. + i $o(^relation(relationId,""))="" s qsBox="#" + ; + s k="" + f d i k="" q + . s k=$o(^relationtag(relationId,k)) i k="" q + . i k="@xapi:users" q + . i k="@version" q + . i k="@timestamp" q + . i k="@fork" q + . s v=^relationtag(relationId,k) + . i $l(v)>100 s v=$e(v,1,100)_".." + . i v="" q + . s ^relationx(k,v,qsBox,relationId)="" + . s ^relationx(k,"*",qsBox,relationId)="" + ; + s ^relation(relationId)=qsBox_$c(1)_bllat_$c(1)_bllon_$c(1)_trlat_$c(1)_trlon ; Save the qsBox because a member might get moved independently + s ^relationx("*","*",qsBox,relationId)="" + ; + q + + +xml(indent,relationId,select) ; Public ; Generate xml for a relation + ; + ; + n user,uid,uidUser,timestamp,version,changeset + n xml + ; + s xml="" + ; + i '$$select^osmXml(select,"relation") q "" + ; + s indent=indent_" " + ; + s user=$g(^relationtag(relationId,"@user")) + s uid=$g(^relationtag(relationId,"@uid")) + s timestamp=$g(^relationtag(relationId,"@timestamp")) + s version=$g(^relationtag(relationId,"@version")) + s changeset=$g(^relationtag(relationId,"@changeset")) + ; + s xml=indent_""_$c(13,10) + w xml + s xml="" + ; + d xmlMembers(relationId,indent,select) + ; + d xmlTags(relationId,indent,select) + s xml=xml_indent_""_$c(13,10) + w xml + s xml="" + ; + q xml + + +xmlMembers(wayId,indent,select) ; Public ; Generate xml for a relation's members + ; + n seq,xml,type,ref,role + ; + s xml="" + ; + i '$$select^osmXml(select,"member") q "" + ; + s indent=indent_" " + ; + s seq="" + f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +xmlTags(id,indent,select) ; Public ; Generate xml for a relation's tags + ; + n k,xml + ; + s xml="" + ; + i '$$select^osmXml(select,"tag") q "" + ; + s indent=indent_" " + ; + s k="" + f d i k="" q + . s k=$o(^relationtag(id,k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzzzzz" q ; Skip attributes + . i $d(^relationtag(id,k))#10=0 q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +bbox(relationId,bllat,bllon,trlat,trlon,parents,recalculate) ; Public ; Get the bbox for a relation + ; + ; Inputs: + ; recalculate - 0 = used stored value if available (default). The stored value may be wrong if nodes have been moved subsequently. + ; 1 = recalculate from current node locations (slow). + ; + n seq,ref,type,relation + n bllat1,bllon1,trlat1,trlon1 + ; + s recalculate=$g(recalculate)=1 + ; + ; Use previously calculated values if present + i 'recalculate d i bllat'="" q + . s relation=$g(^relation(relationId)) + . s bllat=$p(relation,$c(1),2) + . s bllon=$p(relation,$c(1),3) + . s trlat=$p(relation,$c(1),4) + . s trlon=$p(relation,$c(1),5) + ; + ; Create list of parents to handle recursive relations + s parents=$g(parents)_"|"_relationId + ; + s bllat=999999,bllon=999999,trlat=-999999,trlon=-999999 + s bllat1=999999,bllon1=999999,trlat1=-999999,trlon1=-999999 + s seq="" + f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . s ref=$g(^relation(relationId,"seq",seq,"ref")) + . s type=$g(^relation(relationId,"seq",seq,"type")) i type="" q + . i type="node" d bbox^node(ref,.bllat1,.bllon1,.trlat1,.trlon1) + . i type="way" d bbox^way(ref,.bllat1,.bllon1,.trlat1,.trlon1) + . i type="relation",parents_"|"'[("|"_ref_"|") d bbox^relation(ref,.bllat1,.bllon1,.trlat1,.trlon1,parents,recalculate) + . i trlat1>trlat s trlat=trlat1 + . i bllat1trlon s trlon=trlon1 + . i bllon1100 s value=$e(value,1,100)_".." + . k ^relationx(key,value,qsBox,relationId) + . k ^relationx(key,"*",qsBox,relationId) + ; + k ^relationtag(relationId) + ; + q + + +appendUser(users,user) ; Private ; Append a user to a list of users + ; + s user=$tr(user,",","") ; Remove commas from name + ; + i $$contains^string(users,user,",") q users + ; + i users="" s users=user + e s users=users_","_user + q users + + +xmlEscapeApostrophe(string) ; Private ; Escape apostrophe + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +hasRealTag(id) ; Public ; Does this way have a real tag? + ; + n hasRealTag,tag + ; + s hasRealTag=0 + s tag="@zzzzzzzzzzzzzzzz" + f d i tag="" q + . s tag=$o(^relationtag(id,tag)) i tag="" q + . s hasRealTag=1,tag="" + ; + q hasRealTag + + +versionAtChangeset(relationId,changeset,relationChangeset,relationVersion) ; Public ; Get the changeset and version that was current at a given changeset time + ; + ; Usage: + ; d versionAtChangeset^relation(relationId,changeset,.relationChangeset,.relationVersion) + ; Output: + ; relationChangeset - null if not found + ; relationVersion - null if not found + ; + s relationChangeset=changeset + s relationVersion="" + i '$d(^relationVersion(relationId,"c",relationChangeset)) s relationChangeset=$o(^relationVersion(relationId,"c",relationChangeset),-1) i relationChangeset="" q + s relationVersion=$o(^relationVersion(relationId,"c",relationChangeset,""),-1) i relationVersion="" s relationChangeset="" q + ; + q + + +restRelation(string) ; Public ; Single relation query + ; + ; Inputs: + ; string - relationId[ /full | /version/full ] + ; + n step,relationId,full,logId,indent + n seq,nodeId,wayId,ndSeq,subRelationId + n count + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s relationId=step + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Three choices here: + ; / - current relation only + ; /history - all versions of relation + ; /full - current relation plus current members + ; /#version/full - historic way plus historic nodes + s full=0 + i step="" s full=0 + i step="full" s full=1 + i step="history" d restRelationHistory(relationId) q + i step?1.n d restRelation^relationVersion(relationId,step,string) q + ; + k ^temp($j) + s count=0 + ; + s logId=$$logStart^xapi("relation/"_relationId_$s(full:"/full",1:""),"") + ; + ; Bad query? + i relationId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^relation(relationId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Select all nodes that belong to this relation and all nodes that belong to + ; ways that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . ; + . ; Nodes + . i ^relation(relationId,"seq",seq,"type")="node" d q + . . s nodeId=^relation(relationId,"seq",seq,"ref") + . . i $d(^temp($j,"node",nodeId)) q + . . s ^temp($j,"node",nodeId)="" + . . w $$xml^node(indent,nodeId,"node|@*|tag|") + . . s count=count+1 + . ; + . ; Nodes within ways + . i ^relation(relationId,"seq",seq,"type")="way" d q + . . s wayId=^relation(relationId,"seq",seq,"ref") + . . s ndSeq="" + . . f d i ndSeq="" q + . . . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . . . s nodeId=^way(wayId,ndSeq) + . . . i $d(^temp($j,"node",nodeId)) q + . . . s ^temp($j,"node",nodeId)="" + . . . w $$xml^node(indent,nodeId,"node|@*|tag|") + . . . s count=count+1 + ; + ; Select all ways that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . i ^relation(relationId,"seq",seq,"type")'="way" q + . s wayId=^relation(relationId,"seq",seq,"ref") + . w $$xml^way(indent,wayId,"way|@*|nd|tag|") + . s count=count+1 + ; + ; Select this relation + w $$xml(indent,relationId,"relation|@*|member|tag|") + s count=count+1 + ; + ; Select all relations that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . i ^relation(relationId,"seq",seq,"type")'="relation" q + . s subRelationId=^relation(relationId,"seq",seq,"ref") + . w $$xml(indent,subRelationId,"relation|@*|member|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +restRelations(step,string) ; Public ; Multi node query + ; + n logId,relationIds,ok,i,relationId,indent + ; + s logId=$$logStart^xapi($$decode^xapi(step),"") + ; + s relationIds=$p(step,EQUALS,2) + ; + ; Validate query + s ok=1 + f i=1:1:$l(relationIds,",") d i 'ok q + . s relationId=$p(relationIds,",",i) + . i relationId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . i '$d(^relation(relationId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + i 'ok q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + f i=1:1:$l(relationIds,",") w $$xml(indent,$p(relationIds,",",i),"relation|@*|member|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,i,"") + ; + q + + +restRelationHistory(relationId) ; Public ; All versions of relation + ; + n logId,count,indent + n version,changeset + ; + s count=0 + s logId=$$logStart^xapi("relation/"_relationId_"/history","") + ; + ; Bad query? + i relationId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^relationVersion(relationId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Iterate all changesets + s version="" + f d i version="" q + . s version=$o(^relationVersion(relationId,"v",version)) i version="" q + . s changeset=^relationVersion(relationId,"v",version) + . ; + . w $$xml^relationVersion(indent,relationId,changeset,version,"relation|@*|member|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +currentVersion(relationId) ; Public ; Return the current version number of a relation + ; + ; Usage: s currentVersion=$$currentVersion^relation(relationId) + ; Input: + ; relationId - relation id, must not be null + ; Output: + ; currentVersion - if the relation does not exists then null is returned + ; + n version + ; + s version=$o(^relationVersion(relationId,"v",""),-1) + i version="" s version=$g(^relationtag(relationId,"@version")) + q version + diff --git a/relationVersion.m b/relationVersion.m new file mode 100644 index 0000000..264becd --- /dev/null +++ b/relationVersion.m @@ -0,0 +1,233 @@ +relationVersion ; Relation Version Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +xmlChangeset(indent,relationId,changeset,select) ; Public ; Generate xml for a relation at a given changeset + ; + n relationChangeset,relationVersion + ; + d versionAtChangeset^relation(relationId,changeset,.relationChangeset,.relationVersion) i relationChangeset="" q + ; + q $$xml(indent,relationId,relationChangeset,relationVersion,select) + + +xml(indent,relationId,changeset,version,select) ; Public ; Generate xml for a relation + ; + ; + n a,user,uid,timestamp,visible + n xml + ; + s xml="" + ; + s indent=indent_" " + ; + i $d(^c(changeset,"r",relationId,"v",version,"a")) d + . s a=^c(changeset,"r",relationId,"v",version,"a") + . ; s version=$p(a,$c(1),1) ; we already have this + . ; s changeset=$p(a,$c(1),2) ; we already have this + . s timestamp=$p(a,$c(1),3) + . s uid=$p(a,$c(1),4) + . s user=$g(^user(uid,"name")) + . s visible=$p(a,$c(1),5) i visible="" s visible="true" + e d + . ; s version=$g(^c(changeset,"r",relationId,"v",version,"t","@version")) ; We already have this + . ; s changeset=$g(^relationh(relationId,changeset,"tag","@changeset")) ; We already have this + . s timestamp=$g(^c(changeset,"r",relationId,"v",version,"t","@timestamp")) + . s uid=$g(^c(changeset,"r",relationId,"v",version,"t","@uid")) + . s user=$g(^c(changeset,"r",relationId,"v",version,"t","@user")) + . s visible=$g(^c(changeset,"r",relationId,"v",version,"t","@visible"),"true") + ; + s xml=indent_""_$c(13,10) + w xml + s xml="" + ; + d xmlMembers(relationId,changeset,version,indent,select) + ; + d xmlTags(relationId,changeset,version,indent,select) + s xml=xml_indent_""_$c(13,10) + w xml + s xml="" + ; + q xml + + +xmlMembers(relationId,changeset,version,indent,select) ; Public ; Generate xml for a relation's members + ; + n seq,xml,type,ref,role + ; + s xml="" + ; + i '$$select^osmXml(select,"member") q "" + ; + s indent=indent_" " + ; + s seq="" + f d i seq="" q + . s seq=$o(^c(changeset,"r",relationId,"v",version,"s",seq)) i seq="" q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +xmlTags(relationId,changeset,version,indent,select) ; Public ; Generate xml for a relation's tags + ; + n k,u,xml + ; + s xml="" + ; + i '$$select^osmXml(select,"tag") q "" + ; + s indent=indent_" " + ; + s k="" + f d i k="" q + . s k=$o(^c(changeset,"r",relationId,"v",version,"t",k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzz" q + . i $d(^c(changeset,"r",relationId,"v",version,"t",k))#10=0 q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + ; + s u="" + f d i u="" q + . s u=$o(^c(changeset,"r",relationId,"v",version,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + ; + q + + +restRelation(relationId,step,string) ; Public ; Single relation version query + ; + ; Inputs: + ; string - relationId[ /full | /version/full ] + ; + n version,full,logId,indent + n seq,nodeId,wayId,ndSeq,subRelationId + n count + ; + ; Get next step + s version=step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Two choices here: + ; /version/ - historic relation + ; /version/full - historic relation plus historic members + s full=0 + i step="" s full=0 + i step="full" s full=1 + ; + k ^temp($j) + s count=0 + ; + s logId=$$logStart^xapi("relation/"_relationId_"/"_version_$s(full:"/full",1:""),"") + ; + ; Bad query? + i relationId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + i version'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^relationVersion(relationId,"v",version)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + s changeset=^relationVersion(relationId,"v",version) + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Select all nodes that belong to this relation and all nodes that belong to + ; ways that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^c(changeset,"r",relationId,"v",version,"s",seq)) i seq="" q + . ; + . ; Nodes + . i ^c(changeset,"r",relationId,"v",version,"s",seq,"t")="node" d q + . . s nodeId=^c(changeset,"r",relationId,"v",version,"s",seq,"i") + . . i $d(^temp($j,"node",nodeId)) q + . . s ^temp($j,"node",nodeId)="" + . . w $$xmlChangeset^nodeVersion(indent,nodeId,changeset,"node|@*|tag|") + . . s count=count+1 + . ; + . ; Nodes within ways + . i ^c(changeset,"r",relationId,"v",version,"s",seq,"t")="way" d q + . . s wayId=^c(changeset,"r",relationId,"v",version,"s",seq,"i") + . . ; + . . ; Get the way version that existed at the time of this changeset + . . d versionAtChangeset^way(wayId,changeset,.wayChangeset,.wayVersion) i wayChangeset="" q + . . ; + . . s ndSeq="" + . . f d i ndSeq="" q + . . . s ndSeq=$o(^c(wayChangeset,"w",wayId,"v",wayVersion,"n",ndSeq)) i ndSeq="" q + . . . s nodeId=^c(wayChangeset,"w",wayId,"v",wayVersion,"n",ndSeq) + . . . i $d(^temp($j,"node",nodeId)) q + . . . s ^temp($j,"node",nodeId)="" + . . . w $$xmlChangeset^nodeVersion(indent,nodeId,changeset,"node|@*|tag|") + . . . s count=count+1 + ; + ; Select all ways that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^c(changeset,"r",relationId,"v",version,"s",seq)) i seq="" q + . i ^c(changeset,"r",relationId,"v",version,"s",seq,"t")'="way" q + . s wayId=^c(changeset,"r",relationId,"v",version,"s",seq,"i") + . w $$xmlChangeset^wayVersion(indent,wayId,changeset,"way|@*|nd|tag|") + . s count=count+1 + ; + ; Select this relation + w $$xml(indent,relationId,changeset,version,"relation|@*|member|tag|") + s count=count+1 + ; + ; Select all relations that belong to this relation + s seq="" + i full f d i seq="" q + . s seq=$o(^c(changeset,"r",relationId,"v",version,"s",seq)) i seq="" q + . i ^c(changeset,"r",relationId,"v",version,"s",seq,"t")'="relation" q + . s subRelationId=^c(changeset,"r",relationId,"v",version,"s",seq,"i") + . w $$xmlChangeset(indent,subRelationId,changeset,"relation|@*|member|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q diff --git a/relfix.m b/relfix.m new file mode 100644 index 0000000..8f9cc08 --- /dev/null +++ b/relfix.m @@ -0,0 +1,42 @@ +relfix ; Fix up relation index + ; + m status=^relationfix("status") + i '$d(status("count")) s status("count")=0 + i '$d(status("good")) s status("good")=0 + i '$d(status("bad")) s status("bad")=0 + i '$d(status("tag")) s status("tag")=0 + i '$d(status("relationId")) s status("relationId")="" + ; + s relationId="" + f d i relationId="" q + . s relationId=$o(^relation(relationId)) i relationId="" q + . s status("count")=status("count")+1 + . i status("count")#1000=0 s status("relationId")=relationId m ^relationfix("status")=status + . d bbox^relation(relationId,.a,.b,.c,.d) + . s qsBox=$$bbox^quadString(a,b,c,d) i qsBox="" s qsBox="*" + . i $o(^relation(relationId,""))="" s qsBox="#" + . i qsBox=^relation(relationId) s status("good")=status("good")+1 q + . s status("bad")=status("bad")+1 + . s oldQsBox=^relation(relationId) + . ; + . ; Delete old qsIndexes + . s key="" + . f d i key="" q + . . s key=$o(^relationtag(relationId,key)) i key="" q + . . s value=^relationtag(relationId,key) + . . i value="" q + . . i $l(value)>100 s value=$e(value,1,100)_".." + . . k ^relationx(key,value,oldQsBox,relationId) + . . s ^relationx(key,value,qsBox,relationId)="" + . . ; + . . k ^relationx(key,"*",oldQsBox,relationId) + . . s ^relationx(key,"*",qsBox,relationId)="" + . . ; + . . s status("tag")=status("tag")+1 + . ; + . k ^relationx("*","*",oldQsBox,relationId) + . s ^relationx("*","*",qsBox,relationId)="" + . ; + . s ^relation(relationId)=qsBox + q + diff --git a/replicate_down b/replicate_down new file mode 100644 index 0000000..83af84c --- /dev/null +++ b/replicate_down @@ -0,0 +1,3 @@ +. ./profile_source +cd ../zappy1/data06 +$mupip replic -source -shutdown -t=0 diff --git a/replicate_up b/replicate_up new file mode 100755 index 0000000..c4504f5 --- /dev/null +++ b/replicate_up @@ -0,0 +1,5 @@ +. ./profile_source +cd ../zappy1/data06 +$mupip set -reg PERCENT -replic=ON +$mupip replic -instance_create -name=source.repl +$mupip replicate -source -start -secondary=80.68.90.42:8801 -log=source.log -instsec=receiver.repl -root -buff=1 diff --git a/rest.m b/rest.m new file mode 100644 index 0000000..dd19252 --- /dev/null +++ b/rest.m @@ -0,0 +1,540 @@ +rest ; XAPI REST interface + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + ; Set-up error frame + s $zt="do error^rest zgoto "_$zlevel + ; + d main + ; + ; control returns here once an error has been handled + q + + +error ; Private ; Handle error + ; + n errorId,errorCode + ; + s errorCode=$ecode + ; + s $zt="",$ecode="" ; Clear error handler + ; + ; Socket errors are ok, the client disconnected + i $zstatus["%GTM-E-SOCKWRITE" q + ; + ; Log the error + l +^error + s (errorId,^error)=$g(^error)+1 + l -^error + ; + zshow "*":^error(errorId) + ; + q + + +main ; Private ; Process requests + ; + n string,step,encodedCharacters + ; + ; Set up some globals for expression delimiters + s EQUALS=$c(1) + s LEFTBRACKET=$c(2) + s RIGHTBRACKET=$c(3) + s BAR=$c(4) + s SLASH=$c(5) + s ASTERISK=$c(6) + ; + ; Establish the session + s %session=$$establish^session() + ; + s string=%ENV("REQUEST_URI") + s string=$$unescape(string) + ; + ; Encode the query string and then apply escapes + s string=$$encode^xapi(string) + s encodedCharacters=EQUALS_","_LEFTBRACKET_","_RIGHTBRACKET_","_BAR_","_SLASH_","_ASTERISK + f i=2:1:$l(string) i $e(string,i-1)="\",(","_encodedCharacters_",")[(","_$e(string,i)_",") s $e(string,i-1,i)=$$decode^xapi($e(string,i)) + ; + ; Eat leading slash + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i step'="" d error^http q + ; + ; Process steps + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i step="api" d api q + i step="user" d user q + i step="oauth" d oauth q + i step="login" d login^user q + i step="replicate-sequences" d replicateSequences q + i $p(step,"?",1)="edit" d edit q + i step="" d xmlHome("","") q + d notFound^http + q + + + +xmlHome(message,description) ; Serve the front page + ; + n uid,user + ; + d header^http("text/xml") + d prolog^osmXml("/home.xsl") + ; + s uid=$g(^session(%session,"uid")) + s name="" + i uid'="" s name=$g(^user(uid,"name")) + ; + w "",$c(13,10) + ; + i message'="" d + . w "",! + . w description,! + . w "",! + ; + d xmlMetrics + ; + w "",! + q + + + +xmlMetrics ; Private ; Serve metrics + ; + w "",! + w " ",! + w " ",$g(^metric("osmNodeCount")),"",! + w " ",$g(^metric("osmWayCount")),"",! + w " ",$g(^metric("osmRelationCount")),"",! + w " ",! + w " ",! + w " ",$g(^metric("nodeCount")),"",! + w " ",$g(^metric("wayCount")),"",! + w " ",$g(^metric("relationCount")),"",! + w " ",! + w "",! + q + + + + +edit ; Serve a potlatch edit instance + ; + n uid,user + n query + ; + ; Use REQUEST_URI because step has been escaped and so won't work with unpackQuery here + d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2)) + ; + d header^http("text/xml") + d prolog^osmXml("potlatchFosm.xsl") + ; + s uid=$g(^session(%session,"uid")) + s name="" + i uid'="" s name=$g(^user(uid,"name")) + ; + w "",$c(13,10) + ; + w "",! + q + + + +replicateSequences ; Private ; Return state file for timestamp + ; + s currentDevice=$i + ; + s timestamp=$p(%ENV("REQUEST_URI"),"?",2) + i $e(timestamp,1)="Y"!($e(timestamp,1)="y") d + . d unpackQuery^rest(.query,$p(%ENV("REQUEST_URI"),"?",2)) + . i $g(query("Y"))'="" s query("y")=query("Y") + . i $g(query("M"))'="" s query("m")=query("M") + . i $g(query("D"))'="" s query("d")=query("D") + . i $g(query("H"))'="" s query("h")=query("H") + . i $g(query("I"))'="" s query("i")=query("I") + . i $g(query("S"))'="" s query("s")=query("S") + . s timestamp=$g(query("y"))_"-"_$g(query("m"))_"-"_$g(query("d"))_"T"_$g(query("h"))_":"_$g(query("i"))_":"_$g(query("s"))_"Z" + s timestamp=$tr(timestamp,"TZ-:","") + s timestamp=$e(timestamp,1,12) ; Strip seconds + i timestamp="" d notFound^http q + i '$d(^exportDiff("minutelyReplicateSequences",timestamp)) s timestamp=$o(^exportDiff("minutelyReplicateSequences",timestamp),-1) + i timestamp="" d notFound^http q + s stateFile=$g(^exportDiff("minutelyReplicateSequences",timestamp,"stateFile")) + i stateFile="" d notFound^http q + ; + d header^http("text/plain") + o stateFile + f d i eof q + . u stateFile r x s eof=$zeof i eof q + . u currentDevice w x,! + u currentDevice + c stateFile + q + + +oauth ; oauth methods + ; + n step + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i $p(step,"?",1)="request_token" d requestToken^oauth q + i $p(step,"?",1)="authorize" d authorize^oauth q + i $p(step,"?",1)="access_token" d accessToken^oauth q + i step="login" d oauthLogin q + i step="api" d api q + ; + d error^http + q + + +oauthLogin ; Oauth login page + ; + n step,token + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + s token=step + d login^oauth(token) + q + + +api ; API + ; + n step + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i step="0.6" d api06 q + d error^http + q + + +api06 ; API 0.6 + ; + n done,error,bbox,keyseq,qualifiers + n constraint ; Constraint object + n bllon,bllat,trlon,trlat + ; + s bbox="-180,-90,180,90" + s keySeq=0 + s error=0 + s done=0 + ; + ; Parse query steps + f d i string="" q + . s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + . ; + . i step="tile" d tile s done=1 s string="" q + . i step="watch" d rss^watch(string) s done=1,string="" q + . i step="requests" d requests^log s done=1,string="" q + . i step="status" d ^status s done=1,string="" q + . i step="node" d restNode^node(string) s done=1,string="" q + . i $p(step,"?",1)="nodes" d restNodes^node(step,string) s done=1,string="" q + . i step="way" d restWay^way(string) s done=1,string="" q + . i $p(step,"?",1)="ways" d restWays^way(step,string) s done=1,string="" q + . i step="relation" d restRelation^relation(string) s done=1,string="" q + . i $p(step,"?",1)="relations" d restRelations^relation(step,string) s done=1,string="" q + . i step="map" d restMap^mapReduce(string) s done=1,string="" q ; This is mapReduce not map?bbox= + . i step="changeset" d changeset s done=1,string="" q + . i step="changesets" d changesets s done=1,string="" q + . i step="user" d api06user s done=1,string="" q + . ; + . s element=$p(step,LEFTBRACKET,1),step=LEFTBRACKET_$p(step,LEFTBRACKET,2,$l(step)) + . ; + . i element?1"$stylesheet=".e d q + . . s stylesheet=$p(element,"=",2,$l(element)) + . ; + . ; + . i $p(element,"?",1)="map" d map s done=1,string="" q + . i element="stats" d ^stats s done=1,string="" q + . i element'="node",element'="way",element'="relation",element'=ASTERISK d errorMessage("Expected: element = node|way|relation") s error=1,string="" q + . ; + . s constraint("element")=element + . ; + . ; Process predicates + . f d i step="" q + . . s predicate=$p($p(step,RIGHTBRACKET,1),LEFTBRACKET,2),step=$p(step,RIGHTBRACKET,2,$l(step)) + . . s lhs=$p(predicate,EQUALS,1),rhs=$p(predicate,EQUALS,2,$l(predicate)) + . . i lhs="bbox" s bbox=rhs q + . . i predicate="way" s constraint("node/way")=1 q + . . i predicate="not(way)" s constraint("node/way")=0 q + . . i predicate="nd" s constraint("way/nd")=1 q + . . i predicate="not(nd)" s constraint("way/nd")=0 q + . . i predicate="tag" s constraint("node/tag")=1,constraint("way/tag")=1,constraint("relation/tag")=1 q + . . i predicate="not(tag)" s constraint("node/tag")=0,constraint("way/tag")=0,constraint("relation/tag")=0 q + . . ; + . . ; It must be a key=value constraint + . . s keySeq=keySeq+1 + . . s constraint("kv",keySeq,"key")=lhs + . . s constraint("kv",keySeq,"value")=rhs + i error q + i done q + ; + ; Anything left in string are qualifiers which can be passed to the main query function + s qualifiers=string + ; + ; Unpack bbox + s bllon=$p(bbox,",",1) + s bllat=$p(bbox,",",2) + s trlon=$p(bbox,",",3) + s trlat=$p(bbox,",",4) + ; + ; Send headers and prolog + d xml^http("data.osm") + d xmlProlog("") + ; + d bbox^xapi(bllat,bllon,trlat,trlon,.constraint,qualifiers) + q + + +changeset ; Changeset methods + ; + n step + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i $p(step,"?",1)="create" d create^changeset q + i step?1.n d changesetId q + q + + +changesetId ; Specific changeset + ; + n changesetId + ; + s changesetId=step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i $p(step,"?",1)="upload" d upload^changeset(changesetId) q + i $p(step,"?",1)="download" d download^changeset(changesetId) q + i $p(step,"?",1)="close" d close^changeset(changesetId) q + i $p(step,"?",1)="",$g(%ENV("REQUEST_METHOD"))="GET" d restChangeset^changeset(changesetId) q + i $p(step,"?",1)="",$g(%ENV("REQUEST_METHOD"))="PUT" d update^changeset(changesetId) q + q + + +changesets ; Changesets query + ; For now ignore any query parameters and just return the 100 most recent changesets + d query^changeset + q + + + +user ; User preferences/details + ; + n step + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + i step="new" d new^user q + i step="create" d create^user q + i step="confirm" d confirm^user q + ; + d error^http + q + + +api06user ; User preferences/details + ; + n user,uid,step + ; + ; Get the authenticated user + i '$$authenticated^user(.uid,.user) d error^http q + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + i step="details" d getDetails^user(uid) q + i step="preferences" d getPreferences^user(uid) q + i step="conflicts" d getConflicts^user(uid) q + q + + +map ; Traditional map request + ; + n bbox,bllon,bllat,trlon,trlat + n constraint ; Constraint object + n qualifiers + ; + s constraint("element")=ASTERISK + s qualifiers="" + ; + s bbox=$p(element,"?bbox"_EQUALS,2) + s bllon=$p(bbox,",",1) + s bllat=$p(bbox,",",2) + s trlon=$p(bbox,",",3) + s trlat=$p(bbox,",",4) + d header^http("text/xml") + d xmlProlog("") + d bbox^xapi(bllat,bllon,trlat,trlon,.constraint,qualifiers) + q + + +tile ; + s predicate=$p($p(step,"]",1),"[",2),step=$p(step,"]",2,$l(step)) + s x=$p(predicate,",",1) + s y=$p(predicate,",",2) + s z=$p(predicate,",",3) + ; + s type=$p(string,"/",1) + ; + ; Use the IP address for the moment, use a cookie in the future + s id=$g(%ENV("REMOTE_ADDR")) + ; + ; Has this user already flagged this tile? + i $d(^tile(x,y,z,type,id)) d q + . d header^http("text/html") + . w "You have already marked this tile" + ; + s reputation=+$g(^reputation(id)) + s tileScore=$g(^tile(x,y,z,type)) + ; + ; Enhance the user's reputation by the current score for this tile + s reputation=reputation+tileScore + i reputation>10 s reputation=10 ; max. + s ^reputation(id)=reputation + ; + ; Add this user's weight to the tile + s newTileScore=reputation + i newTileScore=0 s newTileScore=1 + s ^tile(x,y,z,type)=newTileScore + s ^tile(x,y,z,type,id)=reputation + ; + d header^http("text/html") + f type1="land","sea","mixed" i $d(^tile(x,y,z,type1)) w "Tile marked as: "_type1_" with score "_(^tile(x,y,z,type1)+1/10)_"
" + ; + s f="/home/etienne/osmxapi/www/tiles.txt" + o f:APPEND + u f w x,",",y,",",z,",",type,",",$zd($h,"YEAR-MM-DD 24:60:SS"),",",(^tile(x,y,z,type)+1/10),! + c f + q + + + +errorMessage(message) w message + q + + +xmlProlog(xslTemplate) ; Public ; Write xml Prolog and xsl stylesheet elements + ; + w "",! + i xslTemplate'="" w "",! + ; + q + + +unpackQuery(params,string) ; Public ; Create the %KEY array from the name-value string sent from the client + ; Array structure: + ; %KEY(name)=value + ; or, if multiple values: + ; %KEY(name,1..*)=value + ; + n x,pair,name,value,oldValue,seq + ; + f x=1:1:$l(string,"&") d + . s pair=$p(string,"&",x) + . s name=$p(pair,"=",1) + . s value=$p(pair,"=",2,$l(pair,"=")) + . i name="" q + . ; + . ; NB the sequence of the following three blocks is significant + . ; + . ; If we already have a value of this kind then make it into an array + . i $d(params(name))=1 d + . . s oldValue=params(name) + . . k params(name) + . . s params(name,1)=oldValue + . ; + . ; Array item + . i $d(params(name))=10 d + . . s seq=$o(params(name,""),-1)+1 + . . s params(name,seq)=$$unescape(value) + . ; + . ; Single item + . i $d(params(name))=0 s params(name)=$$unescape(value) + . ; + q + + + ; Unescape String +unescape(string) ; + n match,char1,char2,char + ; + ; Special case - spaces are converted to + by browser + s string=$tr(string,"+"," ") + ; + ; Convert the two characters following each % character from hex to ascii + ; then replace %HH with A. eg replace abc%2Bdef with abc+def. + s match=0 + f d i match=0 q + . s match=$f(string,"%",match) i match=0 q + . s char1=$$hexToDec($e(string,match)) + . s char2=$$hexToDec($e(string,match+1)) + . s char=$c(char1*16+char2) + . s string=$e(string,1,match-2)_char_$e(string,match+2,$l(string)) + q string + +hexToDec(hex) ; + i hex?1n q hex + i hex="A" q 10 + i hex="B" q 11 + i hex="C" q 12 + i hex="D" q 13 + i hex="E" q 14 + i hex="F" q 15 + i hex="a" q 10 + i hex="b" q 11 + i hex="c" q 12 + i hex="d" q 13 + i hex="e" q 14 + i hex="f" q 15 + q "" + + + ; Switch namespace/UCI +switch(nspace) ; + n mImplementation + s mImplementation=$$mImplementation() + ; i mImplementation="CACHE" znspace nspace + i mImplementation="HBOM" d switchHbom(nspace) + i mImplementation="GTM" ; No-op + q + + +switchHbom(ucivol) ; + n uci,vol,ucivolno,ucino,z + ; + s uci=$p(ucivol,",",1) + s vol=$p(ucivol,",",2) + s ucivolno=$zu(uci,vol) + s ucino=$p(ucivolno,",",1) + i ucino="" q "BadUCI"/0 + ; + ; s z=$zinfo(7,"pvector","ucino",ucino) + q + + + ; Test for M implementation +mImplementation() ; + i $zv["Cache" q "CACHE" + i $zv["HBOM" q "HBOM" + i $zv["GT.M" q "GTM" + q "Unsupported"/0 diff --git a/serenji.m b/serenji.m new file mode 100644 index 0000000..7ffb676 --- /dev/null +++ b/serenji.m @@ -0,0 +1,3 @@ +serenji ; Wrapper for Serenji shell + d SHELL^%Serenji("@gj") + q diff --git a/serverLink.cgi b/serverLink.cgi new file mode 100755 index 0000000..0f394fa --- /dev/null +++ b/serverLink.cgi @@ -0,0 +1,97 @@ +#!/usr/bin/perl +# +# Object: serverLink/cgi +# Component: serverLink.cgi +# +# serverLink.cgi +# Copyright 2000,2011 George James Software Limited +# + +# This is what it does: +# 1 Opens a socket connection to an M server +# 2 If the request is a POST then reads STDIN and creates a +# POST_DATA environment variable (this probably won't work for +# very large amounts of post data, but its good for 30kbytes). +# 3 Copies all environment variables to the socket in the format: +# %ENV:environment_variable=value +# 4 Copies the response from the socket to STDOUT +# Anything else should probably be done on the M server + +# Usage: +# serverLink.cgi +# Expects: +# $ENV{'SERVER_LINK_IP'} = IP address of M server +# $ENV{'SERVER_LINK_PORT'} = Port number on which M server is listening +# $ENV{'SERVER_LINK_PASSPHRASE'} = ServerLink's passphrase + +use strict; +use IO::Socket; +open STDERR, '>>/tmp/error.log'; + +my ($socket, $line, $key, $postData, $payload, $peerPort, $peerAddr, $serverLinkAuth, $i); + +$peerAddr = $ENV{'SERVER_LINK_IP'}; +$peerPort = $ENV{'SERVER_LINK_PORT'}; +$serverLinkAuth = $ENV{'SERVER_LINK_PASSPHRASE'}; + + +# Create socket object with connection to M server +# If no connection then return an Internal Server Error header. For security +# reasons do not send any other kind of identifying info. The web-server will +# log the response which is where you should look for debugging and problem diagnosis. +for ($i=0;$i<=30;$i++) { + if ($socket = IO::Socket::INET->new(Proto => "tcp", + PeerAddr => "$peerAddr", + Timeout => 1000000, + PeerPort => "$peerPort")) { + print $socket "serverLink.cgi/1.4\n"; + if ($line=<$socket>) { + if ($line=="r.serverLink/1.4") { last; } } + } + elsif ($i==30) { + print STDOUT "Status: 503 Service Unavailable\015\012"; + print STDOUT "Content-Type: text/html\015\012"; + print STDOUT "\015\012"; + exit;} + + else { + if ($i>3) {sleep 1;} + } +} + + +# Stuff the pass-phrase into the ENV hash so that it gets passed to the M server +$ENV{'GJS_SERVERLINK_AUTH'}=$serverLinkAuth; + + +# Get POST form contents from STDIN and append to the QUERY_STRING +# environment variable. To the user the Query String will always +# be in the environment variable (nice and simple...too simple). +if ($ENV{'REQUEST_METHOD'} eq 'POST') { + read(STDIN,$postData,$ENV{'CONTENT_LENGTH'}); + $ENV{'POST_DATA'}=$postData; +} +#if ($ENV{'REQUEST_METHOD'} eq 'PUT') { +# read(STDIN,$payload,$ENV{'CONTENT_LENGTH'}); +# $ENV{'PAYLOAD'}=$payload; +#} + +# Walk ENV hash and print +foreach $key (keys %ENV) { + print $socket "%ENV:$key=$ENV{$key}\n"}; + + +# Send %END to indicate end of message +print $socket "%END\n"; + + +# Disable buffering for STDOUT +select((select(STDOUT), $|=1)[0]); +# Now read the response from the socket and echo it back to the web-server +# which will be waiting on STDOUT. +while ($line = <$socket>) { + print STDOUT $line or die "Client gone\n"; +} + +# Done +die "Done\n"; diff --git a/serverLink.m b/serverLink.m new file mode 100644 index 0000000..fa55f98 --- /dev/null +++ b/serverLink.m @@ -0,0 +1,551 @@ +serverLink ; Server Link + ; Copyright (C) 2008,2011 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + q + + + ; Main entry point +start(port,logLevel) ; + n mImplementation + s mImplementation=$$mImplementation() + ; + s port=$g(port) i port="" s port=6500 + i $d(^serverLink("port")) s port=^serverLink("port") + s logLevel=$g(logLevel) i logLevel="" s logLevel=0 + i $d(^serverLink("logLevel")) s logLevel=^serverLink("logLevel") + ; + k ^serverLink("stop") + d logMessage("Server started",1,port) + ; + i mImplementation="CACHE" d open01(port,logLevel) + i mImplementation="HBOM" d open02(port,logLevel) + i mImplementation="GTM" d open03(port,logLevel) + q + + + ; Test for M implementation +mImplementation() ; + i $zv["Cache" q "CACHE" + i $zv["HBOM" q "HBOM" + i $zv["M21" q "HBOM" + i $zv["GT.M" q "GTM" + q "Unsupported"/0 + + + + ; Open socket for listening (accept mode) + ; Cache +open01(port,logLevel) ; + n socket,stop,string + ; + s socket="|TCP|"_port + o socket:(:port:"PSTA"):10 e d logMessage("Cannot open socket",0,port) s stop=1 q + s stop=0 + ; + f d i stop q + . u socket:"PSTA" + . r string:60 e s stop=$$checkStop q + . d logMessage("Server connection"_string,2,port) + . j sub01^serverLink(port,logLevel):(:4:socket:socket):10 e d logMessage("Cannot spawn sub-process",1,port) q + ; + c socket + d logMessage("Server stopped",1,port) + q + + + ; Open socket for listening (accept mode) + ; HBOM +open02(port,logLevel) ; + n device,socket,stop + ; + s device=9050 + o device:("TCP":"":port):10 e d logMessage("Cannot open socket",0,port) s stop=1 q + u device w /listen(10) + s stop=0 + ; + f d i stop q + . u device w /wait(60) + . i $key'="CONNECT" s stop=$$checkStop q + . s socket=$zsocket(device) + . d logMessage("Server connection socket #"_socket,2,port) + . u device:(::::::socket) ; Detach socket + . i $device'="" d logMessage("Unable to detach socket #"_socket_" $device="_$device,1,port) + . c device:socket + . j sub02^serverLink(port,socket,logLevel)::10 e d logMessage("Cannot spawn sub-process for socket #"_socket,1,port) q + ; + c device + d logMessage("Server stopped",1,port) + q + + + ; Open socket for listening (accept mode) + ; GT.M + ; Because GT.M cannot pass sockets between processes we are using the following strategy: + ; 1 Job off a real serverLink process which will listen on the port + ; 2 Use a lock to monitor when it has completed + ; 1 Open port 5000 in listen mode + ; 2 Job another process which will also attempt to listen on port 5000. It will hang until + ; this process closes the listen socket. + ; 3 As soon as this process gets a connection, close the listen socket and start to service the + ; the active connection. +open03(port,logLevel) ; + n process,started + ; + ; Allocate a process Id for this spawner + tstart * + s process=$g(^serverLink("process"))+1 + s ^serverLink("process")=process + tcommit + ; + ; Keep starting servers + f d i $$checkStop^serverLink() q + . l +^serverLink("process",process) ; Wait until the last job has finished + . s ^serverLink("process",process)="starting" + . l -^serverLink("process",process) + . ; j open03a^serverLink(port,logLevel,process) + . zsystem "$zappy/scripts/"_^osmPlanet("instance")_" "_port_" "_$g(^serverLink("logLevel"))_" "_process + . ; + . ; Wait until it has started + . s started=0 + . f d i started q + . . i $g(^serverLink("process",process))="started" s started=1 q + ; + ; Tidy up + k ^serverLink("process",process) + q + + + ; Started serverLink process (GT.M) +open03a(port,logLevel,process) ; + ; + ; Lock and keep the lock until the process completes + l +^serverLink("process",process) + s ^serverLink("process",process)="started" + d open03b(port,logLevel) + l -^serverLink("process",process) + q + + + ; GT.M real serverLink process +open03b(port,logLevel) ; + n device,socket,stop,ok + ; + s device="|TCP|"_port + s stop=0,ok=0 + f d i stop!ok q + . o device:(ZLISTEN=port_":TCP":DELIMITER=$c(10):ATTACH="listen":NOWRAP:IOERROR="TRAP"):60:"SOCKET" e s stop=$$checkStop q + . s ok=1 + i stop d logMessage("Server stopped",1,port) q + ; + ; Now listen + d logMessage("Server listening on port "_port,3,port) + u device w /listen(1) + ; + s stop=0 + f d i stop q + . u device w /wait(60) + . i $p($key,"|",1)'="CONNECT" s stop=$$checkStop q + . s socket=$p($key,"|",2) + . d logMessage("Server connection socket #"_socket,2,port) + . ; + . ; Release listen socket so that the next listener can fire up + . c device:(SOCKET="listen") + . ; + . ; Process the request + . d sub03^serverLink(port,socket,logLevel) + . s stop=1 + ; + c device + d logMessage("Server stopped",1,port) + q + + + ; Start here with a connection + ; Cache + ; TCP socket is current device +sub01(port,logLevel) ; + n socket,stop,eof,string,key,%ENV + ; + ; Top level error handler + n $et + s $et="i $estack=0 znspace """_$znspace_""" g error^serverLink" + ; + s socket=$p + d logMessage("Sub-process started on socket #"_socket,2,port) + ; + ; Handshake + u socket:(::"STP") + r string:60 e d logMessage("Handshake timeout",0,port) c socket q + d logMessage("Handshake from client: "_string,2,port) + i '$$clientVersion(string) d c socket q + . d logMessage("Handshake rejected from client: "_string,0,port) + w $$serverVersion,! + ; + s stop=0 + s eof=0 + f d i stop!eof q + . u socket:(::"STP") + . r string:60 e d logMessage("Client timeout",1,port) s stop=1 q + . i string="%END" s eof=1 q + . i $e(string,1,5)="%ENV:" d + . . s key=$p($e(string,6,$l(string)),"=",1) + . . i key'="" s %ENV(key)=$e(string,6+$l(key)+1,$l(string)) + . d logMessage(string,2,port) + ; + ; Check for stop + i stop c socket q + ; + ; Authenticate and execute + i $$authentic(.%ENV,port,logLevel) d + . u socket + . d exec + ; + ; Termination + c socket + d logMessage("Sub-process stopped",2,port) + q + + + ; Start here with a connection + ; HBOM + ; socket handle is passed, attach to device +sub02(port,socket,logLevel) ; + n device,stop,eof,string,substring,timeout,key,%ENV + n ucivol,uci,vol,ucivolno,ucino + ; + ; Derive current UCI number + s ucivol=$zu(0) + s uci=$p(ucivol,",",1) + s vol=$p(ucivol,",",2) + s ucivolno=$zu(uci,vol) + s ucino=$p(ucivolno,",",1) + ; + ; Top level error handler + n $et + s $et="q:0&$zinfo(7,""pvector"",""ucino"","_ucino_") g error^serverLink" + ; + s device=9050 + o device:("TCP":""::::socket) ; Attach socket + i $device'="" d logMessage("Sub-process unable to start on socket #"_socket_" $device="_$device,1,port) c device q + ; + d logMessage("Sub-process started on socket #"_socket,2,port) + ; + ; Handshake + s string=$$sub02read(port,socket,device) + d logMessage("Handshake from client: "_string,2,port) + i '$$clientVersion(string) d c device q + . d logMessage("Handshake rejected from client: "_string,0,port) + w $$serverVersion,! + ; + s stop=0 + s eof=0 + f d i stop!eof q + . s string=$$sub02read(port,socket,device) + . d logMessage(string,2,port) + . ; + . i string="%STOP" s stop=1 q + . i string="%END" s eof=1 q + . i string="" s eof=1 q ; Retain for backward compatability (old serverLink.cgi may send null) + . ; + . i $e(string,1,5)="%ENV:" d + . . s key=$p($e(string,6,$l(string)),"=",1) + . . i key'="" s %ENV(key)=$e(string,6+$l(key)+1,$l(string)) + ; + ; Check for stop + i stop c device q + ; + ; Authenticate and execute + i $$authentic(.%ENV,port,logLevel) d + . u device + . d exec + ; + ; Termination + c device + d logMessage("Sub-process stopped",2,port) + q + + + ; Read $c(10) terminated string from socket +sub02read(port,socket,device) ; + n string,stop,eor,substring,timeout + s string="" + s stop=0 + s eor=0 + u device:(:::$c(10)) + f d i stop!eor q + . r substring:60 s timeout='$t + . i $device'="" d logMessage("Error reading from socket #"_socket_" $device="_$device,1,port) s stop=1 q + . d logMessage("Substring: "_substring,3,port) + . s string=string_substring + . i timeout d logMessage("Client timeout, for socket #"_socket,1,port) s stop=1 q + . i $key=$c(10) s eor=1 q + i stop q "%STOP" + q string + + + ; Start here with a connection + ; GT.M + ; socket handle is passed, attach to device +sub03(port,socket,logLevel) ; + n device,stop,eof,string,substring,timeout,key,%ENV + ; + ; Set log level override + s logLevel=$g(^serverLink("logLevel"),logLevel) + ; + ; Top level error handler + ; Need to check for quotes in $zroutines!! + n $zt + s $zt="s $zroutines="""_$zroutines_""" d error^serverLink zgoto "_($zlevel-1) + ; + ; Attach to socket + s device="|TCP|"_port + ; + d logMessage("Sub-process started on socket #"_socket,2,port) + ; + ; Handshake + s string=$$sub03rea(port,socket,device) + d logMessage("Handshake from client: "_string,2,port) + i '$$clientVersion(string) d c device q + . d logMessage("Handshake rejected from client: "_string,0,port) + w $$serverVersion,! + ; + s payload=0 + k ^serverLink("payload",$j) + ; + s stop=0 + s eof=0 + f d i stop!eof q + . s string=$$sub03rea(port,socket,device) + . d logMessage(string,2,port) + . ; + . i string="%STOP" s stop=1 q + . i string="%END" s eof=1 q + . ; + . i $e(string,1,5)="%ENV:" d + . . s key=$p($e(string,6,$l(string)),"=",1) + . . s string=$e(string,6+$l(key)+1,$l(string)) + . . i key'="" s %ENV(key)=string + . . i key="PAYLOAD"!(key="POST_DATA") s payload=1,seq=0 + . . e s payload=0 + . i payload d + . . s seq=seq+1 + . . s ^serverLink("payload",$j,seq)=string + . ; + ; + ; Check for stop + i stop c device q + ; + ; Authenticate and execute + i $$authentic(.%ENV,port,logLevel) d + . u device + . d exec + ; + ; Termination + c device + ;k ^serverLink("payload",$j) + d logMessage("Sub-process stopped",2,port) + q + + + ; Read $c(10) terminated string from socket +sub03rea(port,socket,device) ; + n string,stop,eor,substring,timeout + s string="" + s stop=0 + s eor=0 + u device:(SOCKET=socket) + f d i stop!eor q + . r substring:60 s timeout='$t + . i $device'=0 d logMessage("Error reading from socket #"_socket_" $device="_$device,1,port) s stop=1 q + . d logMessage("Substring: "_substring,3,port) + . s string=string_substring + . i timeout d logMessage("Client timeout, for socket #"_socket,1,port) s stop=1 q + . i $key=$c(10) s eor=1 q + i stop q "%STOP" + q string + + + ; Execute script +exec ; + n requestUri,scriptName,mRoutine + ; + i $d(^serverLink("REST")) s mRoutine=^serverLink("REST") + e d + . ; Apache Server + . s requestUri=$g(%ENV("REQUEST_URI")) + . ; + . ; Microsoft IIS or PWS + . i requestUri="" s requestUri=$g(%ENV("SCRIPT_NAME"))_"?"_$g(%ENV("QUERY_STRING")) + . ; + . d logMessage("RequestUri="_requestUri,1,port) + . d logMessage("PostData="_$g(%ENV("POST_DATA")),1,port) + . s scriptName=$p(requestUri,"?",1) + . s mRoutine=$p($p(scriptName,"/",$l(scriptName,"/")),".",1) ; Can use any file extension + . i $e(mRoutine,1,4)="nph-" s mRoutine=$e(mRoutine,5,999) ; Strip non-parsed header prefix + ; + ; Unless it is a percent routine then execute it + i mRoutine'="",$e(mRoutine,1)'="%" d + . i mRoutine'?1.AN.1".".AN Q ;; L2021 security fix - only allow AN with possibly one "." + . n (mRoutine,%ENV) + . i $g(%ENV("REMOTE_ADDR"))'="",$G(^serverLink("Serenji",%ENV("REMOTE_ADDR"))),'$$DEBUG^%Serenji("^"_mRoutine,%ENV("REMOTE_ADDR")) q + . d @("^"_mRoutine) + ; + q + + + ; Authenticate that the request has come from a trusted source. + ; If the pass-phrase matches then ok, otherwise log error. + ; Allow multiple pass-phrases so that multiple different servers can connect etc. + ; Authentication string restricted to 60 text characters to prevent or type errors + ; which may be attempts to breach security. +authentic(%ENV,port,logLevel) ; + n auth + s auth=$g(%ENV("GJS_SERVERLINK_AUTH")) + i auth?1.60anp,$d(^serverLink("GJS_SERVERLINK_AUTH",auth)) d q 1 + . d logMessage("Authenticated connection from: "_^serverLink("GJS_SERVERLINK_AUTH",auth),2,port) + . k %ENV("GJS_SERVERLINK_AUTH") ; Delete pass-phrase to reduce window of opportunity + d logMessage("Unauthenticated web-server: "_auth,0,port) + q 0 + + + ; Check whether a stop signal has been sent +checkStop() ; + q $d(^serverLink("stop"))'=0 + + + ; Log a message (to the console for now) +logMessage(string,importance,port) ; + i $d(logLevel),importance>logLevel q + s ^serverLink("log",port)=$g(^serverLink("log",port))+1 + s ^serverLink("log",port,^serverLink("log",port))=$h_" "_$j_" "_string + q + + + ; Method to set the stop flag +setStop(port) ; + s ^serverLink("stop")=1 + q + + + ; Error handler +error n error + ; + s error=$ze + i $zv["GT.M" s error=$zstatus + ; + i $zv["Cache" s $ec="" + i $zv["HBOM" s $ec="" + i $zv["M21" s $ec="" + ; + s $ze="" + ; s $zt="bigError" + ; + ; Log all errors + d logMessage("Error: "_error,0,$g(port,"")) + ; + ; If development/debug then dump the error to the user + i '$d(^serverLink("debug")) q + ; + d header^http + ; + w "",! + w "
",! + w $$htmlEscape(error),! + w "
",! + d int^symbolTable + ; + w "",! + q + + + ; Error handling an error +bigError n bigError + s bigError=$ze + i $zv["GT.M" s error=$zstatus + ; + i $zv["Cache" s $ec="" + i $zv["HBOM" s $ec="" + i $zv["M21" s $ec="" + ; + s $ze="" + s $zt="" + ; + d logMessage("Big error "_bigError_" handling error "_$g(error),0,$g(port,"")) + q + + +htmlEscape(string) ; + s string=$$substitute(string,"&","&") + s string=$$substitute(string,"<","<") + s string=$$substitute(string,">",">") + q string + + +substitute(string,replace,with) ; + f q:string'[replace s string=$p(string,replace,1)_with_$p(string,replace,2,$l(string,replace)) + q string + + + ; Acceptable client versions +clientVersion(version) ; + i version="serverLink.cgi/1.4" q 1 + q 0 + + + ; Server version +serverVersion() q "r.serverLink/1.4" + + + ; Setup Pass-phrase for server access +setup ; + n auth,desc,newDesc + w !,"Configure authenticated web-servers" + ; +setup1 w !,"Pass-phrase? " r auth i auth="" q + i auth="?" d g setup1 + . w !!,"Pass-phrase",?15,"Description" + . s auth="" + . f d i auth="" q + . . s auth=$o(^serverLink("GJS_SERVERLINK_AUTH",auth)) i auth="" q + . . w !,"***",?15,^serverLink("GJS_SERVERLINK_AUTH",auth) + i auth'?1.60anp w " invalid" g setup1 + s desc=$g(^serverLink("GJS_SERVERLINK_AUTH",auth)) + w !,"Web-server description " + i desc'="" w "<",desc,"> " + r newDesc + i newDesc="" s newDesc=desc w newDesc + i newDesc'=" " s ^serverLink("GJS_SERVERLINK_AUTH",auth)=newDesc + e k ^serverLink("GJS_SERVERLINK_AUTH",auth) w " deleted" + g setup1 + + + ; Enable Serenji hook for serverLink requests coming from a browser at + ; a specified IP address. Default is same address as my interactive login +debugOn(addr) ; + i $g(addr)="" s addr=$$IAM^%Serenji + q:addr="" + s ^serverLink("Serenji",addr)=1 + q + + + ; Disable Serenji hook for serverLink requests coming from a browser at + ; a specified IP address. Default is same address as my interactive login +debugOff(addr) ; + i $g(addr)="" s addr=$$IAM^%Serenji + q:addr="" + k ^serverLink("Serenji",addr) + q + diff --git a/session.m b/session.m new file mode 100644 index 0000000..a620261 --- /dev/null +++ b/session.m @@ -0,0 +1,43 @@ +session ; Session Class + +establish() ; Public ; Establish an existing session or create a new one + ; + n session,cookie + ; + s session="" + ; + ; Get existing session if there is one + s cookie=$g(%ENV("HTTP_COOKIE")) + i cookie'="" d + . s session=$p($p(cookie,"_osm_session=",2),";",1) + . i session'="",'$d(^session(session)) s session="" ; Non-existant session + ; + ; If no existing session then create one + i session="" d + . f s session=$$token(32) i '$d(^session(session)) q + . s ^session(session,"createdAt")=$h + ; + ; Increment session counter + s ^session(session,"count")=$g(^session(session,"count"))+1 + ; + q session + + +cookie ; Public ; Give the client a cookie containing the existing session + ; + ; TODO: Add expiry data if user asked to be remembered + ; + w "Set-cookie: _osm_session="_%session_"; path=/; HttpOnly",! + ; + q + + +token(length) ; Generate random token + ; + n token,i + ; + s token="" + f i=1:1:length s token=token_$e("abcdefghijklmnopqrstuvwxyz0123456789",$r(35)+1) + q token + + diff --git a/shutdown.m b/shutdown.m new file mode 100644 index 0000000..2ecfb0d --- /dev/null +++ b/shutdown.m @@ -0,0 +1,20 @@ +shutdown ; Shutdown osmxapi services + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + d setStop^serverLink() + ;s ok=$$STOP^%SerenjL(4321) + q diff --git a/startup.m b/startup.m new file mode 100644 index 0000000..50c0fce --- /dev/null +++ b/startup.m @@ -0,0 +1,31 @@ +startup ; ServerLink startup + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + j start^serverLink(6520) + s ok=$$START^%SerenjL(4321) + q diff --git a/stats.m b/stats.m new file mode 100644 index 0000000..0a5b4e9 --- /dev/null +++ b/stats.m @@ -0,0 +1,60 @@ +stats ; Display some stats + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + + d header^http("text/xml") + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + ; + w "",! + ; + f x=20:20:180 w "",! + ; + f y=50:50:700 w "",! + ; + s column=0 + s oldCount=0 + s date="20071129" + f d i date="" q + . s date=$o(^total("date",date)) i date="" q + . s count=^total("date",date,"item",20,"distinct") + . s difference=count-oldCount + . s oldCount=count + . s column=column+1 + . s pubs=^total("date",date,"item",5,"count")-6500/20 + . s churches=^total("date",date,"item",7,"count")-6500/20 + . d bar(column,difference,"green") + . ;d bar(column,pubs,"red") + . ;d bar(column,churches,"blue") + w "",! + q +bar(column,value,class) ; + w "",! + q diff --git a/status.m b/status.m new file mode 100644 index 0000000..6b7ed0e --- /dev/null +++ b/status.m @@ -0,0 +1,579 @@ +status ; XAPI Server Status + ; This program is free software: you can redistribute it and/or modify + ; Copyright (C) 2009 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + ; Quasi mapReduce stuff + d map^mapReduce("status") + d reduce^mapReduce("status") + ; + d header^http("text/html") + ; + w "",! + w "",! + w "XAPI Status for ",^osmPlanet("instance"),"",! + w "" + w "",! + + w "",! + w "",! + ; + w "
",! + w "",! + ; + ; Summary table header + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"logId")) q + . w "",! + w "",! + ; + ; Generate row for total requests + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"logId")) q + . w "",! + w "",! + ; + ; Generate row for average response time + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"logId")) q + . s responseTime=$g(^status("server",instance,"munin","responseTotal"),1)/$g(^status("server",instance,"munin","apiCalls"),1) + . w "",! + w "",! + ; + ; Generate row for active requests across all servers + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"logId")) q + . w "",! + w "",! + ; + w "
Summary",instance,"
Total requests:",$fn($g(^status("server",instance,"logId")),","),"
Average response time:",$j(responseTime,0,2),"
Active requests:",^status("server",instance,"activeProcesses"),"/",^status("server",instance,"totalProcesses"),"
",! + w "
",! + ; + ; Recent and active requests + d active + ; + ; Import table + w "
",! + w "",! + ; + ; Summary table header + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . w "",! + w "",! + ; + ; Generate row for source + ; w "",! + ; w "",! + ; s instance="" + ; f d i instance="" q + ; . s instance=$o(^status("loadDiff",instance)) i instance="" q + ; . w "",! + ; w "",! + ; + ; Generate row for last File + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . s lastFile=$g(^status("server",instance,"loadDiff","lastFile"),"000000000") + . w "",! + w "",! + ; + ; Generate row for diff timestamp + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . w "",! + w "",! + ; + w "",! + w "",! + s instance="" + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . s files=^status("server",instance,"loadDiff","files") + . s lines=^status("server",instance,"loadDiff","lines")/files + . w "",! + w "",! + ; + w "",! + w "",! + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . s files=^status("server",instance,"loadDiff","files") + . s modified=^status("server",instance,"loadDiff","modified")/files + . w "",! + w "",! + ; + w "",! + w "",! + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . s files=^status("server",instance,"loadDiff","files") + . s deleted=^status("server",instance,"loadDiff","deleted")/files + . w "",! + w "",! + ; + w "",! + w "",! + f d i instance="" q + . s instance=$o(^status("server",instance)) i instance="" q + . i '$d(^status("server",instance,"loadDiff")) q + . s files=^status("server",instance,"loadDiff","files") + . s duration=^status("server",instance,"loadDiff","duration")/files + . w "",! + w "",! + ; + w "
Data import",instance,"
Source ",$g(^status("loadDiff",instance,"url")),"
Last file ",$e(lastFile,1,3),"/",$e(lastFile,4,6),"/",$e(lastFile,7,9),".osc","
Timestamp ",$g(^status("server",instance,"loadDiff","timestamp")),"
Average file length",$j(lines,0,0)," lines","
Average updates per file",$j(modified,0,0)," elements
Average deletions per file",$j(deleted,0,0)," elements
Average processing time",$$minutes(duration),"
",! + w "
",! + ; + d userAgentByRequest + d userAgentBySize + ; + w "",! + w "",! + q + + +loadCounts(count) ; Private ; Get diff load counts for the last 100 files + ; + n lines,delete,modify,files,duration + n file + ; + s duration=0 + s delete=0 + s modify=0 + s lines=0 + s files=0 + ; + k count + s count("duration")=0 + s count("deleted")=0 + s count("modified")=0 + s count("lines")=0 + s count("files")=0 + ; + s file="" + f d i file="" q + . s file=$o(^loadDiff(file)) i file="" q + . i file'?.e1".osc" q + . s files=files+1 + . s lines=lines+$g(^loadDiff(file,"totalLines")) + . s modify=modify+$g(^loadDiff(file,"totalNodesModified")) + . s modify=modify+$g(^loadDiff(file,"totalWaysModified")) + . s modify=modify+$g(^loadDiff(file,"totalRelationsModified")) + . s delete=delete+$g(^loadDiff(file,"totalNodesDelete")) + . s delete=delete+$g(^loadDiff(file,"totalWaysDeleted")) + . s delete=delete+$g(^loadDiff(file,"totalRelationsDeleted")) + . i $g(^loadDiff(file,"duration"))>0 s duration=duration+$g(^loadDiff(file,"duration")) ; Skip negative durations + ; + ; Counts + s count("duration")=duration + s count("deleted")=delete + s count("modified")=modify + s count("lines")=lines + s count("files")=files + q + + +active ; Current active requests + ; + n sAge,logId,count + ; + w "
",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + ; + s count=0 + ; + s sAge="" + f d i sAge="" q + . s sAge=$o(^status("log",sAge)) i sAge="" q + . s logId="" + . f d i logId="" q + . . s logId=$o(^status("log",sAge,logId)) i logId="" q + . . s ps=$g(^status("log",sAge,logId,"ps")) + . . s count=count+1 + . . i (ps'="")!(count<999) d displayTask(sAge,logId) + ; + w "
AgeServerLogIdpidQueryUser AgentExtentTimeElements
",! + w "
",! + q + + +displayTask(sAge,logId) ; + ; + n hNow,sNow,query,start,age,pid,age,extent,userAgent,count,colour,title + ; + ; + s instance=$g(^status("log",sAge,logId,"instance")) + ; + s hNow=$g(^status("server",instance,"now")) + s sNow=$p(hNow,",",1)*86400+$p(hNow,",",2) + ; + s query=$g(^status("log",sAge,logId,"request")) + s start=$g(^status("log",sAge,logId,"start")) s start=$p(start,",",1)*86400+$p(start,",",2) + s age=$$minutes(sNow-start) + s end=$g(^status("log",sAge,logId,"end"),hNow) s end=$p(end,",",1)*86400+$p(end,",",2) + s pid=$g(^status("log",sAge,logId,"pid")) + s ps=$g(^status("log",sAge,logId,"ps")) + s time=$$minutes(end-start) + s extent=17-$l($g(^status("log",sAge,logId,"qs"))) i extent=17 s extent=0 + s userAgent=$g(^status("log",sAge,logId,"userAgent")) + s count=$g(^status("log",sAge,logId,"count"),0) + ; + s colour="white",title="" + i ps'="" s colour="blue",title=ps + w "",! + w "",$$minutes(sAge),"",! + w "",instance,"",! + w "",logId,"",! + w "",pid,"",! + w "",query,"",! + w "",userAgent,"",! + w "",extent,"",! + w "",time,"",! + w "",count,"",! + w "",! + ; + q + +minutes(seconds) ; Convert seconds to minutes + q (seconds)\60_":"_$e(100+((seconds)#60),2,3) + + +processes(ps) ; Get status of zappy processes + ; + n temp,i,line,pid,io + ; + k ps + s ps=0 + s io=$i + ; + s temp="/tmp/xapi_status"_$j_".tmp" + zsystem "ps -Al|grep "_^osmPlanet("instance")_" >"_temp + ; + o temp:READ + s $zt="g eof" + f i=1:1 u temp r line s pid=$tr($e(line,10,15)," ","") i pid'="" s ps(pid)=line,ps=ps+1 +eof s $zt="",$ze="" c temp + ; + zsystem "rm "_temp + u io + q + + +userAgentByRequest ; Display UserAgents by Requests + ; + n active,r,logId + s global="^%logStats" + ; + w "
",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + w "",! + ; + ; Iterate the user agents by log frequency + s log="" + f d i log="" q + . s log=$o(^status("byLog",log),-1) i log="" q + . i log<100 s log="" q + . s agent="" + . f d i agent="" q + . . s agent=$o(^status("byLog",log,agent)) i agent="" q + . . s count=^status("byAgent",agent,"count") + . . s qsl=^status("byAgent",agent,"qsl") + . . s duration=^status("byAgent",agent,"duration") + . . s title="Sample request: "_$g(^status("byAgent",agent,"sampleRequest"))_" Sample UserAgent: "_$g(^status("byAgent",agent,"sampleUserAgent")) + . . w "",! + . . i $d(^userAgent(agent,"url")) w "",! + . . e w "",! + . . w "",! + . . w "",! + . . w "",! + . . w "",! + . . w "",! + ; + w "
User AgentRequestsAverage sizeExtentResponse time
",agent,"",agent,"",$fn(log,","),"",$fn(count/log,",",0),"",$fn(qsl/log*6.25,",",2),"%",$fn(duration/log,",",2),"
",! + w "
",! + q + + +userAgentBySize ; Display UserAgents by Size of request + ; + n active,r,logId + s instance=^osmPlanet("instance") + ; + w "
",! + w "",! + w "",! + w "",! + w "",! + w "",! + ; + ; Iterate the user agents by size + s count="" + f d i count="" q + . s count=$o(^status("byCount",count),-1) i count="" q + . i count<1000 s count="" q + . s agent="" + . f d i agent="" q + . . s agent=$o(^status("byCount",count,agent)) i agent="" q + . . s log=^status("byAgent",agent,"log") + . . s title="Sample request: "_$g(^status("byAgent",agent,"sampleRequest"))_" Sample UserAgent: "_$g(^status("byAgent",agent,"sampleUserAgent")) + . . w "",! + . . i $d(^userAgent(agent,"url")) w "",! + . . e w "",! + . . w "",! + . . w "",! + . . w "",! + ; + w "
User AgentSizeRequests
",agent,"",agent,"",$fn(count,","),"",$fn(log,","),"
",! + w "
",! + q + + +mapReduce ; + d map^mapReduce("status") + d reduce^mapReduce("status") + q + + +mapInit q + + +mapFinal q + + +mapMain ; Build table of current active requests + ; + n active,activeProcesses,request,logId,ps,count + ; + s global="^%status"_^osmPlanet("instance") + s @global@("now")=$h + ; + ; Get array of active processes + d processes(.ps) + ; + k @global@("log") + ; + ; Create array of active tasks sorted by logId + ; As a by product, delete any dead tasks + s activeProcesses=0 + s request="" + f d i request="" q + . s request=$o(^requestx(request)) i request="" q + . s logId="" + . f d i logId="" q + . . s logId=$o(^requestx(request,logId)) i logId="" q + . . s pid=^log(logId,"pid") + . . i '$d(ps(pid)) k ^requestx(request,logId) q + . . s active(logId)="" + ; + ; Add most recent tasks to table + s logId="" + f i=1:1:10 d i logId="" q + . s logId=$o(^log(logId),-1) i logId="" q + . s pid=$g(^log(logId,"pid")) + . m @global@("log",logId)=^log(logId) + . i $d(ps(pid)) s @global@("log",logId,"ps")=ps(pid),activeProcesses=activeProcesses+1 + . k active(logId) + ; + ; Add any remaining active tasks to table + f d i logId="" q + . s logId=$o(active(logId),-1) i logId="" q + . s pid=$g(^log(logId,"pid")) + . s request=$g(^log(logId,"request")) + . m @global@("log",logId)=^log(logId) + . i $d(ps(pid)) s @global@("log",logId,"ps")=ps(pid),activeProcesses=activeProcesses+1 + ; + ; Logfile stats + i $d(^log) d + . s @global@("activeProcesses")=activeProcesses + . s @global@("totalProcesses")=ps + . s @global@("logId")=$g(^log) + . m @global@("munin")=^munin + ; + i $d(^loadDiff) d + . s @global@("loadDiff","url")=$g(^loadDiff("url"),"None") + . s @global@("loadDiff","lastFile")=$g(^loadDiff("lastFile"),"000000000") + . s @global@("loadDiff","timestamp")=$g(^loadDiff("timestamp"),"Never run") + . ; + . d loadCounts(.count) + . m @global@("loadDiff")=count + ; + q + + +userAgentStatistics ; Public ; Build log file ua stats + ; + k ^tempStatus($j) + s l="" + f d i l="" q + . s l=$o(^log(l)) i l="" q + . s ua=$g(^log(l,"userAgent")) + . s count=$g(^log(l,"count")) + . s agent=$p($p(ua," ",1),"/",1) i agent="" s agent="unknown" + . s duration=$g(^log(l,"duration")) i duration<0 s duration=0 + . s qs=$g(^log(l,"qs")) + . s qsl=16-$l(qs) + . s ^tempStatus($j,"byAgent",agent,"log")=$g(^tempStatus($j,"byAgent",agent,"log"))+1 + . s ^tempStatus($j,"byAgent",agent,"count")=$g(^tempStatus($j,"byAgent",agent,"count"))+count + . s ^tempStatus($j,"byAgent",agent,"qsl")=$g(^tempStatus($j,"byAgent",agent,"qsl"))+qsl + . s ^tempStatus($j,"byAgent",agent,"duration")=$g(^tempStatus($j,"byAgent",agent,"duration"))+duration + . s ^tempStatus($j,"byAgent",agent,"sampleRequest")=$g(^log(l,"request")) + . s ^tempStatus($j,"byAgent",agent,"sampleUserAgent")=$g(^log(l,"userAgent")) + ; + s global="^%status"_^osmPlanet("instance") + k @global@("byAgent") + m @global@("byAgent")=^tempStatus($j,"byAgent") + q + + +reduceInit ; Public ; Initialize log file reduction + ; + k ^status + ; + q + + +reduceMain(key,global) ; Public ; Reduce a log file + ; + n hNow,sNow,agent,logId,hStart,sStart,sAge + ; + ; Make all the unreduced data available + m ^status("server",key)=@global + ; + ; hNow is the time on the originating server. Servers will be in various timezones, and their clocks may be out by a bit, + ; so always measure time relative to hNow on the originating server. + s hNow=@global@("now") + s sNow=$p(hNow,",",1)*86400+$p(hNow,",",2) + ; + ; Consolidate each instance of log stats into a single log stats file + s agent="" + f d i agent="" q + . s agent=$o(@global@("byAgent",agent)) i agent="" q + . s ^status("byAgent",agent,"count")=$g(^status("byAgent",agent,"count"))+@global@("byAgent",agent,"count") + . s ^status("byAgent",agent,"duration")=$g(^status("byAgent",agent,"duration"))+@global@("byAgent",agent,"duration") + . s ^status("byAgent",agent,"log")=$g(^status("byAgent",agent,"log"))+@global@("byAgent",agent,"log") + . s ^status("byAgent",agent,"qsl")=$g(^status("byAgent",agent,"qsl"))+@global@("byAgent",agent,"qsl") + . s ^status("byAgent",agent,"sampleRequest")=@global@("byAgent",agent,"sampleRequest") + . s ^status("byAgent",agent,"sampleUserAgent")=@global@("byAgent",agent,"sampleUserAgent") + ; + ; Sort active log entries by age + s logId="" + f d i logId="" q + . s logId=$o(@global@("log",logId)) i logId="" q + . s hStart=@global@("log",logId,"start"),sStart=$p(hStart,",",1)*86400+$p(hStart,",",2) + . s sAge=sNow-sStart + . m ^status("log",sAge,logId)=@global@("log",logId) + . s ^status("log",sAge,logId,"instance")=key ; Note which server this log entry came from + ; + q + + +reduceFinal ; Public ; Finalize a log file reduction + ; + n agent,instance + n logId,activeProcesses,totalProcesses,apiCalls,responseTotal + ; + ; Build byCount and byLog indexes from byAgent stats + ; + s agent="" + f d i agent="" q + . s agent=$o(^status("byAgent",agent)) i agent="" q + . s log=^status("byAgent",agent,"log") + . s count=^status("byAgent",agent,"count") + . s ^status("byCount",count,agent)="" + . s ^status("byLog",log,agent)="" + ; + ; Create log total (if there is more than one instance) + s instance=$o(^status("server","")) i $o(^status("server",instance))'="" d + . ; + . s logId=0 + . s activeProcesses=0 + . s totalProcesses=0 + . s apiCalls=0 + . s responseTotal=0 + . ; + . s instance="" + . f d i instance="" q + . . s instance=$o(^status("server",instance)) i instance="" q + . . i '$d(^status("server",instance,"logId")) q + . . s logId=logId+^status("server",instance,"logId") + . . s activeProcesses=activeProcesses+^status("server",instance,"activeProcesses") + . . s totalProcesses=totalProcesses+^status("server",instance,"totalProcesses") + . . s apiCalls=apiCalls+^status("server",instance,"munin","apiCalls") + . . s responseTotal=responseTotal+^status("server",instance,"munin","responseTotal") + . ; + . s ^status("server","Total","logId")=logId + . s ^status("server","Total","activeProcesses")=activeProcesses + . s ^status("server","Total","totalProcesses")=totalProcesses + . s ^status("server","Total","munin","apiCalls")=apiCalls + . s ^status("server","Total","munin","responseTotal")=responseTotal + q diff --git a/stream.m b/stream.m new file mode 100644 index 0000000..d201f26 --- /dev/null +++ b/stream.m @@ -0,0 +1,87 @@ +stream ; Stream Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +openFile(stream,fileName) ; Public ; Create a stream object for a file and open the stream + ; + o fileName:READ + ; + s stream("current")="" + s stream("fileName")=fileName + s stream("recordCount")=0 + s stream("type")="file" + ; + q + + +openPipe(stream,fileName) ; Public ; Create a stream object for a pipe and open the stream + ; + o fileName:FIFO + ; + s stream("current")="" + s stream("fileName")=fileName + s stream("recordCount")=0 + s stream("type")="pipe" + ; + q + + +openPayload(stream) ; Public ; Create a stream object for an http payload + ; + s stream("current")="" + s stream("i")="" + s stream("recordCount")=0 + s stream("type")="payload" + ; + q + + + +read(stream) ; Public ; Read a record from a stream + ; + n line + ; + ; Get the next line + i stream("type")="payload" d + . s stream("i")=$o(^serverLink("payload",$j,stream("i"))) i stream("i")="" s line="" q + . s line=^serverLink("payload",$j,stream("i")) + e u stream("fileName") r line + ; + s stream("current")=line + s stream("recordCount")=stream("recordCount")+1 + ; + q line + + +close(stream) ; Public ; Close the stream and destroy the stream object + ; + i stream("type")="payload" ; no-op + e c stream("fileName") + k stream + q + + +eof(stream) ; Public ; End of File? + ; + n eof + ; + s eof=0 + i stream("type")="payload",stream("i")="" s eof=1 + i stream("type")="pipe" w 1/0 ; TODO + i stream("type")="file" w 1/0 ; TODO + q eof + + diff --git a/streamx.m b/streamx.m new file mode 100644 index 0000000..683121f --- /dev/null +++ b/streamx.m @@ -0,0 +1,74 @@ +streamx ; Stream Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + +openFile(stream,fileName) ; Public ; Create a stream object for a file and open the stream + ; + o fileName:READ + ; + s stream("current")="" + s stream("fileName")=fileName + s stream("recordCount")=0 + s stream("buffer")="" + ; + q + + +openPipe(stream,fileName) ; Public ; Create a stream object for a pipe and open the stream + ; + o fileName:FIFO + ; + s stream("current")="" + s stream("fileName")=fileName + s stream("recordCount")=0 + s stream("buffer")="" + ; + q + + +read(stream) ; Public ; Read a record from a stream + ; + n line + ; + u stream("fileName") r line + s stream("current")=line + s stream("recordCount")=stream("recordCount")+1 + ; + q line + +readx(stream) ; Public ; Read buffered data from a stream + ; + n line,data + ; + ; Keep the buffer filled (between 10,000 and 20,000 bytes) + i $l(stream("buffer"))<10000 d + . u stream("fileName") r line#10000 i $l(line)=0 q + . s stream("buffer")=stream("buffer")_line + ; + ; Read up to the next >< delimited point + i stream("buffer")'["><" s data=stream("buffer") ; Should be end of file (I hope) + e s data=$p(stream("buffer"),"><",1)_">",stream("buffer")=$e(stream("buffer"),$l(data)+1,30000) + s stream("recordCount")=stream("recordCount")+1 + ; + q data + +close(stream) ; Public ; Close the stream and destroy the stream object + ; + c stream("fileName") + k stream + q + diff --git a/string.m b/string.m new file mode 100644 index 0000000..2715a86 --- /dev/null +++ b/string.m @@ -0,0 +1,62 @@ +string ; String Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + +contains(string,substring,delimiter) ; Public ; Does string contain substring + ; + q (delimiter_string_delimiter)[(delimiter_substring_delimiter) + + +upper(string) ; Public ; Convert string to upper case + q $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + + +lower(string) ; Public ; Convert string to lower case + q $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") + +toB64(txt) ; Public ; encode txt as base64 + n result,char64,pos,triple,bytenum,bits + s result="" + s char64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + f pos=1:3:$l(txt) d + . s triple=$e(txt,pos,pos+2) + . s bits=0 + . f bytenum=1:1:$l(triple) s bits=bits*256+$a(triple,bytenum) + . i bytenum=3 s result=result_$e(char64,bits\262144+1)_$e(char64,bits\4096#64+1)_$e(char64,bits\64#64+1)_$e(char64,bits#64+1) q + . i bytenum=2 s bits=bits*4,result=result_$e(char64,bits\4096+1)_$e(char64,bits\64#64+1)_$e(char64,bits#64+1)_"=" q + . s bits=bits*16,result=result_$e(char64,bits\64+1)_$e(char64,bits#64+1)_"==" + q result + + +fromB64(txt) ; Public ; Decode txt from base64 + n result,char64,pos,quad,bytenum,bits,worth + s result="" + s char64="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + f pos=1:4:$l(txt) d + . s quad=$e(txt,pos,pos+3) + . s bits=0 + . f bytenum=1:1:$l(quad) d q:worth<0 + . . s worth=$f(char64,$e(quad,bytenum))-2 + . . q:worth<0 + . . s bits=bits*64+worth + . i worth'<0 s result=result_$c(bits\65536,bits\256#256,bits#256) q + . i bytenum=4 s result=result_$c(bits\1024,bits\4#256) q + . i bytenum=3 s result=result_$c(bits\16) q + . n zer + . s zer="fromB64^%vc1str\Bad base64 input" + . d force^%vc9er + q result diff --git a/tempLoad.m b/tempLoad.m new file mode 100644 index 0000000..7ad196f --- /dev/null +++ b/tempLoad.m @@ -0,0 +1,30 @@ + ;d oneFile^loadDiff("20090624-20090625.osc") + ;d oneFile^loadDiff("20090625-20090626.osc") + ;d oneFile^loadDiff("20090626-20090627.osc") + ;d oneFile^loadDiff("20090627-20090628.osc") + ;d oneFile^loadDiff("20090628-20090629.osc") + ;d oneFile^loadDiff("20090629-20090630.osc") + ;d oneFile^loadDiff("20090630-20090701.osc") + ;d oneFile^loadDiff("20090701-20090702.osc") + ;d oneFile^loadDiff("20090702-20090703.osc") + ;d oneFile^loadDiff("20090703-20090704.osc") + ;d oneFile^loadDiff("20090704-20090705.osc") + ;d oneFile^loadDiff("20090705-20090706.osc") + ;d oneFile^loadDiff("20090706-20090707.osc") + ;d oneFile^loadDiff("20090707-20090708.osc") + ;d oneFile^loadDiff("20090708-20090709.osc") + ;d oneFile^loadDiff("20090709-20090710.osc") + ;d oneFile^loadDiff("20090710-20090711.osc") + ;d oneFile^loadDiff("20090711-20090712.osc") + ;d oneFile^loadDiff("20090712-20090713.osc") + ;d oneFile^loadDiff("20090713-20090714.osc") + ;d oneFile^loadDiff("20090714-20090715.osc") + ;d oneFile^loadDiff("20090715-20090716.osc") + ;d oneFile^loadDiff("20090716-20090717.osc") + ;d oneFile^loadDiff("20090717-20090718.osc") + ;d oneFile^loadDiff("20090718-20090719.osc") + d oneFile^loadDiff("20090719-20090720.osc") + d oneFile^loadDiff("20090720-20090721.osc") + d oneFile^loadDiff("20090721-20090722.osc") + d oneFile^loadDiff("20090722-20090723.osc") + q diff --git a/test.m b/test.m new file mode 100644 index 0000000..a4fd3ce --- /dev/null +++ b/test.m @@ -0,0 +1,38 @@ +test ; + n $zt + s $zt="s $zroutines="""_$zroutines_""" d error^test zgoto "_($zlevel-1) + w !,"start" + d sub1 + w !,"end" + q + +sub1 w !,"sub1 - start" + d sub2 + w !,"sub2 - end" + q + +sub2 w !,"sub2 - start" + w 1/0 + w !,"sub2 - end" + q + + +error ; + s $ze="" + w !,"error^test" + w !,$zstatus + ; + q + + + +open s f="gaga.txt" + o f:(READ:EXCEPTION="g fail") + u 0 w "opened" + c f + q + +fail u 0 w "fail" + q + + diff --git a/tgj1.m b/tgj1.m new file mode 100644 index 0000000..65d78c8 --- /dev/null +++ b/tgj1.m @@ -0,0 +1,265 @@ +tgj1 ; File convert ^changeset + ; + s c=$g(^tgj1("changeset")) + f count=1:1 d i c="" q + . s c=$o(^changeset(c),-1) i c="" q + . s n="" + . f d i n="" q + . . s n=$o(^changeset(c,"n",n)) i n="" q + . . s v="" + . . f d i v="" q + . . . s v=$o(^changeset(c,"n",n,"v",v)) i v="" q + . . . i $d(^changeset(c,"n",n,"v",v,"a")) q + . . . s uid=$g(^changeset(c,"n",n,"v",v,"t","@uid")) + . . . s timestamp=$g(^changeset(c,"n",n,"v",v,"t","@timestamp")) + . . . s visible=$g(^changeset(c,"n",n,"v",v,"t","@visible")) + . . . s fork=$g(^changeset(c,"n",n,"v",v,"t","@fork")) + . . . s a=v_$c(1)_c_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_fork + . . . s ^changeset(c,"n",n,"v",v,"a")=a + . . . s t="" + . . . f d i t="" q + . . . . s t=$o(^changeset(c,"n",n,"v",v,"t",t)) i t="" q + . . . . i $e(t,1)'="@" d + . . . . . s u=$$tag(t) + . . . . . s ^changeset(c,"n",n,"v",v,"u",u)=^changeset(c,"n",n,"v",v,"t",t) + . . . . k ^changeset(c,"n",n,"v",v,"t",t) + . i count#1000=0 s ^tgj1("changeset")=c + q + + + + + ; Get internal value for the key or assign one +tag(key) ; + n u + s u=$g(^keyx(key)) + i u="" d + . l +^key + . s (u,^key)=^key+1 + . s ^key(u)=key + . s ^keyx(key)=u + . l -^key + q u + + + +nodes ; File convert nodes in ^element + s qs=$g(^tgj1("qs")) + s count=0,done=0 + f d i (qs="")!done q + . s qs=$o(^element(qs)) i qs="" q + . s n="" + . f d i n="" q + . . s n=$o(^element(qs,"n",n)) i n="" q + . . s count=count+1 + . . i $d(^element(qs,"n",n,"a")) q + . . s changeset=$g(^element(qs,"n",n,"t","@changeset")) + . . s timestamp=$g(^element(qs,"n",n,"t","@timestamp")) + . . s uid=$g(^element(qs,"n",n,"t","@uid")) + . . s version=$g(^element(qs,"n",n,"t","@version")) + . . s visible=$g(^element(qs,"n",n,"t","@visible")) + . . s fork=$g(^element(qs,"n",n,"t","@fork")) + . . s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid_$c(1)_visible_$c(1)_fork + . . s ^element(qs,"n",n,"a")=a + . . s t="" + . . f d i t="" q + . . . s t=$o(^element(qs,"n",n,"t",t)) i t="" q + . . . i $e(t,1)'="@" d + . . . . s u=$$tag(t) + . . . . s ^element(qs,"n",n,"u",u)=^element(qs,"n",n,"t",t) + . . k ^element(qs,"n",n,"t") + . i count#1000=0 s ^tgj1("qs")=qs + q + +integ ; + ; For the highest version of each node, check that all tags in ^element are also present in ^changeset + ; Any tag in ^element that is not in ^changeset should be deleted + ; + s count=0,fixed=0 + s c=$g(^tgj1("changeset")) + f d i c="" q + . s c=$o(^changeset(c),-1) i c="" q + . d integ1(c) + . s count=count+1 + . i count#100=0 s ^tgj1("changeset")=c,^tgj1("fixed")=fixed + s ^tgj1("done")=1 + s ^tgj1("fixed")=fixed + q + + +integ1(c) ; + d + . s n="" + . f d i n="" q + . . s n=$o(^changeset(c,"n",n)) i n="" q + . . s v=$o(^nodeVersion(n,"v",""),-1) + . . i '$d(^changeset(c,"n",n,"v",v)) q ; Not the latest version in this changeset + . . s qs=^nodeVersion(n,"q") + . . i '$d(^element(qs,"n",n)) q ; Element missing, probably a deletion + . . s u="" + . . f d i u="" q + . . . s u=$o(^element(qs,"n",n,"u",u)) i u="" q + . . . i $d(^changeset(c,"n",n,"v",v,"u",u)) q ; tag exists on latest version of element, so ok + . . . ; w !,"Changeset: ",c,?20," Node: ",n,?40,^key(u),?60,^element(qs,"n",n,"u",u) + . . . s fixed=fixed+1 + . . . s value=^element(qs,"n",n,"u",u) + . . . i $l(value)>100 s value=$e(value,1,100)_".." + . . . s k=^key(u) + . . . k ^element(qs,"n",n,"u",u) + . . . i value'="" k ^nodex(k,value,qs,n) + . . . k ^nodex(k,"*",qs,n) + q + + + +nol ; Look for elements that have an a node but no l node + s qs=$g(^tgj1("qs")) + s count=0 + f d i qs="" q + . s qs=$o(^element(qs)) i qs="" q + . s n="" + . f d i n="" q + . . s n=$o(^element(qs,"n",n)) i n="" q + . . s count=count+1 + . . i '$d(^element(qs,"n",n,"l")) s ^tgj1("nol",qs,n)="" + . . i '$d(^element(qs,"n",n,"a")) s ^tgj1("noa",qs,n)="" + . i count#1000=0 s ^tgj1("qs")=qs + q + + +nolfix ; + s qs="" + f d i qs="" q + . s qs=$o(^tgj1("nol",qs)) i qs="" q + . s n="" + . f d i n="" q + . . s n=$o(^tgj1("nol",qs,n)) i n="" q + . . i $d(^element(qs,"n",n,"a")),'$d(^element(qs,"n",n,"l")) k ^element(qs,"n",n,"a") w "." + q + + + +findDeletedNodes ; + s w=$g(^tgj1("way")) + s count=0 + f d i w="" q + . s w=$o(^way(w)) i w="" q + . s count=count+1 i count#1000=0 s ^tgj1("way")=w + . s s="" + . f d i s="" q + . . s s=$o(^way(w,s)) i s="" q + . . s n=^way(w,s) + . . s v=$o(^nodeVersion(n,"v",""),-1) i v="" s ^tgjBad(w,n)="no versions" q + . . s c=^nodeVersion(n,"v",v) + . . i '$d(^changeset(c,"n",n)) s ^tgjBad(w,n)="Missing changeset "_c q + . . i $p(^changeset(c,"n",n,"v",v,"a"),$c(1),5)="false" s ^tgjBad(w,n)="Deleted node in "_c q + q + +fixDeletedNodes ; + s w="" + f d i w="" q + . s w=$o(^tgjBad(w)) i w="" q + . s n="" + . f d i n="" q + . . s n=$o(^tgjBad(w,n)) i n="" q + . . ; + . . ; Remove deleted version + . . s v=$o(^nodeVersion(n,"v",""),-1) i v="" q + . . s v1=$o(^nodeVersion(n,"v",v),-1) i v1="" q + . . s c=^nodeVersion(n,"v",v) + . . k ^nodeVersion(n,"c",c,v) + . . k ^nodeVersion(n,"v",v) + . . s c1=^nodeVersion(n,"v",v1) + . . ; + . . ; Reinstate prior version (v1) + . . d addNodeFromChangeset^node(c1,n,v1) + . . ; + . . ; Remove from bad list + . . k ^tgjBad(w,n) + q + +fixDeletedNodes1 ; Fix deleted nodes with no predecessor + s w="" + f d i w="" q + . s w=$o(^tgjBad(w)) i w="" q + . s n="" + . f d i n="" q + . . s n=$o(^tgjBad(w,n)) i n="" q + . . ; + . . ; Remove deleted version + . . s v=$o(^nodeVersion(n,"v",""),-1) i v="" q + . . s v1=$o(^nodeVersion(n,"v",v),-1) i v1'="" q + . . s c=^nodeVersion(n,"v",v) + . . s q=^nodeVersion(n,"q") + . . ; + . . ; Some nodes may already have been saved from deletion + . . i $d(^element(q,"n",n)) s ^tgjBad(w,n,"status")="not deleted" q + . . ; + . . ; Reinstate deleted version + . . d addNodeFromChangeset(c,n,v) + . . ; + . . ; Remove from bad list + . . k ^tgjBad(w,n) + q + +addNodeFromChangeset(changeset,nodeId,version) ; Public ; Add a node from a changeset + ; + n qsOld,a,timestamp,delete,qsNew,l + n u,key,value,intValue + ; + s qsOld=$g(^nodeVersion(nodeId,"q")) + ; + s a=^changeset(changeset,"n",nodeId,"v",version,"a") + s $p(a,$c(1),5)="" ; Unset the delete flag + s timestamp=$p(a,$c(1),3) + s delete=($p(a,$c(1),5)="false") + s qsNew=$p(a,$c(1),7) + s l=^changeset(changeset,"n",nodeId,"v",version,"l") + ; + ; Old changesets don't have the qs stored on them + i qsNew="" s qsNew=$$llToQs^quadString($p(l,$c(1),1),$p(l,$c(1),2)) + ; + ; Update - node + i 'delete d + . ; + . ; If the qs key has changed then delete the old entries + . i qsOld'="",qsOld'=qsNew d + . . k ^element(qsOld,"n",nodeId,"l") + . . k ^element(qsOld,"n",nodeId,"a") + . ; + . ; Update the node with new values + . s ^element(qsNew,"n",nodeId,"l")=l + . s ^element(qsNew,"n",nodeId,"a")=$p(a,$c(1),1,6) + ; + ; Update - changeset by version index + s ^nodeVersion(nodeId,"q")=qsNew + s ^nodeVersion(nodeId,"v",version)=changeset + s ^nodeVersion(nodeId,"c",changeset,version)="" + ; + ; Update process elements + s u="" + f d i u="" q + . s u=$o(^changeset(changeset,"n",nodeId,"v",version,"u",u)) i u="" q + . s value=^changeset(changeset,"n",nodeId,"v",version,"u",u) + . d addTagFromChangeset^node(qsOld,qsNew,nodeId,u,value,changeset,version,delete) + ; + ; Delete all tags that are not on the new version of the node + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^element(qsOld,"n",nodeId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^changeset(changeset,"n",nodeId,"v",version,"u",u)) q + . s value=^element(qsOld,"n",nodeId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^nodex(key,intValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + . k ^element(qsOld,"n",nodeId,"u",u) + ; + i delete,qsOld'="" k ^element(qsOld,"n",nodeId) + ; + ; Create export index + s ^export(timestamp,"n",changeset,nodeId,version)="" + ; + q + diff --git a/tgj2.m b/tgj2.m new file mode 100644 index 0000000..afa2492 --- /dev/null +++ b/tgj2.m @@ -0,0 +1,8 @@ +pipe ; Test output to named pipe + s pipe="output.pipe" + o pipe:(nowrap:stream:fifo) + u pipe + f i=1:1:100000 w $tr($j("",1000)," ","a") + w "z" + c pipe + q diff --git a/threen1c.m b/threen1c.m new file mode 100644 index 0000000..4491b5f --- /dev/null +++ b/threen1c.m @@ -0,0 +1,78 @@ +threeen1c + ; Find the maximum cycle lenth for the 3n+1 problem for all integers through two input integers. + ; See http://docs.google.com/View?id=dd5f3337_12fzjpqbc2 + ; Assumes input format is 3 integers separated by a space with the first integer smaller than the second. + ; Third integer is number of threads. No input error checking is done. -- K.S. Bhaskar 20091122 + ; No claim of copyright is made with respect to this program. + ; + ; Loop over lines in input + For Read input Quit:$ZEOF!'$Length(input) Do + .Set i=$Piece(input," ",1) ; i - starting number + .Set j=$Piece(input," ",2) ; j - ending number + .Set k=$Piece(input," ",3) ; k - parallel execution streams requested + .Write i," ",j," ",k ; Reproduce input on output + .;Open "cpus":(COMMAND="grep processor /proc/cpuinfo|wc -l":READONLY)::"PIPE" + .;Use "cpus" Read cpus Use $PRINCIPAL ; Get number of CPUS on system + .;Close "cpus" + .s cpus=4 + .Set:4*cpus>k k=4*cpus ; at least four execution streams per CPU + .Write " ",k ; Report actual number of execution streams + .Set blk=(j-i+k)\k ; Calculate size of blocks (last block may be smaller) + .Set ^count=0 ; Clear count - may have residual value if restarting from crash + .set ^count("next")=0 + .Lock +l1 ; Set lock for process synchronization + .For s=i:blk:j Do + ..Set c=$Increment(^count) ; Atomic increment of counter in database for process synchronization + ..Set ^count(c)=s_"|"_(s+blk-1)_"|"_i_"|"_j + ..;Job doblk(s,s+blk-1,i,j) ; Job process for next block of numbers + ..zsystem "$gtmrun doblk^threen1c three"_c + .For Quit:'^count Hang 0.1 ; Wait for processes to start (^count goes to 0 when they do) + .Lock -l1 ; Release lock so processes can run + .Set startat=$HOROLOG ; Starting time + .Lock +l2 ; Wait for processes to finish + .set endat=$HOROLOG ; Ending time + .Write " ",^result," ",(86400*($Piece(endat,",",1)-$Piece(startat,",",1)))+$Piece(endat,",",2)-$Piece(startat,",",2),! + .Lock -l2 ; Release lock for next run + .Do dbinit ; Initialize database for next run + Quit + ; +dbinit ; Initializes database + Kill ^cycle,^count ; Clear database for next iteration + Set ^result=1 ; Initialize ^result to minimum legal cycle length + Quit + ; +; This is where Jobbed processes start + ;doblk(myfirst,mylast,allfirst,alllast) +doblk ; + h 5 + Lock +l2($JOB) ; Get lock parent will wait on till Jobbed processes are done + s next=$i(^count("next")) + s args=^count(next) + Set tmp=$Increment(^count,-1) ; Decrement ^count to say this process is alive + Lock +l1($JOB) ; Getting lock on l1($JOB) means parent has released lock on l + s myfirst=$p(args,"|",1) + s mylast=$p(args,"|",2) + s allfirst=$p(args,"|",3) + s alllast=$p(args,"|",4) + Do docycle(myfirst,mylast) ; Do the block I am assigned to, then do the other blocks + Do:alllast>mylast docycle(mylast+1,alllast) + Do:allfirst^result ^result=i + ..TCommit + ..Set n="" For Set n=$Order(currpath(n)) Quit:""=n Set ^cycle(currpath(n))=i-n + Quit diff --git a/time.m b/time.m new file mode 100644 index 0000000..6479562 --- /dev/null +++ b/time.m @@ -0,0 +1,249 @@ + ; Time Class + ; Summary of functions (see comments above function label for details) + ; + ; standard argument abbreviations are: + ; + ; t1 - 12 hour alphabetic time: HH:MM am/pm + ; t2 - 24 hour clock delimited time : HH:MM + ; te - entered time eg. 'T' '24/9/91' - many possible formats + ; th - $h time (seconds since midnight) + ; ti - 24 hour clock internal time : HHMM + ; + ; Validation functions: return 0 if invalid time + ; + ; $$tmv1(te) - transform external as entered to HH:MMxx (am/pm) + ; $$tmv2(te) - transform external as entered to HH:MM + ; $$tmvh(te) - transform external as entered to $h seconds + ; $$tmvi(te) - transform external as entered to HHMM + ; + ; time validation functions accept value of: + ; + ; 24 hour clock eg. 23:05 + ; 12 hour clock eg. 11:05pm + ; 't' for time now + ; + ; any delimiter can be used + ; if no minutes are entered 00 minutes is assumed + ; if 3 digits are entered hMM is assumed + ; if am/pm is not specified am is assumed + ; + ; Functions to transform valid times: + ; + ; $$tmt1h(t1) - transform 12 hour time to $h format + ; $$tmt1i(t1) - transform 12 hour time to HHMM + ; $$tmt2h(t2) - transform 24 hour time to $h format + ; $$tmt2i(t2) - transform 24 hour time to HHMM + ; $$tmth1(th) - transform $h time to 12 hour time + ; $$tmth2(th) - transform $h time to 24 hour time + ; $$tmthi(th) - transform $h time to HHMM + ; $$tmths(th) - transform $h time to HHMMSS (hours, minutes, seconds) + ; $$tmti1(ti) - transform HHMM to 12 hour time + ; $$tmti2(ti) - transform HHMM to 24 hour time + ; $$tmtih(ti) - transform HHMM to $h time + ; + ; Constants: + ; + ; $$time - time now in $h HHMM HH:MM HH:MM formats delimited by space + ; $$time1 - time now in 12 hour format + ; $$time2 - time now in 24 hour format + ; $$timeh - time now as $h time + ; $$timei - time now as HHMM + + +time() ; Public ; Time now as $h, HHMM, HH:MM and HH:MMxx delimited by space + n z s z=$$timeh + q z_" "_$$tmthi(z)_" "_$$tmth2(z)_" "_$$tmth1(z) + + +time1() ; Public ; Time now in 12 hour format + q $$tmth1($$timeh) + + +time2() ; Public ; Time now in 24 hour format + q $$tmth2($$timeh) + + +timeh() ; Public ; Time now as $h time + q $p($h,",",2) + + +timei() ; Public ; Time now as HHMM + q $$tmthi($$timeh) + + +tmt1h(t2) ; Public ; Transform 12 hour time to $h format + ; + i t2="" q "" + q $e(t2,6,7)="pm"*12+$e(t2,1,2)*60+$e(t2,4,5)*60 + + +tmt1i(t2) ; Public ; Transform 12 hour time to HHMM + ; + i t2="" q "" + q ($e(t2,6,7)="pm"*12+$e(t2,1,2))_$e(t2,4,5) + + +tmt2h(t2) ; Public ; Transform 24 hour time to $h format + ; + i t2="" q "" + q $e(t2,1,2)*60+$e(t2,4,5)*60 + + +tmt2i(t2) ; Public ; Transform 24 hour time to HHMM + ; + q $e(t2,1,2)_$e(t2,4,5) + + +tmth1(th) ; Public ; Transform $h time to 12 hour time + ; + i th="" q "" + n %h,%m,%s + d tmtx9 + q $$tmtx4 + + +tmth2(th) ; Public ; Transform $h time to 24 hour time + ; + i th="" q "" + n %h,%m,%s + d tmtx9 + q %h_":"_%m + + +tmthi(th) ; Public ; Transform $h time to HHMM + ; + i th="" q "" + n %h,%m,%s + d tmtx9 + q %h_%m + + +tmths(th) ; Public ; Transform $h time to HHMMSS + ; + i th="" q "" + n %h,%m,%s + d tmtx9 + q %h_%m_%s + + +tmti1(ti) ; Public ; Transform HHMM to 12 hour time + ; + i ti="" q "" + n %h,%m,%s + s %h=$e(ti,1,2),%m=$e(ti,3,4) + q $$tmtx4 + + +tmti2(ti) ; Public ; Transform HHMM to 24 hour time + ; + i ti="" q "" + q $e(ti,1,2)_":"_$e(ti,3,4) + + +tmtih(ti) ; Public ; Transform HHMM to $h time + ; + i ti="" q "" + q $e(ti,1,2)*60+$e(ti,3,4)*60 + + +tmv1(te) ; Public ; Transform external as entered to HH:MMxx (am/pm) + ; + i te="" q "" + n %h,%m,%s + i '$$tmvx q 0 + q $$tmtx4 + + +tmv2(te) ; Public ; Transform external as entered to HH:MM + ; + i te="" q "" + n %h,%m,%s + i '$$tmvx q 0 + q $$tmti2(%h_%m) + + +tmvh(te) ; Public ; Transform external as entered to $h seconds + ; + i te="" q "" + n %h,%m,%s + i '$$tmvx q 0 + q $$tmtih(%h_%m) + + +tmvi(te) ; Public ; Transform external as entered to HHMM + ; + i te="" q "" + n %h,%m,%s + i '$$tmvx q 0 + q %h_%m + + +tmvx() ; Private ; Validate and default external time + ; + ; $$tmvx - validate and default external time + ; - needs te=time to validate + ; - returns %h, %m = hours, minutes padded with leading zeros + ; + ; 1) tmvx2: parse input + ; 2) i %a..: convert alpha suffix to 1/0 flag (0=am,1=pm,other=error) + ; 3) tmtx1: check hours, minutes + ; + k %h,%m + n %a s %a="" + i '$$tmvx2 q 0 + i %a'="" s %a=$f(" AM PM"," "_%a)-2-$l(%a)/3 i %a#1 q 0 + i ($l(%h)>2)!(%h'?1n.n)!(%h>23)!((%h>12)&(%a)) q 0 + i ($l(%m)>2)!(%m'?.n)!(%m>59) q 0 + i %a s %h=%h#12+12 + s %h=$e(100+%h,2,3),%m=$e(100+%m,2,3) + q 1 + + +tmvx2() ; Private ; Parse input:--> %h, %m defined if parses ok, %a=am/pm suffix + ; returns 1 if managed to parse, else 0 + ; + i te?.e1l.e s te=$$upper^%vc1str(te) + ; + ; time="T" + ; + i te="T" s th=$p($h,",",2) d tmtx9 q 1 + ; + ; eeeU strip am/pm suffix, put into %a + ; + i te?.e1u.u d + . n %i + . f %i=$l(te):-1:0 q:$e(te,%i)?1n + . s %a=$e(te,%i+1,99),te=$e(te,1,%i) + . f q:%a'?1p.e s %a=$e(%a,2,99) ; should strip all punctuation?? + . q + ; + ; nnnn - pad with zeroes + ; + i te?.n d q 1 + . i $l(te)<3 s te=te_"00" + . i $l(te)=3 s te="0"_te + . s %h=$e(te,1,2),%m=$e(te,3,99) + . q + ; + ; other - look for delimiter + ; + i te'?.n d q 1 + . n %i + . f %i=1:1 i $e(te,%i)'?1n,$e(te,%i)?.p q + . s %h=$e(te,1,%i-1),%m=$e(te,%i+1,99) + . q + ; + q 0 + + +tmtx4() ; Private ; reformat %h, %m as HH:MMxx + q $e(100+$s(%h>12:%h-12,1:%h),2,3)_":"_%m_$s(%h>11:"pm",1:"am") + + +tmtx9 ; Private ; extract %h, %m, %s from $h seconds + s %m=th\60 + s %h=$e(100+(%m\60),2,3),%m=$e(100+(%m#60),2,3),%s=$e(100+(th#60),2,3) + q + + + diff --git a/total.m b/total.m new file mode 100644 index 0000000..00fe174 --- /dev/null +++ b/total.m @@ -0,0 +1,180 @@ +total ; REST ; Calculate totals for various tags + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + n date,f + ; + s date=^osmPlanet("date") + d generate(date) + ; + s f="/home/etienne/www/total.xml" + o f:NEW + u f + d xmlProlog("total.xsl") + ; + d xmlTotal(date,"total|count|distinct|@*") + ; + c f + q + + + +xmlTotal(date,select) ; Generate xml dataset of totals for a given date + ; + n i,element,key,value,type,comment + ; + i '$$select^osmXml(select,"total") q + ; + w "",! + ; + s i="" + f d i i="" q + . s i=$o(^total("date",date,"item",i)) i i="" q + . s element=$g(^total("date",date,"item",i,"element")) + . s key=$g(^total("date",date,"item",i,"key")) + . s value=$g(^total("date",date,"item",i,"value")) + . s type=$g(^total("date",date,"item",i,"type")) + . s count=$g(^total("date",date,"item",i,"count")) + . s distinct=$g(^total("date",date,"item",i,"distinct")) + . s comment=$g(^total("date",date,"item",i,"comment")) + . i type="count" d xmlCount(element,key,value,count,comment,select) + . i type="distinct" d xmlDistinct(element,key,distinct,comment,select) + w "",! + ; + q + + +xmlCount(element,key,value,count,comment,select) ; + ; + i '$$select^osmXml(select,"count") q + ; + w "",! + q + + +xmlDistinct(element,key,distinct,comment,select) ; + ; + i '$$select^osmXml(select,"distinct") q + ; + w "",! + q + + +generate(date) ; Generate current stats and store as given date + ; + n i,element,key,value,type,comment + ; + ; Only record one set of stats per day + i $d(^total("date",date)) k ^total("date",date) + ; + s i="" + f d i i="" q + . s i=$o(^total("param",i)) i i="" q + . s element=$g(^total("param",i,"element")) + . s key=$g(^total("param",i,"key")) + . s value=$g(^total("param",i,"value")) + . s type=$g(^total("param",i,"type")) + . s comment=$g(^total("param",i,"comment")) + . i type="count" d genCount(date,i,element,key,value,comment) + . i type="distinct" d genDistinct(date,i,element,key,comment) + ; + q + + +genCount(date,item,element,key,value,comment) ; + ; + n e,i,count,qt,id + ; + s count=0 + i element["node" s count=count+$g(^count("node",key,value)) + i element["way" s count=count+$g(^count("waykv",key,value)) + ; + s ^total("date",date,"item",item,"element")=element + s ^total("date",date,"item",item,"key")=key + s ^total("date",date,"item",item,"value")=value + s ^total("date",date,"item",item,"type")="count" + s ^total("date",date,"item",item,"comment")=comment + s ^total("date",date,"item",item,"count")=count + ; + q + + +genDistinct(date,item,element,key,comment) ; + ; + n i,e,distinct,value + ; + s distinct=0 + i element["node" d + . s value="" + . f d i value="" q + . . s value=$o(^nodex(key,value)) i value="" q + . . s distinct=distinct+1 + ; + i element["way" d + . s value="" + . f d i value="" q + . . s value=$o(^wayx(key,value)) i value="" q + . . i '$d(^nodex(key,value)) s distinct=distinct+1 + ; + s ^total("date",date,"item",item,"element")=element + s ^total("date",date,"item",item,"key")=key + s ^total("date",date,"item",item,"type")="distinct" + s ^total("date",date,"item",item,"comment")=comment + s ^total("date",date,"item",item,"distinct")=distinct + ; + q + + +add ; + ; + w !,"Type " r t i t="" s t="count" w t + w !,"Element " r e i e="" s e="node|way" w e + w !,"Key " r k i k="" s k="*" w k + i t="count" w !,"Value " r v i v="" s v="*" w v + w !,"Comment " r comment + ; + s i=$g(^total("paramCount"))+1 + s ^total("paramCount")=i + ; + s ^total("param",i,"type")=t + s ^total("param",i,"element")=e + s ^total("param",i,"key")=k + i t="count" s ^total("param",i,"value")=v + s ^total("param",i,"comment")=comment + w !,"Added as entry #",i + g add + + + +xmlProlog(xslTemplate) ; Public ; Write xml Prolog and xsl stylesheet elements + ; + w "",! + i xslTemplate'="" w "",! + ; + q diff --git a/user.m b/user.m new file mode 100644 index 0000000..77ec6b9 --- /dev/null +++ b/user.m @@ -0,0 +1,566 @@ +user ; User details + +new ; Public ; Create an account + ; + n query,errors + ; + d xmlNew(.query,.errors) + ; + q + + +xmlNew(query,errors) ; Generate new user form + d header^http("text/xml") + d prolog^osmXml("/userNew.xsl") + ; + w "",! + ; + i $g(errors) d + . w "",! + . f i=1:1:errors d + . . w "",! + . . w errors(i,"message") + . . w "",! + . w "",! + w "",! + q + +create ; Public ; Create user account + ; + n query,email,emailConfirmation,name,password,passwordConfirmation,emailToken,errors + ; + ; + s errors=0 + ; + d unpackQuery^rest(.query,%ENV("POST_DATA")) + ; + s email=query("userEmail") + s emailConfirmation=query("userEmailConfirmation") + s name=query("userDisplayName") + s password=query("userPassCrypt") + s passwordConfirmation=query("userPassCryptConfirmation") + s claimOsmName=$g(query("claimOsmName")) + ; + ; Some basic validation + i $l(email)<2 d error(.errors,"userEmail","Email is required") + i email'=emailConfirmation d error(.errors,"userEmailConfirmation","Email addresses do not match") + i password'=passwordConfirmation d error(.errors,"userPassCryptConfirmation","Passwords do not match") + i $l(password)<6 d error(.errors,"userPassCrypt","Password is a bit on the short side to be very secure") + i name="" d error(.errors,"userDisplayName","Please enter a display name") + ; + i $d(^pendingUserx("nameOrEmail",name)) d error(.errors,"userDisplayName","Display Name is not available") ; Duplicate displayname + i claimOsmName'="on",$d(^userx("name",name)) d error(.errors,"userDisplayName","Display Name is not available") ; Duplicate displayname + i claimOsmName="on",'$d(^userx("name",name)) d error(.errors,"userDisplayName","Display Name is not recognized as an existing OpenStreetMap account name.") ; OSM name + i $d(^userx("nameOrEmail",email)) d error(.errors,"userEmail","Email already registered. Have you lost your password?") ; Duplicate email + i $d(^pendingUserx("nameOrEmail",email)) d error(.errors,"userEmail","Email already registered. Have you lost your password?") ; Duplicate email + ; + ; TODO: Need to check if this username is already registered (if sha256Password exists then account has already been registered/claimed + ; + ; Punt if there are errors in the form + i errors d xmlNew(.query,.errors) q + ; + l +^id("pendingUid") + s uid=$g(^id("pendingUid"),100000000)+1 + s ^id("pendingUid")=uid + l -^id("pendingUid") + ; + ; Allocate a token + s emailToken=$$token() + ; + s ^pendingUser(uid,"email")=email + s ^pendingUser(uid,"name")=name + s ^pendingUser(uid,"sha256Password")=$$dgst^openssl(password,"sha256") + s ^pendingUser(uid,"emailToken")=emailToken + s ^pendingUser(uid,"createdAt")=$$nowZulu^date() + s ^pendingUser(uid,"claimOsmName")=claimOsmName + s ^pendingUserx("name",name)=uid + s ^pendingUserx("email",email)=uid + s ^pendingUserx("nameOrEmail",name)=uid + s ^pendingUserx("nameOrEmail",email)=uid + s ^pendingUserx("emailToken",emailToken)=uid + ; + ; Log this event + s userLogId=$g(^userLog)+1 + s ^userLog=userLogId + s ^userLog(userLogId,"email")=email + s ^userLog(userLogId,"name")=name + s ^userLog(userLogId,"osm")=claimOsmName + ; + s currentDevice=$i + ; + ; Send email to new user + s file="confirm"_$j_".tmp" + o file:NEW + u file + s emailAddress="<"_email_">" + i name'=email s emailAddress=name_" "_emailAddress + w "To: "_emailAddress,! + w "From: fosm <80n@xenserver-2.ucsd.edu>",! + w "Subject: fosm :: Confirm your account creation request",! + w ! + w name,! + w "Thank you for requesting an account to contribute to fosm.org.",! + w ! + w "Please click the link below to confirm your request:",! + w "http://www.fosm.org/user/confirm/"_emailToken,! + w ! + w "If you did not apply for an account at FOSM please ignore this message and accept our apologies.",! + w ! + w "Thank you.",! + w "The FOSM community",! + w ".",! + c file + zsystem "cat confirm"_$j_".tmp|/usr/sbin/sendmail -t" + ; + o file c file:DELETE + ; + ; Send email to me + s file="confirm"_$j_".tmp" + o file:NEW + u file + w "To: 80n80n@gmail.com",! + w "From: fosm <80n@xenserver-2.ucsd.edu>",! + w "Subject: fosm signup",! + w ! + w "The following user signed up to fosm",! + w "Name = ",name,! + w "email = ",email,! + w "claim osm = ",claimOsmName,! + w "email token = ",emailToken,! + w ! + zwr %ENV + w ! + w ".",! + c file + zsystem "cat confirm"_$j_".tmp|/usr/sbin/sendmail -t" + ; + o file c file:DELETE + ; + u currentDevice + ; + ; Send response to user + ; d header^http("text/html") + s message="Thank you. Please check your email." + ; + d xmlHome^rest("Confirmation",message) + ; + c currentDevice + ; + q + + +error(errors,field,message) ; Add an error message to the errors object + s errors=errors+1 + s errors(errors,"field")=field + s errors(errors,"message")=message + q + + +login ; Public ; Login + ; + ; If itis not a POST then display a blank login form + i $g(%ENV("REQUEST_METHOD"))="GET" d xmlLogin("","","") q + ; + d unpackQuery^rest(.query,%ENV("POST_DATA")) + s name=$g(query("user%5Bemail%5D")) + s password=$g(query("user%5Bpassword%5D")) + ; + ; Check user + i name="" d xmlLogin(name,"Sorry, could not log in with those details.",$$loginHelp) q + s uid=$g(^userx("nameOrEmail",name)) + i uid="" d xmlLogin(name,"Sorry, could not log in with those details.",$$loginHelp) q + ; + ; Check password + i password="" d xmlLogin(name,"Sorry, could not log in with those details.",$$loginHelp) q + s sha256Password=$$dgst^openssl(password,"sha256") + ; + s actualSha256Password=$g(^user(uid,"sha256Password")) + i actualSha256Password'=sha256Password d xmlLogin(name,"Sorry, could not log in with those details.",$$loginHelp) q + ; + s ^session(%session,"authenticated")=1 ; TODO: individual roles + s ^session(%session,"uid")=uid + ; + ; If there is a redirect request then go there + s session=$g(^session(%session,"redirect")) + i session'="" k ^session(%session,"redirect") d @session q + ; + ; Now go to the home page (issue client side redirect) + w "Status: 301 Moved Permanently",! + w "Location: /",! + d cookie^session + w ! + q + + +loginHelp() ; Help the user login + q "Please check that you have entered your email address or username and your password correctly. Passwords are case sensitive. If you cannot remember your password please follow the Lost your Password link to reset it." + + +xmlLogin(name,message,description) ; Return form contents and error details + d header^http("text/xml") + d prolog^osmXml("login.xsl") + ; + w "",$c(13,10) + ; + i message'="" d + . w "",! + . w description,! + . w "",! + w "",! + q + + +add(uid,name) ; Public ; Add a user (from external source, not an authorized account here) + ; + i uid="" q + i name="" q + i '$d(^user(uid)) d + . s ^user(uid,"name")=name + . s ^user(uid,"alias",name)="" + . s ^user(uid,"createdAt")=$$nowZulu^date() + . s ^userx("name",name)=uid + . s ^userx("nameOrEmail",name)=uid + ; + ; User may have changed their name + i $g(^user(uid,"name"))'=name d + . s ^user(uid,"name")=name + . s ^user(uid,"alias",name)="" + . s ^userx("name",name)=uid + . s ^userx("nameOrEmail",name)=uid + ; + q + + +onEdit(uid) ; Public ; Called when a user edits something + ; + ; Record edit counts + s ^user(uid,"lastEditAt")=$$nowZulu^date() + s ^user(uid,"editCount")=$g(^user(uid,"editCount"))+1 + ; + q + + +authenticated(uid,name) ; Public ; Is this session authenticated? + ; + n ok,authorization,oauthToken,queryString + n b64NamePassword,namePassword,password,sha256Password,actualSha256Password + ; + ; There are three possible ways that the request can be authorized: + ; 1) Basic digest - The user's displayName will be in the Authorization header REDIRECT_HTTP_AUTHORIZATION + ; 2) OAuth - The user's OAuth credentials will be in the Authorization header REDIRECT_HTTP_AUTHORIZATION + ; 3) OAuth - The user's OAuth credentials will be in the query string of the REQUEST_URI + ; 4) TODO: cookie - If the user has a cookie for an authenticated session then they are in + ; + + i $d(^session(%session,"uid")) d q 1 + . s uid=^session(%session,"uid") + . s name=^user(uid,"name") + ; + s ok=1 + s authorization=$g(%ENV("REDIRECT_HTTP_AUTHORIZATION")) + i $p(authorization," ",1)="Basic" d i 'ok d error401 q 0 + . s b64NamePassword=$p(authorization," ",2) + . i b64NamePassword="" s ok=0 q + . s namePassword=$$fromB64^string(b64NamePassword) + . s name=$p(namePassword,":",1) + . s password=$p(namePassword,":",2,$l(namePassword)) + . i name="" s ok=0 q + . s uid=$g(^userx("nameOrEmail",name)) + . i uid="" s ok=0 q + . s sha256Password=$$dgst^openssl(password,"sha256") + . s actualSha256Password=$g(^user(uid,"sha256Password")) + . i sha256Password'=actualSha256Password s ok=0 q + . s ok=1 + ; + i $p(authorization," ",1)="OAuth" d i 'ok d error401 q 0 + . s oauthToken=$p($p(authorization,"oauth_token=""",2),"""",1) + . i oauthToken="" s ok=0 q + . s uid=$g(^oauth("access",oauthToken,"uid")) + . i uid="" s ok=0 + ; + i authorization="" d i 'ok d error401 q 0 + . s queryString=$g(%ENV("REQUEST_URI")) + . s oauthToken=$p($p(queryString,"oauth_token=",2),"&",1) + . i oauthToken="" s ok=0 q + . s uid=$g(^oauth("access",oauthToken,"uid")) + . i uid="" s ok=0 + ; + s ^session(%session,"authenticated")=1 + s ^session(%session,"uid")=uid + s name=^user(uid,"name") + q 1 + + +error401 ; Send http 401 response + w "Status: 401 Authorization Required",! + w "WWW-Authenticate: Basic realm=""FOSM""",! + w "Content-Type: text/html",! + w ! + w "",! + w "",! + w "",! + w "Error",! + w "",! + w "",! + w "

401 Unauthorized.

",! + w "",! + q + + + + +sendOsmMessage(name,title,body) ; Send a message to an Osm user (from FOSM) + ; + n message,length,session,socket,m + ; + s message="message%5Btitle%5D="_title + s message=message_"&message%5Bbody%5D="_body + s message=message_"&commit=Send" + s length=$l(message) + s session=^osmPlanet("osmSession") + s socket="|TCP|"_$j + o socket:(CONNECT="www.openstreetmap.org:80:TCP":DELIMITER=$C(13,10):ATTACH="client":NOWRAP):60:"SOCKET" + u socket + w "POST /message/new/"_$$urlEscape(name)_" HTTP/1.1",$c(13,10) + w "Host: www.openstreetmap.org",$c(13,10) + w "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-GB; rv:1.9.2.9) Gecko/20100824 Firefox/3.6.9 (.NET CLR 3.5.30729)",$c(13,10) + w "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8",$c(13,10) + w "Accept-Language: en-gb,en;q=0.5",$c(13,10) + w "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7",$c(13,10) + w "Keep-Alive: 115",$c(13,10) + w "Connection: keep-alive",$c(13,10) + w "Cookie: _osm_location=-3.4322779774666|55.75741619093|5|M; _osm_session="_session,$c(13,10) + w "Content-Type: application/x-www-form-urlencoded",$c(13,10) + w "Content-Length: "_length,$c(13,10) + w $c(13,10) + w message,$c(13,10) + w $c(13,10) + f m=1:1:20 u socket r x u 0 w x + c socket + q + + +tellUser(message) ; Tell the user something + d header^http("text/html") + w message,! + q + + +confirm ; Public ; Confirm account application + ; + n step,token,password,name,email + ; + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + s token=step + i $l(token)'=30 d error^http q + ; + ; Check that the user has a valid token + i '$d(^pendingUserx("emailToken",token)) d error^http q + ; + ; Confirm the token + i $d(^pendingUserx("emailToken",token)) d + . s pendingUid=^pendingUserx("emailToken",token) + . s ^pendingUser(pendingUid,"emailConfirmed")=1 + ; + ; Get the current state + s emailConfirmed=$g(^pendingUser(pendingUid,"emailConfirmed")) + ; + ; Are we good to go? + i emailConfirmed=1 d approve(pendingUid) q + ; + ; We shouldn't be here... + d xmlHome^rest("Oops...","Something unexpected has happened. Sorry.") + q + + +approve(pendingUid) ; Approve a pending request + ; + n name,email,sha256Password + ; + s name=^pendingUser(pendingUid,"name") + s email=^pendingUser(pendingUid,"email") + s sha256Password=^pendingUser(pendingUid,"sha256Password") + ; + ; Use an existing uid if the name has been confirmed otherwise allocate a new uid + i $g(^pendingUser(pendingUid,"claimOsmName"))="on" s uid=$g(^userx("name",name)) + e d + . l +^id("uid") + . s uid=$g(^id("uid"),100000000)+1 + . s ^id("uid")=uid + . l -^id("uid") + ; + s ^user(uid,"email")=email + s ^user(uid,"name")=name + s ^user(uid,"alias",name)="" + s ^user(uid,"createdAt")=$$nowZulu^date() + s ^user(uid,"sha256Password")=sha256Password + s ^userx("name",name)=uid + s ^userx("nameOrEmail",name)=uid + s ^userx("email",email)=uid + s ^userx("nameOrEmail",email)=uid + ; + ; Delete the pending user details now + s emailToken=$g(^pendingUser(pendingUid,"emailToken")) + k ^pendingUser(pendingUid) + k ^pendingUserx("name",name) + k ^pendingUserx("nameOrEmail",name) + k ^pendingUserx("email",email) + k ^pendingUserx("nameOrEmail",email) + k ^pendingUserx("emailToken",emailToken) + ; + ; Log the user in + s ^session(%session,"authenticated")=1 + s ^session(%session,"uid")=uid + ; + d xmlHome^rest("Confirmation","Your account has been confirmed. Welcome to FOSM. You can now use JOSM, Merkaartor and other tools to contribute content.") + q + + +token() ; Generate 30 character random token + ; + n token,i + ; + s token="" + f i=1:1:30 s token=token_$e("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789",$r(61)+1) + q token + + +getConflicts(uid) ; Public ; Get details of edit conflicts + ; + n seq,changeset,version,nodeId,wayId,relationId,type,id + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + w "",$c(13,10) + ; + s seq="" + f d i seq="" q + . s seq=$o(^conflict(uid,seq)) i seq="" q + . s type=$g(^conflict(uid,seq,"@type")) + . s id=$g(^conflict(uid,seq,"@id")) + . s a=$g(^conflict(uid,seq,"a")) + . s version=$p(a,$c(1),1) + . s changeset=$p(a,$c(1),2) + . s timestamp=$p(a,$c(1),3) + . s conflictUid=$p(a,$c(1),4) + . s visible=$p(a,$c(1),5) + . ; + . w "<"_type + . w $$attribute^osmXml("id",id,"") + . w $$attribute^osmXml("version",version,"") + . w $$attribute^osmXml("changeset",changeset,"") + . w $$attribute^osmXml("uid",uid,"") + . i conflictUid'="" w $$attribute^osmXml("name",$g(^user(conflictUid,"name")),"") + . w $$attribute^osmXml("timestamp",timestamp,"") + . i visible'="" w $$attribute^osmXml("visible",visible,"") + . w "/>",$c(13,10) + w "",$c(13,10) + q + + +getDetails(uid) ; Public ; Get user details and return as xml + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + w "",$c(13,10) + ; + w " ","",$c(13,10) + ; + w " ","",$c(13,10) + ; + w " ","",$c(13,10) + ; + w " ","",$c(13,10) + ; + w " ","",$c(13,10) + w " ","","en","",$c(13,10) + w " ","",$c(13,10) + ; + w " ","",$c(13,10) + ; + w "",$c(13,10) + ; + q + + +getPreferences(uid) ; Public ; Get user preferences + ; + n key,value + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + w "",$c(13,10) + ; + w " ","",$c(13,10) + s key="" + f d i key="" q + . s key=$o(^user(uid,"preferences",key)) i key="" q + . s value=^user(uid,"preferences",key) + . w " ","",$c(13,10) + w " ","",$c(13,10) + ; + w "",$c(13,10) + ; + q + + +urlEscape(string) ; Private ; Url Escape a string + ; + n out,c + ; + s out="" + f c=1:1:$l(string) s out=out_$$urlChar($a(string,c)) + q out + + +urlChar(ascii) ; Private ; Url Escape a character + ; + n hex1,hex2 + ; + i ascii>64,ascii<91 q $c(ascii) ; A-Z + i ascii>96,ascii<123 q $c(ascii) ; a-z + i ascii>47,ascii<58 q $c(ascii) ; 0-9 + i ascii>255 q $c(ascii) ; ? + ; + s hex1=$e("0123456789ABCDEF",ascii\16+1) + s hex2=$e("0123456789ABCDEF",ascii#16+1) + q "%"_hex1_hex2 diff --git a/watch.m b/watch.m new file mode 100644 index 0000000..0868ecc --- /dev/null +++ b/watch.m @@ -0,0 +1,83 @@ +watch ; Watch class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + + +rss(string) ; Public ; Generate rss feed of a users watch items + ; + n watchlist,user,category,sequence,count + ; + s watchlist=$p(string,"/",1,2) + s user=$p(watchlist,"/",1) + s category=$p(watchlist,"/",2) + ; + d header^http("application/rss+xml") + d prolog^osmXml("") + ; + w "",! + w "",! + w "OSM Watchlist",! + w "RSS feed of OpenStreetMap changes being watched by user "_$p(watchlist,"/",1) + i category'="" w " for category "_category + w ".",! + ; + s sequence="" + f count=1:1 d i sequence="" q + . s sequence=$o(^watchRss(watchlist,sequence),-1) i sequence="" q + . i count>30 s sequence="" q + . ; + . m event=^watchRss(watchlist,sequence) + . ; + . ; If this is a category event then link to the RSS feed for this user's category + . i event("type")="category" d category(.event,user) + . e d element(.event) + ; + w "",! + w "",! + q + + +category(event,user) ; Category event + ; + w "",! + w "",event("id")_" ",event("mode")," by ",event("changedBy"),"",! + w "",event("timestamp"),"",! + w "http://www.informationfreeway.org/api/0.5/watch/"_user_"/"_event("id")_"",! + w "http://www.informationfreeway.org/api/0.5/watch/"_user_"/"_event("id")_"",! + w "",! + ; + q + + +element(event) ; Element event + ; + n name + ; + s name=$g(event("name")) + i name="" s name=event("type")_" "_event("id") + ; + w "",! + w "",name_" ",event("mode")," by ",event("changedBy"),"",! + w "",event("timestamp"),"",! + w "http://www.openstreetmap.org/api/0.5/"_event("type")_"/"_event("id")_"/history",! + w "http://www.openstreetmap.org/api/0.5/"_event("type")_"/"_event("id")_"/history",! + w "",! + ; + q + diff --git a/way.m b/way.m new file mode 100644 index 0000000..2627f97 --- /dev/null +++ b/way.m @@ -0,0 +1,874 @@ +way ; Way Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +add(sWay,delete) ; Public ; Add a way + ; #sWay = stream object containing way + ; + n line,wayId,ndSeq,timestamp,user,uid,version,changeset + n a,currentUid,blockedByUid + ; + s line=sWay("current") + ; + s wayId=$$getAttribute^osmXml(line,"id") + s version=$$getAttribute^osmXml(line,"version") + s changeset=$$getAttribute^osmXml(line,"changeset") + s timestamp=$$getAttribute^osmXml(line,"timestamp") + s user=$$getAttribute^osmXml(line,"user") + i user["'" s user=$$xmlEscapeApostrophe(user) + s uid=$$getAttribute^osmXml(line,"uid") + ; + ; + ; Don't load older versions + i $g(^waytag(wayId,"@version"))>version d q + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sWay) + ; + ; Conflict checks + s currentUid=$g(^waytag(wayId,"@uid"),0) + s a=version_$c(1)_changeset_$c(1)_timestamp_$c(1)_uid + ; + ; Don't load forked elements + i $d(^waytag(wayId,"@fork")) d q + . ; + . ; Log conflict + . d log^conflict("way",wayId,currentUid,a,"Edited in fosm") + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sWay) + ; + ; Don't load edits from blocked users + i uid'="",$g(^user(uid,"osmImport"))="block" d q + . s blockedByUid=$g(^user(uid,"blockedByUid"),uid) + . ; + . ; Log conflict + . d log^conflict("way",wayId,blockedByUid,a,"User #"_uid_" ("_^user(uid,"name")_") blocked by "_blockedByUid) + . ; + . ; Skip the rest of the element + . i line["/>" q + . f d i line["" q + . . s line=$$read^stream(.sWay) + ; + d delete(wayId,changeset,delete) + ; + ; + ; Way attributes + d setTag(wayId,"@timestamp",timestamp,changeset,version,delete) + d setTag(wayId,"@user",user,changeset,version,delete) + d setTag(wayId,"@uid",uid,changeset,version,delete) + d setTag(wayId,"@version",version,changeset,version,delete) + d setTag(wayId,"@changeset",changeset,changeset,version,delete) + i delete d setTag(wayId,"@visible","false",changeset,version,delete) + ; + ; Changeset by version index + s ^wayVersion(wayId,"v",version)=changeset + s ^wayVersion(wayId,"c",changeset,version)="" + ; + ; Changeset headers + s ^c(changeset)="" + s ^c(changeset,"w",wayId)="" + s ^c(changeset,"w",wayId,"v",version)="" + ; + ; If there are nodes and/or tags then process these + i line'["/>" d + . ; + . s ndSeq=0 + . ; + . f d i line["" q + . . s line=$$read^stream(.sWay) + . . i line["" d + . ; + . s ndSeq=0 + . ; + . f d i line["" q + . . s line=$$read^stream(.sWay) + . . i line["" f d i line["/>" q + . s line=line_$$read^stream(.sWay) + ; + s k=$$getAttribute^osmXml(line,"k") i k="" q + ; + ; Get internal value for the key or assign one + s u=$g(^keyx(key)) + i u="" d + . l +^key + . s (u,^key)=^key+1 + . s ^key(u)=key + . s ^keyx(key)=u + . l -^key + ; + i $l(k)>100 s k=$e(k,1,100)_".." + s v=$$getAttribute^osmXml(line,"v") + i v["'" s v=$$xmlEscapeApostrophe(v) ; The planet export doesn't escape apostrophes + i $l(v)>4000 s v=$e(v,1,4000)_".." + ; + s ^c(changeset,"w",wayId,"v",version,"u",u)=v + ; + q + + +apply(changeset,wayId,version) ; Public ; Apply a way from a changeset to the active database + ; + ; TODO: This looks rubbish... + ; Where's ^way(id,seq) get updated? + ; Should update first then calculate bbox after all nodes have been added + ; Should not be writing to ^e(qs,"w"...) + ; Other? + ; + n qsOld,a,delete,qsNew,l + n u,key,value,intValue + ; + s qsOld=$p($g(^way(wayId)),$c(1),1) + ; + s a=^c(changeset,"n",wayId,"v",version,"a") + s delete=($p(a,$c(1),5)="false") + d bbox(wayId,.bllat,.bllon,.trlat,.trlon) + s qsNew=$$bbox^quadString(bllat,bllon,trlat,trlon) + i qsNew="" s qsNew="*" + s $p(a,$c(1),6)=qsNew + ; + ; Update - node + i 'delete d + . ; + . ; If the qs key has changed then delete the old entries + . i qsOld'="",qsOld'=qsNew d + . . k ^e(qsOld,"w",nodeId,"a") + . ; + . ; Update the node with new values + . s ^e(qsNew,"n",nodeId,"a")=$p(a,$c(1),1,6) + ; + ; Update - changeset by version index + s ^wayVersion(wayId,"q")=qsNew + s ^wayVersion(wayId,"v",version)=changeset + s ^wayVersion(wayId,"c",changeset,version)="" + ; + ; Update process elements + s u="" + f d i u="" q + . s u=$o(^c(changeset,"w",wayId,"v",version,"u",u)) i u="" q + . s value=^c(changeset,"w",wayId,"v",version,"u",u) + . d applyTag(qsOld,qsNew,wayId,u,value,changeset,version,delete) + ; + ; Delete all tags that are not on the new version of the way + s u="" + i qsOld'="" f d i u="" q + . s u=$o(^e(qsOld,"w",wayId,"u",u)) i u="" q + . s key=^key(u) + . i 'delete,$d(^c(changeset,"w",wayId,"v",version,"u",u)) q + . s value=^e(qsOld,"w",wayId,"u",u) + . s intValue=value + . i $l(intValue)>100 s intValue=$e(value,1,100)_".." + . i intValue'="" k ^wayx(key,intValue,qsOld,wayId) + . k ^wayx(key,"*",qsOld,wayId) + . k ^e(qsOld,"w",wayId,"u",u) + ; + i delete,qsOld'="" k ^e(qsOld,"w",wayId) + ; + ; Create export index + s ^export($$nowZulu^date(),"w",changeset,wayId,version)="" + ; + q + + +addTagFromChangeset(qsOld,qsNew,nodeId,u,newValue,changeset,version,delete) ; Private ; Update (add/modify/delete) a key/value pair for a node + ; + ; Usage: + ; d updateTag(qsOld,qsNew,nodeId,key,newValue,newChangeset,newVersion,delete) + ; qsOld - qs of the old node. Null if this is a new node with no previous version + ; qsNew - qs of the new node. Null if this tag is to be deleted + ; nodeId - id of the node in question + ; key - the tag's key + ; newValue - the new value of the tag, may be null + ; newChangeset - the id of the changeset for this update + ; newVersion - the version number of the node being updated + ; delete - 1 if the whole node is being deleted, 0 if this is an update + ; + n key,oldValue,intNewValue,intOldValue + ; + s key=^key(u) + ; + s oldValue="" + i qsOld'="" s oldValue=$g(^e(qsOld,"n",nodeId,"u",u)) + ; + s intNewValue=newValue + i $l(newValue)>100 s intNewValue=$e(newValue,1,100)_".." + ; + s intOldValue=oldValue + i $l(oldValue)>100 s intOldValue=$e(oldValue,1,100)_".." + ; + ; Delete the tag and it's indexes if the node is being deleted + i delete d + . ; k ^e(qsOld,"n",nodeId,"u",u) ; Don't actually need to do this becaue the whole node will be deleted anyway + . i intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . k ^nodex(key,"*",qsOld,nodeId) + ; + ; Add/Update the tag for the element + e d + . i (oldValue'=newValue)!(qsOld'=qsNew) d ; Optimisation, can be used when all t tags have gone + . . i qsOld'="",qsOld'=qsNew k ^e(qsOld,"n",nodeId,"u",u) + . . i qsNew'="" s ^e(qsNew,"n",nodeId,"u",u)=newValue + . ; + . ; Update the two key/value indexes + . i (intOldValue'=intNewValue)!(qsOld'=qsNew) d + . . i qsOld'="",intOldValue'="" k ^nodex(key,intOldValue,qsOld,nodeId) + . . i qsNew'="",intNewValue'="" s ^nodex(key,intNewValue,qsNew,nodeId)="" + . . i qsOld'="" k ^nodex(key,"*",qsOld,nodeId) + . . i qsNew'="" s ^nodex(key,"*",qsNew,nodeId)="" + ; + q + + + + + +addDiff(sWay,delete,changeset) ; Public ; Add a way + ; #sWay = stream object containing way + ; + n line,wayId,ndSeq,timestamp,user,uid,version,ok,predecessors + ; + s line=sWay("current") + ; + s wayId=$$getAttribute^osmXml(line,"id") + s timestamp=$$nowZulu^date() + ; + ; New ways + i wayId<0 d + . s oldId=wayId + . l +^id("way") + . s wayId=^id("way")+1 + . s ^id("way")=wayId + . l -^id("way") + . s newId=wayId + . s version=1 + . ; + . ; Add to new item map + . s ^temp($j,"way",oldId)=newId + ; + ; Existing ways + s ok=1 + e d i 'ok q 0 + . s version=$$getAttribute^osmXml(line,"version") + . ; check version match + . i $$currentVersion(wayId)'=version d error409^http("Version mismatch: Provided "_version_", server had: "_$$currentVersion(wayId)_" of Way "_wayId) s ok=0 q ; Version mismatch + . s oldId=wayId + . s newId=wayId + . s version=version+1 + . d delete(wayId,changeset,delete) + ; + s uid=^c(changeset,"t","@uid") + s user=^user(uid,"name") + i user["'" s user=$$xmlEscapeApostrophe(user) + ; + ; Way attributes + d setTag(wayId,"@timestamp",timestamp,changeset,version,delete) + d setTag(wayId,"@user",user,changeset,version,delete) + d setTag(wayId,"@uid",uid,changeset,version,delete) + d setTag(wayId,"@version",version,changeset,version,delete) + d setTag(wayId,"@changeset",changeset,changeset,version,delete) + d setTag(wayId,"@fork",1,changeset,version,delete) + i delete d setTag(wayId,"@visible","false",changeset,version,delete) + ; + ; Changeset by version index + s ^wayVersion(wayId,"v",version)=changeset + s ^wayVersion(wayId,"c",changeset,version)="" + ; + ; Changeset headers + s ^c(changeset)="" + s ^c(changeset,"w",wayId)="" + s ^c(changeset,"w",wayId,"v",version)="" + ; + ; If there are nodes and/or tags then process these + i line'["/>" d + . ; + . s ndSeq=0 + . ; + . s predecessors="" + . f d i line["" q + . . s line=$$read^stream(.sWay) + . . i line["" f d i line["/>" q + . s line=line_$$read^stream(.sWay) + ; + s k=$$getAttribute^osmXml(line,"k") i k="" q + i $l(k)>100 s k=$e(k,1,100)_".." + s v=$$getAttribute^osmXml(line,"v") + i v["'" s v=$$xmlEscapeApostrophe(v) ; The planet export doesn't escape apostrophes + i $l(v)>4000 s v=$e(v,1,4000)_".." + ; + ; Swallow meta:lastEdit tag + i k="meta:lastEdit" q + ; + ; Process meta:id tag + ; If the meta:id is the same as the element's id then swallow it + i k="meta:id",v=wayId q + ; + ; If the meta:id is different then it means that the way has been either merged or split + ; In both cases we add the original id value to this way's predecessor list + i k="meta:id" d q + . f i=1:1:$l(v,";") s predecessorId=$p(v,";",i) i predecessorId'=wayId s predecessors=predecessors_";"_predecessorId + ; + ; Swallow any meta:predecessors tags as these apply only to one version + i k="meta:predecessors" q + ; + i 'delete s ^waytag(wayId,k)=v + s ^c(changeset,"w",wayId,"v",version,"t",k)=v + ; + q + + +indexTags(wayId) ; Private ; Create index entries for a single way + ; + n qsBox,bllat,bllon,trlat,trlon,k,v + ; + ; Calculate the qsRoot for this way + d bbox(wayId,.bllat,.bllon,.trlat,.trlon) + s qsBox=$$bbox^quadString(bllat,bllon,trlat,trlon) + i qsBox="" s qsBox="*" + ; + s k="" + f d i k="" q + . s k=$o(^waytag(wayId,k)) i k="" q + . i k="@xapi:users" q + . i k="@version" q + . i k="@timestamp" q + . i k="@fork" q + . s v=^waytag(wayId,k) + . i v="" q + . i $l(v)>100 s v=$e(v,1,100)_".." + . s ^wayx(k,v,qsBox,wayId)="" + . s ^wayx(k,"*",qsBox,wayId)="" + ; + ; Add a quad string index for the way itself + s ^wayx("*","*",qsBox,wayId)="" + ; + ; Save the qsBox because a node might get moved independently + s ^way(wayId)=qsBox_$c(1)_bllat_$c(1)_bllon_$c(1)_trlat_$c(1)_trlon + q + + +getTag(wayId,tag) ; Public ; Get the value of a tag for a way + ; + i wayId="" q "" + ; + q $g(^waytag(wayId,tag)) + + +setTag(wayId,k,v,changeset,version,delete) ; Private ; Add a tag + ; + i k="" q + i 'delete s ^waytag(wayId,k)=v + s ^c(changeset,"w",wayId,"v",version,"t",k)=v + ; + q + + +xml(indent,wayId,select,meta) ; Public ; Generate xml for a way + ; + n user,uid,timestamp,version,changeset + n xml + ; + s xml="" + ; + i '$$select^osmXml(select,"way") q "" + ; + s indent=indent_" " + ; + s user=$g(^waytag(wayId,"@user")) + s uid=$g(^waytag(wayId,"@uid")) + s timestamp=$g(^waytag(wayId,"@timestamp")) + s version=$g(^waytag(wayId,"@version")) + s changeset=$g(^waytag(wayId,"@changeset")) + ; + s xml=indent_""_$c(13,10) + w xml + s xml="" + ; + d xmlNodes(wayId,indent,select) + ; + ; Inject meta:id tag + i $g(meta) d + . s xml=xml_indent_"" + . s xml=xml_indent_"" + . w xml + . s xml="" + ; + d xmlTags(wayId,indent,select) + s xml=xml_indent_""_$c(13,10) + w xml + s xml="" + ; + q xml + + +xmlNodes(wayId,indent,select) ; Public ; Generate xml for a way's nodes + ; + n ndSeq,xml + ; + s xml="" + ; + i '$$select^osmXml(select,"nd") q "" + ; + s indent=indent_" " + ; + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +xmlTags(id,indent,select) ; Public ; Generate xml for a way's tags + ; + n k,xml + ; + s xml="" + ; + i '$$select^osmXml(select,"tag") q "" + ; + s indent=indent_" " + ; + s k="" + f d i k="" q + . s k=$o(^waytag(id,k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzzzzz" q ; Skip attributes + . i $d(^waytag(id,k))#10=0 q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +bbox(wayId,bllat,bllon,trlat,trlon,recalculate) ; Public ; Calculate the bbox for a way + ; + ; Inputs: + ; recalculate - 0 = used store value if available (default). The stored value may be wrong if nodes have been moved subsequently. + ; 1 = recalculate from current node locations (slow). + ; + n ndSeq,nodeId,latlon,lat,lon,qsBox,way + ; + s recalculate=$g(recalculate)=1 + ; + ; Use previously calculated values if present + i 'recalculate d i bllat'="" q + . s way=$g(^way(wayId)) + . s bllat=$p(way,$c(1),2) + . s bllon=$p(way,$c(1),3) + . s trlat=$p(way,$c(1),4) + . s trlon=$p(way,$c(1),5) + ; + s bllat=999999,bllon=999999,trlat=-999999,trlon=-999999 + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . ; + . ; Ignore if node does not exist (which is possible) + . s qsBox=$$qsBox^node(nodeId) i qsBox="" q + . s latlon=$g(^e(qsBox,"n",nodeId,"l")) i latlon="" q + . ; + . s lat=$p(latlon,$c(1),1) + . s lon=$p(latlon,$c(1),2) + . i lat>trlat s trlat=lat + . i lattrlon s trlon=lon + . i lon100 s value=$e(value,1,100)_".." + . k ^wayx(key,value,qsBox,wayId) + . k ^wayx(key,"*",qsBox,wayId) + ; + k ^waytag(wayId) + ; + ; Delete node index + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i nodeId="" q + . k ^wayByNode(nodeId,wayId) + . i oldChangeset'="" s ^nodeVersion(nodeId,"c",oldChangeset,"w",wayId)=newChangeset + ; + ; Delete way + k ^wayx("*","*",qsBox,wayId) + k ^way(wayId) + ; + q + + +appendUser(users,user) ; Private ; Add user to list of users + ; + s user=$tr(user,",","") ; Remove commas from name + ; + i $$contains^string(users,user,",") q $e(users,1,100) + ; + i users="" s users=user + e s users=users_","_user + q $e(users,1,100) + + +xmlEscapeApostrophe(string) ; Private ; Escape apostrophe + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +hasRealTag(id) ; Public ; Does this way have a real tag? + ; + n hasRealTag,tag + ; + s hasRealTag=0 + s tag="@zzzzzzzzzzzzzz" + f d i tag="" q + . s tag=$o(^waytag(id,tag)) i tag="" q + . s hasRealTag=1,tag="" + ; + q hasRealTag + + +versionAtChangeset(wayId,changeset,wayChangeset,wayVersion) ; Public ; Get the changeset and version that was current at a given changeset time + ; + ; Usage: + ; d versionAtChangeset^way(wayId,changeset,.wayChangeset,.wayVersion) + ; Output: + ; wayChangeset - null if not found + ; wayVersion - null if not found + ; + s wayChangeset=changeset + s wayVersion="" + i '$d(^wayVersion(wayId,"c",wayChangeset)) s wayChangeset=$o(^wayVersion(wayId,"c",wayChangeset),-1) i wayChangeset="" q + s wayVersion=$o(^wayVersion(wayId,"c",wayChangeset,""),-1) i wayVersion="" s wayChangeset="" q + ; + q + + +restWay(string) ; Public ; Single way query + ; + n logId + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + s wayId=step + ; + ; Get next step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Four choices here: + ; / - current way only + ; /full - current way plus current nodes + ; /history - all versions of current way + ; /#version/full - historic way plus historic nodes + s full=0 + i step="" s full=0 + i step="full" s full=1 + i step="history" d restWayHistory(wayId) q + i step?1.n d restWay^wayVersion(wayId,step,string) q + ; + s logId=$$logStart^xapi($$decode^xapi("way/"_wayId_$s(full:"/full",1:"")),"") + ; + ; Bad query? + i wayId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^way(wayId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + k ^temp($j) + ; + ; Add all nodes that belong to this way + s ndSeq="" + i full f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i $d(^temp($j,nodeId)) q + . s ^temp($j,nodeId)="" + . w $$xml^node(indent,nodeId,"node|@*|tag|") + ; + w $$xml(indent,wayId,"way|@*|nd|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + + +restWays(step,string) ; Public ; Multi way query + ; + n logId,wayIds,ok,i,wayId,indent,version,changesetId + ; + s logId=$$logStart^xapi($$decode^xapi(step),"") + ; + s wayIds=$p(step,EQUALS,2) + ; + ; Validate query + s ok=1 + f i=1:1:$l(wayIds,",") d i 'ok q + . s wayId=$p(wayIds,",",i) + . i wayId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") s ok=0 q + . i '$d(^wayVersion(wayId)) d gone^http,logEnd^xapi(logId,0,"410 Gone") s ok=0 q + i 'ok q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Use changeset version in case one of the selected versions has been deleted + f i=1:1:$l(wayIds,",") d + . s wayId=$p(wayIds,",",i) + . s version=$o(^wayVersion(wayId,"v",""),-1) i version="" q + . s changesetId=^wayVersion(wayId,"v",version) + . w $$xml^wayVersion(indent,wayId,changesetId,version,"way|@*|nd|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,i,"") + ; + q + + + +restWayHistory(wayId) ; Public ; All versions of way + ; + n logId,count,indent + n version,changeset + ; + s count=0 + s logId=$$logStart^xapi("way/"_wayId_"/history","") + ; + ; Bad query? + i wayId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^wayVersion(wayId)),$d(^way(wayId)) d q + . w "Status: 307 Moved Temporarily",! + . w "Location: ","http://api.openstreetmap.org/api/0.6/way/"_wayId_"/history",! + . w ! + i '$d(^wayVersion(wayId)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + s indent="" + d osm^xapi(indent) + ; + ; Iterate all versions + s version="" + f d i version="" q + . s version=$o(^wayVersion(wayId,"v",version)) i version="" q + . s changeset=^wayVersion(wayId,"v",version) + . ; + . w $$xml^wayVersion(indent,wayId,changeset,version,"way|@*|nd|tag|") + . s count=count+1 + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,count,"") + ; + q + + +currentVersion(wayId) ; Public ; Return the current version number of a way + ; + ; Usage: s currentVersion=$$currentVersion^way(wayId) + ; Input: + ; wayId - way id, must not be null + ; Output: + ; currentVersion - if the way does not exists then null is returned (if the way has been deleted then the deleted version number is returned) + ; + n version + ; + s version=$o(^wayVersion(wayId,"v",""),-1) + i version="" s version=$g(^waytag(wayId,"@version")) + q version + diff --git a/wayVersion.m b/wayVersion.m new file mode 100644 index 0000000..3458a11 --- /dev/null +++ b/wayVersion.m @@ -0,0 +1,186 @@ +wayVersion ; Way Version Class + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +xmlChangeset(indent,wayId,changeset,select) ; Public ; Generate xml for a way at a specific changeset + ; + n wayChangeset,wayVersion + ; + d versionAtChangeset^way(wayId,changeset,.wayChangeset,.wayVersion) i wayChangeset="" q "" + ; + q $$xml(indent,wayId,wayChangeset,wayVersion,select) + + +xml(indent,wayId,changeset,version,select) ; Public ; Generate xml for a way + ; + ; Usage: + ; w $$xml^wayVersion(indent,wayId,changeset,[version],select) + ; + n a,user,uid,timestamp,visible + n xml + ; + s xml="" + ; + s indent=indent_" " + ; + i $d(^c(changeset,"w",wayId,"v",version,"a")) d + . s a=^c(changeset,"w",wayId,"v",version,"a") + . ; s version=$p(a,$c(1),1) ; we already have this + . ; s changeset=$p(a,$c(1),2) ; we already have this + . s timestamp=$p(a,$c(1),3) + . s uid=$p(a,$c(1),4) + . s user=$g(^user(uid,"name")) + . s visible=$p(a,$c(1),5) i visible="" s visible="true" + e d + . ; s version=$g(^c(changeset,"w",wayId,"v",version,"t","@version")) ; We already have this value + . ; s changeset=$g(^c(changeset,"w",wayId,"v",version,"t","@changeset")) ; We already have this value + . s timestamp=$g(^c(changeset,"w",wayId,"v",version,"t","@timestamp")) + . s uid=$g(^c(changeset,"w",wayId,"v",version,"t","@uid")) + . s user=$g(^c(changeset,"w",wayId,"v",version,"t","@user")) + . s visible=$g(^c(changeset,"w",wayId,"v",version,"t","@visible"),"true") + ; + s xml=indent_""_$c(13,10) + w xml + s xml="" + ; + d xmlNodes(indent,wayId,changeset,version,select) + ; + d xmlTags(indent,wayId,changeset,version,select) + s xml=xml_indent_""_$c(13,10) + w xml + s xml="" + ; + q xml + + +xmlNodes(indent,wayId,changeset,version,select) ; Public ; Generate xml for a way's nodes + ; + n ndSeq,xml + ; + s xml="" + ; + i '$$select^osmXml(select,"nd") q "" + ; + s indent=indent_" " + ; + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^c(changeset,"w",wayId,"v",version,"n",ndSeq)) i ndSeq="" q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + q + + +xmlTags(indent,wayId,changeset,version,select) ; Public ; Generate xml for a way's tags + ; + n k,u,xml + ; + s xml="" + ; + s indent=indent_" " + ; + s k="" + f d i k="" q + . s k=$o(^c(changeset,"w",wayId,"v",version,"t",k)) i k="" q + . i $e(k,1)="@" s k="@zzzzzzzzzzzzzzzz" q + . i $d(^c(changeset,"w",wayId,"v",version,"t",k))#10=0 q + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + ; + s u="" + f d i u="" q + . s u=$o(^c(changeset,"w",wayId,"v",version,"u",u)) i u="" q + . s k=^key(u) + . s xml=xml_indent_""_$c(13,10) + . w xml + . s xml="" + ; + q + + +restWay(wayId,step,string) ; Public ; Single way version + ; + n logId,version,full,changeset,ndSeq,nodeId + ; + ; Get next step + s version=step + s step=$p(string,SLASH,1),string=$p(string,SLASH,2,$l(string)) + ; + ; Two choices here: + ; #version - historic way + ; #version/full - historic way plus historic nodes + s full=0 + i step="" s full=0 + i step="full" s full=1 + ; + s logId=$$logStart^xapi("way/"_wayId_"/"_version_"/"_step,"") + ; + ; Bad query? + i wayId'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + i version'?1.n d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + ; Is it there? + i '$d(^wayVersion(wayId,"v",version)) d gone^http,logEnd^xapi(logId,0,"410 Gone") q + ; + s changeset=^wayVersion(wayId,"v",version) + i '$d(^c(changeset,"w",wayId,"v",version)) d notFound^http,logEnd^xapi(logId,0,"404 Not found") q + ; + d header^http("text/xml") + d xmlProlog^rest("") + ; + k ^temp($j) + ; + s indent="" + d osm^xapi(indent) + ; + ; Add all nodes that belong to this way + s ndSeq="" + i full f d i ndSeq="" q + . s ndSeq=$o(^c(changeset,"w",wayId,"v",version,"n",ndSeq)) i ndSeq="" q + . s nodeId=^c(cchangeset,"w",wayId,"v",version,"n",ndSeq) + . ; + . i $d(^temp($j,nodeId)) q + . s ^temp($j,nodeId)="" + . ; + . w $$xmlChangeset^nodeVersion(indent,nodeId,changeset,"node|@*|tag|") + ; + w $$xml(indent,wayId,changeset,version,"way|@*|nd|tag|") + ; + w indent,"",$c(13,10) + ; + d logEnd^xapi(logId,1,"") + ; + q + diff --git a/wayfix.m b/wayfix.m new file mode 100644 index 0000000..b5062cc --- /dev/null +++ b/wayfix.m @@ -0,0 +1,41 @@ +wayfix ; Fix up way index + ; + m status=^wayfix("status") + i '$d(status("count")) s status("count")=0 + i '$d(status("good")) s status("good")=0 + i '$d(status("bad")) s status("bad")=0 + i '$d(status("tag")) s status("tag")=0 + i '$d(status("wayId")) s status("wayId")="" + ; + s wayId=status("wayId") + f d i wayId="" q + . s wayId=$o(^way(wayId)) i wayId="" q + . s status("count")=status("count")+1 + . i status("count")#1000=0 s status("wayId")=wayId m ^wayfix("status")=status + . d bbox^way(wayId,.a,.b,.c,.d) + . s qsBox=$$bbox^quadString(a,b,c,d) i qsBox="" s qsBox="*" + . i qsBox=^way(wayId) s status("good")=status("good")+1 q + . s status("bad")=status("bad")+1 + . s oldQsBox=^way(wayId) + . ; + . ; Delete old qsIndexes + . s key="" + . f d i key="" q + . . s key=$o(^waytag(wayId,key)) i key="" q + . . s value=^waytag(wayId,key) + . . i value="" q + . . i $l(value)>100 s value=$e(value,1,100)_".." + . . k ^wayx(key,value,oldQsBox,wayId) + . . s ^wayx(key,value,qsBox,wayId)="" + . . ; + . . k ^wayx(key,"*",oldQsBox,wayId) + . . s ^wayx(key,"*",qsBox,wayId)="" + . . ; + . . s status("tag")=status("tag")+1 + . ; + . k ^wayx("*","*",oldQsBox,wayId) + . s ^wayx("*","*",qsBox,wayId)="" + . ; + . s ^way(wayId)=qsBox + q + diff --git a/xapi.c b/xapi.c new file mode 100644 index 0000000..3d4fa18 --- /dev/null +++ b/xapi.c @@ -0,0 +1,25 @@ +#include +#include "gtmxc_types.h" +#define BUF_LEN 1024 +int main(int argc, char *argv[]) +{ + gtm_char_t port[] = "6520"; + gtm_char_t logLevel[] = "0"; + gtm_char_t process[100]; + gtm_char_t msgbuf[BUF_LEN]; + gtm_status_t status; + status = gtm_init(); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + return status; + } + status = gtm_ci("xapi", argv[1], argv[2], argv[3]); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + fprintf(stderr, "%s\n", msgbuf); + return status; + } + return 0; +} diff --git a/xapi.m b/xapi.m new file mode 100644 index 0000000..7c9ff51 --- /dev/null +++ b/xapi.m @@ -0,0 +1,937 @@ +xapi ; OpenStreetMap API 0.6 with extensions + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + ; Test + s constraint("element")=ASTERISK + ;s constraint("kv",1,"key")="restriction" + ;s constraint("kv",1,"value")="no_right_turn" + ;s bllon=14.545898,bllat=50.559799,trlon=14.721680,trlat=50.634557 + ;s bllon=-180,bllat=-90,trlon=180,trlat=90 + s bllon=12.01,bllat=12.01,trlon=12.02,trlat=12.02 + d bbox(bllat,bllon,trlat,trlon,.constraint,"") + q + + +bbox(bllat,bllon,trlat,trlon,constraint,qualifiers) ; Public ; Returns an osm dataset for a bbox and tag selection + ; + ; Constraint object: + ; constraint("element") - which element to select + ; constraint("kv",keySeq,"key")=value + ; constraint("kv",keySeq,"value")=value + ; constraint("way/nd") - if undefined select all ways. If true select ways with at least one node, if false select ways + ; with no nodes. + ; constraint("way/tag") - if undefined select all ways. If true select all ways with at least one tag. If false select + ; all ways with no tags. + ; constraint("node/way") - if undefined select all nodes. If true select just nodes with ways. If false select just + ; nodes without ways. + ; constraint("relation/node") + ; constraint("relation/way") + ; constraint("relation/relation") + ; constraint("relation/tag") + ; + n e,k,v + n gOrderedNodes + n request,logId,qsRoot,bbox,gCount,itemCount,area,continue + n indent,nodeId,wayId,relationId + n i,j + n subElement,gNodeElements,gWayElements,gRelationsElements + n start,midpoint,end,logFile + ; + s e=$g(constraint("element")) + s k=$g(constraint("kv",1,"key")) ; First key if there is one + s v=$g(constraint("kv",1,"value")) + ; + ; Normalise request + i e="" s e=ASTERISK + i k="" s k=ASTERISK + i v="" s v=ASTERISK + i bllat="" s bllat=-90 + i bllon="" s bllon=-180 + i trlat="" s trlat=90 + i trlon="" s trlon=180 + s bllat=+bllat + s bllon=+bllon + s trlat=+trlat + s trlon=+trlon + ; + s request=$$decode(e)_$$decodeKVs(.constraint)_"[bbox="_bllon_","_bllat_","_trlon_","_trlat_"]" + i $g(constraint("way/nd"))=1 s request=request_"[nd]" + i $g(constraint("way/nd"))=0 s request=request_"[not(nd)]" + i $g(constraint("node/tag"))=1 s request=request_"[tag]" ; Applies to ways and relations as well + i $g(constraint("node/tag"))=0 s request=request_"[not(tag)]" ; Applies to ways and relations as well + i $g(constraint("node/way"))=1 s request=request_"[way]" + i $g(constraint("node/way"))=0 s request=request_"[not(way)]" + i $g(constraint("relation/node"))=1 s request=request_"[node]" + i $g(constraint("relation/node"))=0 s request=request_"[not(node)]" + i $g(constraint("relation/way"))=1 s request=request_"[way]" + i $g(constraint("relation/way"))=0 s request=request_"[not(way)]" + i $g(constraint("relation/relation"))=1 s request=request_"[relation]" + i $g(constraint("relation/relation"))=0 s request=request_"[not(relation)]" + ; + ; Qualifiers + s subElement=$p(qualifiers,SLASH,1) + ; + ; Always return the main element and it's attributes + s gNodeElements="node|@*|" + s gWayElements="way|@*|" + s gRelationsElements="relation|@*|" + ; + ; Way qualifiers + i e="way" d + . i subElement="" d + . . s gNodeElements=gNodeElements_"tag|" + . . s gWayElements=gWayElements_"nd|tag|" + . e s gWayElements=gWayElements_subElement + ; + ; Node qualifiers + i e="node" d + . i subElement="" d + . . s gNodeElements=gNodeElements_"tag" ; Default + . e s gNodeElements=gNodeElements_subElement + ; + ; Relation qualifiers + i e="relation" d + . i subElement="" d + . . s gNodeElements=gNodeElements_"tag|" + . . s gWayElements=gWayElements_"nd|tag|" + . . s gRelationsElements=gRelationsElements_"member|tag|" + . e s gRelationsElements=gRelationsElements_subElement + ; + ; Relation qualifiers + i e=ASTERISK d + . i subElement="" d + . . s gNodeElements=gNodeElements_"tag|" + . . s gWayElements=gWayElements_"nd|tag|" + . . s gRelationsElements=gRelationsElements_"member|tag|" + . e d + . . s gNodeElements=gNodeElements_subElement + . . s gWayElements=gWayElements_subElement + . . s gRelationsElements=gRelationsElements_subElement + ; + ; Get the qs for the query + s qsRoot=$$bbox^quadString(bllat,bllon,trlat,trlon) + ; + ; Log the start of the request + s logId=$$logStart(request,qsRoot) + ; + ; + k ^temp($j) + s gCount=0 + ; + s bbox("bllat")=bllat + s bbox("bllon")=bllon + s bbox("trlat")=trlat + s bbox("trlon")=trlon + s bbox("root")=qsRoot + ; + ; Validate for blocked requests + i '$$checkQuery($$decode(e),$$decode(k),$$decode(v),bllat,bllon,trlat,trlon,.reason) d q + . d error1(request,logId,"Your request is for "_reason_" which is too large or a bit silly. Sorry.") + . d logEnd(logId,0,reason) + ; + ; Add to active request index + d requestAdd(request,logId) + ; + ; Write headers + s indent="" + d osm(indent) + w indent,"",$c(13,10) + ; + ; Output nodes in order? + s gOrderedNodes=0 + ; + s continue=1 + ; + ; Hack for Potlatch - only serve main roads at low zoom levels + ;s potlatchHack=$g(%ENV("HTTP_HOST"))="potlatch.fosm.org" + ;i potlatchHack s e="node",k="place",v=ASTERISK ;_BAR_"trunk"_BAR_"primary" ;_BAR_"secondary"_BAR_"tertiary" + ; + ; If normal map request do it the traditional way + i e=ASTERISK,k=ASTERISK,v=ASTERISK d + . s continue=$$map(.bbox) + e d + . i e=ASTERISK d + . . f i=1:1:$l(k,BAR) f j=1:1:$l(v,BAR) s continue=$$elements("node",$$decode($p(k,BAR,i)),$$decode($p(v,BAR,j)),qsRoot,.bbox) i 'continue q + . . i 'continue q + . . f i=1:1:$l(k,BAR) f j=1:1:$l(v,BAR) s continue=$$elements("way",$$decode($p(k,BAR,i)),$$decode($p(v,BAR,j)),qsRoot,.bbox) i 'continue q + . . i 'continue q + . e d + . . f i=1:1:$l(k,BAR) f j=1:1:$l(v,BAR) s continue=$$elements($$decode(e),$$decode($p(k,BAR,i)),$$decode($p(v,BAR,j)),qsRoot,.bbox) i 'continue q + . . i 'continue q + ; + i 'continue d + . ; Generate error and deliberately incomplete xml document if element limit reached + . w indent,"Query limit of ",gCount," elements reached",$c(13,10) + . ; + . ; Add to silly request list + . s ^silly($$decode(e),$$decode(k),$$decode(v),bllat,bllon,trlat,trlon)="over "_gCount_" elements" + ; + ; If ordered nodes then write them all now + s nodeId="" + i continue,gOrderedNodes f d i nodeId="" q + . s nodeId=$o(^temp($j,"node",nodeId)) i nodeId="" q + . w $$xml^node(indent,nodeId,gNodeElements) + ; + s wayId="" + i continue f d i wayId="" q + . s wayId=$o(^temp($j,"way",wayId)) i wayId="" q + . w $$xml^way(indent,wayId,gWayElements,1) + ; + s relationId="" + i continue f d i relationId="" q + . s relationId=$o(^temp($j,"relation",relationId)) i relationId="" q + . w $$xml^relation(indent,relationId,gRelationsElements) + ; + ; Close xml document unless query aborted + i continue w indent,"",$c(13,10) + ; + k ^temp($j) + ; + d logEnd(logId,gCount,"") + ; + ; Remove from request index + d requestDelete(request,logId) + ; + s logFile="muninRequests.log" + o logFile:NEW u logFile w ^munin("apiCalls"),! c logFile + ; + s logFile="muninResponseTotal.log" + o logFile:NEW u logFile w ^munin("responseTotal"),! c logFile + ; + s logFile="muninResponseDB.log" + o logFile:NEW u logFile w ^munin("responseDB"),! c logFile + ; + s logFile="muninResponseIO.log" + o logFile:NEW u logFile w ^munin("responseIO"),! c logFile + ; + q + + +map(oBox) ; Private ; Process a map request + ; + n qsItem,continue + ; + s continue=1 + ; + s qsItem=oBox("root") + i qsItem'="" s continue=$$mapNode(qsItem,.oBox) i 'continue q 0 + ; + f d i qsItem="" q + . s qsItem=$$nextNode(.oBox,qsItem,"*","*") i qsItem="" q + . s continue=$$mapNode(qsItem,.oBox) i 'continue s qsItem="" q + ; + i 'continue q 0 + q 1 + + +mapNode(qsItem,bbox) ; Process a single quadtree + ; + n nodeId,wayId,continue + ; + s continue=1 + ; + s nodeId="" + f d i nodeId="" q + . s nodeId=$o(^e(qsItem,"n",nodeId)) i nodeId="" q + . ; + . ; Check that node is actually within bounding box + . i '$$nodeInBox(qsItem,nodeId,.bbox) q + . s continue=$$node(nodeId,"*","*",.bbox,1) i 'continue s nodeId="" q + . ; + . s wayId="" + . f d i wayId="" q + . . s wayId=$o(^wayByNode(nodeId,wayId)) I wayId="" q + . . s continue=$$way(wayId,"*","*",.bbox,1) i 'continue s wayId="" q + . i 'continue s nodeId="" q + ; + i 'continue q 0 + q 1 + + +checkQuery(e,k,v,bllat,bllon,trlat,trlon,reason) ; Check for silly requests + ; + s reason="" + i '$d(^silly(e,k,v,bllat,bllon,trlat,trlon)) q 1 + ; + s reason=$g(^silly(e,k,v,bllat,bllon,trlat,trlon)) + ; + q 0 + + +elements(e,k,v,qsRoot,bbox) ; + ; + n lat,lon,qsItem,x,continue + ; + i k="" s k="*" + i v="" s v="*" + ; + ; All data in the db is already xml escaped, including indexes, so escape k and v before we use them + s k=$$xmlEscape(k) + s v=$$xmlEscape(v) + ; + s continue=1 + ; + ; Nodes + i e="node" d + . s continue=$$elementNode(k,v,"*",.bbox) i 'continue q + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) s continue=$$elementNode(k,v,qsItem,.bbox) i 'continue q + . i 'continue q + ; + i 'continue q 0 + ; + s qsItem=qsRoot + i e="node" f d i qsItem="" q + . i k="*",v="*" s qsItem=$o(^e(qsItem)) + . e s qsItem=$o(^nodex(k,v,qsItem)) + . i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . s continue=$$elementNode(k,v,qsItem,.bbox) i 'continue s qsItem="" q + ; + i 'continue q 0 + ; + ; Ways + i e="way" d + . s continue=$$elementWay(k,v,"*",.bbox) i 'continue q + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) s continue=$$elementWay(k,v,qsItem,.bbox) i 'continue q + . i 'continue q + ; + i 'continue q 0 + ; + s qsItem=qsRoot + i e="way" f d i qsItem="" q + . s qsItem=$o(^wayx(k,v,qsItem)) i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . s continue=$$elementWay(k,v,qsItem,.bbox) i 'continue s qsItem="" q + ; + i 'continue q 0 + ; + ; Relations + i e="relation" d + . s continue=$$elementRelation(k,v,"*",.bbox) i 'continue q + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) s continue=$$elementRelation(k,v,qsItem,.bbox) i 'continue q + ; + i 'continue q 0 + ; + s qsItem=qsRoot + i e="relation" f d i qsItem="" q + . s qsItem=$o(^relationx(k,v,qsItem)) i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . s continue=$$elementRelation(k,v,qsItem,.bbox) i 'continue s qsItem="" q + ; + i 'continue q 0 + q 1 + + +nextQs(bbox,qsItem) ; Get the next quad tree that is actually in the bbox + ; + n x,nextQs + ; + s nextQs=qsItem + f x=1:1:$l(qsItem) i '$$bboxInQs^quadString(.bbox,$e(qsItem,1,x)) s nextQs=$$incrementQs^quadString($e(qsItem,1,x)) q + ; + q nextQs + + +nextNode(oBox,qsItem,k,v) ; Private ; get the next tile containing a node of the right kind within the bounding box + ; + n i,done,qsLast + ; + s done=0 + f d i done q + . i k="*",v="*" s qsItem=$o(^e(qsItem)) + . e s qsItem=$o(^nodex(k,v,qsItem)) + . i qsItem="" s done=1 q + . ; + . ; If we are not still inside the bbox root area then we are done + . i $e(qsItem,1,$l(oBox("root")))'=oBox("root") s qsItem="",done=1 q + . ; + . ; If we are still inside the bbox area then we have the next tile + . i $$bboxInQs^quadString(.oBox,qsItem) s done=1 q + . ; + . ; Split off the last quad + . s qsLast=$e(qsItem,$l(qsItem)),qsItem=$e(qsItem,1,$l(qsItem)-1) + . ; + . ; Iterate through the remaining tiles at this level + . i "a"[qsLast,$$bboxInQs^quadString(.oBox,qsItem_"b") s qsItem=qsItem_"b",done=1 q + . i "ab"[qsLast,$$bboxInQs^quadString(.oBox,qsItem_"c") s qsItem=qsItem_"c",done=1 q + . i "abc"[qsLast,$$bboxInQs^quadString(.oBox,qsItem_"d") s qsItem=qsItem_"d",done=1 q + . ; + . ; Walk down the tree until we find a tile that is not in the bbox area + . ; This potentially skips large parts of the tree that are outside the box + . f i=1:1:$l(qsItem) i '$$bboxInQs^quadString(.oBox,$e(qsItem,1,i)) q + . ; + . ; Increment to the next tile, then rinse and repeat + . s qsItem=$$incrementQs^quadString($e(qsItem,1,i)) i qsItem="" s done=1 q + ; + q qsItem + + +elementNode(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id,relationId,continue + ; + s continue=1 + ; + s id="" + f d i id="" q + . i k="*",v="*" s id=$o(^e(qsItem,"n",id)) + . e s id=$o(^nodex(k,v,qsItem,id)) + . i id="" q + . ; + . ; Check the node/way constraint + . ; + . i $g(constraint("node/way"))=1,$d(^wayByNode(id))\10=0 q + . i $g(constraint("node/way"))=0,$d(^wayByNode(id))\10=1 q + . ; + . ; Check the node/tag constraint + . i $g(constraint("node/tag"))=1,$$hasRealTag^node(id)=0 q + . i $g(constraint("node/tag"))=0,$$hasRealTag^node(id)=1 q + . ; + . ; Check that node is actually within bounding box + . i '$$nodeInBox(qsItem,id,.bbox) q + . ; + . ; Does node satisfy all predicates + . i '$$nodePredicates(qsItem,id,.constraint) q + . ; + . s continue=$$node(id,k,v,.bbox,1) i 'continue s id="" q + ; + i 'continue q 0 + q 1 + + +node(nodeId,k,v,bbox,relations) ; Add node and all it's relations to workfile + ; + n relationId,continue + ; + i $d(^temp($j,"node",nodeId)) q 1 + i 'gOrderedNodes w $$xml^node(indent,nodeId,gNodeElements) + s ^temp($j,"node",nodeId)="" + ; + s continue=$$elementCounter i 'continue q 0 + ; + ; Optionally select any relations that belong to this node + s relationId="" + i relations f d i relationId="" q + . s relationId=$o(^relationMx("node",nodeId,relationId)) i relationId="" q + . i $d(^temp($j,"relation",relationId)) q + . s ^temp($j,"relation",relationId)="" + . s continue=$$elementCounter i 'continue s relationId="" q + ; + i 'continue q 0 + q 1 + + +elementCounter() ; Private ; Count number of elements selected and abort if limit exceeded + ; + s gCount=gCount+1 i gCount>9999999 q 0 ; Abort + i gCount#100=0 d + . s ^log(logId,"count")=gCount + . i gCount=5000 d renice(5) + . i gCount=50000 d renice(10) + . i gCount=500000 d renice(15) + . ; + . ; Pause to allow quick queries to complete + . i gCount>500,gCount#500=0 h 2 + . i gCount>5000,gCount#100=0 h 4 + . i gCount>50000,gCount#100=0 h 8 + q 1 + + +elementWay(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id,continue + ; + s continue=1 + ; + s id="" + f d i id="" q + . s id=$o(^wayx(k,v,qsItem,id)) i id="" q + . ; + . ; Check the way/nd constraint + . i $g(constraint("way/nd"))=0,$d(^way(id))\10=1 q + . i $g(constraint("way/nd"))=1,$d(^way(id))\10=0 q + . ; + . ; Check the way/tag constraint + . i $g(constraint("way/tag"))=0,$$hasRealTag^way(id)=1 q + . i $g(constraint("way/tag"))=1,$$hasRealTag^way(id)=0 q + . ; + . ; Does way satisfy all predicates + . i '$$wayPredicates(id,.constraint) q + . ; + . ; Check that the way is actually within the bounding box + . i '$$wayInBox(id,.bbox) q + . ; + . s continue=$$way(id,k,v,.bbox,1) i 'continue s id="" q + ; + i 'continue q 0 + q 1 + + +way(wayId,k,v,bbox,relations) ; Add way and all it's nodes and relations to workfile + ; + n ndSeq,nodeId,relationId + ; + ; Has the way already been selected? + i $d(^temp($j,"way",wayId)) q 1 + s ^temp($j,"way",wayId)="" + ; + s continue=$$elementCounter i 'continue q 0 + ; + ; Add all nodes that belong to this way + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i $d(^temp($j,"node",nodeId)) q + . i 'gOrderedNodes w $$xml^node(indent,nodeId,gNodeElements) + . s ^temp($j,"node",nodeId)="" + . s continue=$$elementCounter i 'continue s ndSeq="" q + . ; + . ; Optionally select any relations that belong to this node + . s relationId="" + . i relations f d i relationId="" q + . . s relationId=$o(^relationMx("node",nodeId,relationId)) i relationId="" q + . . i $d(^temp($j,"relation",relationId)) q + . . s ^temp($j,"relation",relationId)="" + . . s continue=$$elementCounter i 'continue s relationId="" q + ; + i 'continue q 0 + ; + ; Optionally, add all relations that belong to this way + s relationId="" + i relations f d i relationId="" q + . s relationId=$o(^relationMx("way",wayId,relationId)) i relationId="" q + . i $d(^temp($j,"relation",relationId)) q + . s ^temp($j,"relation",relationId)="" + . s continue=$$elementCounter i 'continue s relationId="" q + ; + i 'continue q 0 + q 1 + + +elementRelation(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id,continue + ; + s continue=1 + ; + s id="" + f d i id="" q + . s id=$o(^relationx(k,v,qsItem,id)) i id="" q + . ; + . ; Check the relation/node constraint + . i $g(constraint("relation/node"))=0,$d(^relation(id,"node"))\10=1 q + . i $g(constraint("relation/node"))=1,$d(^relation(id,"node"))\10=0 q + . ; + . ; Check the relation/way constraint + . i $g(constraint("relation/way"))=0,$d(^relation(id,"way"))\10=1 q + . i $g(constraint("relation/way"))=1,$d(^relation(id,"way"))\10=0 q + . ; + . ; Check the relation/relation constraint + . i $g(constraint("relation/relation"))=0,$d(^relation(id,"relation"))\10=1 q + . i $g(constraint("relation/relation"))=1,$d(^relation(id,"relation"))\10=0 q + . ; + . ; Check the relation/tag constraint + . i $g(constraint("relation/tag"))=0,$$hasRealTag^relation(id)=1 q + . i $g(constraint("relation/tag"))=1,$$hasRealTag^relation(id)=0 q + . ; + . ; Does relation satisfy all predicates + . i '$$relationPredicates(id,.constraint) q + . ; + . ; Check that the way is actually within the bounding box + . i '$$relationInBox(id,.bbox) q + . s continue=$$relation(id,k,v,.bbox) i 'continue s id="" q + ; + i 'continue q 0 + q 1 + + +relation(relationId,k,v,bbox) ; Add relation and all it's constituent elements to workfile + ; + n seq,type,ref,continue + ; + ; Has the relation already been selected? + i $d(^temp($j,"relation",relationId)) q 1 + s ^temp($j,"relation",relationId)="" + s continue=$$elementCounter i 'continue q 0 + ; + ; Add all elements that belong to this relation + s seq="" + f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . s ref=$g(^relation(relationId,"seq",seq,"ref")) + . s type=$g(^relation(relationId,"seq",seq,"type")) + . ; + . ; If it's a relation then add the relation recursively + . i type="relation" s continue=$$relation(ref,k,v,.bbox) i 'continue s seq="" q + . ; + . ; If it's a node then add the node, but not the node's relations + . i type="node" s continue=$$node(ref,k,v,.bbox,0) i 'continue s seq="" q + . ; + . ; If it's a way then add the way's nodes, but not its relations + . i type="way" s continue=$$way(ref,k,v,.bbox,0) i 'continue s seq="" q + ; + i 'continue q 0 + q 1 + + +nodeInBox(qsItem,nodeId,bbox) ; Is a node within the bbox? + ; + n lat,lon,latlon + ; + ; Coarse check, is the item within the qsBox of the bbox? + ; If it isn't then it is definitely not in the bbox. + i $e(qsItem,1,$l(bbox("root")))'=bbox("root") q 0 + ; + ; Precise check + s latlon=$g(^e(qsItem,"n",nodeId,"l")) i latlon="" q 0 + s lat=$p(latlon,$c(1),1) + i latbbox("trlat") q 0 + ; + s lon=$p(latlon,$c(1),2) + i lonbbox("trlon") q 0 + q 1 + + +wayInBox(wayId,bbox) ; Is a way within the bbox? + ; Stop looking as soon as we find one node that is actually within the bbox + ; + n wayInBox,ndSeq,nodeId + ; + ; Coarse check, does the qsBox of the way overlap with the qsBox of the bbox + ; If it doesn't then the way cannot be in the bbox. + i '$$qsOverlap(^way(wayId),bbox("root")) q 0 + ; + s wayInBox=0 + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i $$nodeInBox($$qsBox^node(nodeId),nodeId,.bbox) s wayInBox=1,ndSeq="" q + ; + q wayInBox + + +qsOverlap(qsBox1,qsBox2) ; Do two qsBoxes overlap? + ; + i qsBox1=qsBox2 q 1 + i $l(qsBox1)>$l(qsBox2),$e(qsBox1,1,$l(qsBox2))=qsBox2 q 1 + i $l(qsBox2)>$l(qsBox1),$e(qsBox2,1,$l(qsBox1))=qsBox1 q 1 + q 0 + + +relationInBox(relationId,bbox) ; Is a relation within the bbox? + ; + ; Iterate through all elements of the relation and test whether any of them + ; are in the bbox. It only needs one. + ; + n ok,seq,ref,type + ; + s ok=0 + s seq="" + f d i seq="" q + . s seq=$o(^relation(relationId,"seq",seq)) i seq="" q + . s ref=$g(^relation(relationId,"seq",seq,"ref")) + . s type=$g(^relation(relationId,"seq",seq,"type")) + . ; + . ; If it's a relation, then check that recursively + . i type="relation",$$relationInBox(ref,.bbox) s ok=1,seq="" q + . ; + . ; If it's a node then check if it's in the box + . i type="node",$$nodeInBox($$qsBox^node(ref),ref,.bbox) s ok=1,seq="" q + . ; + . ; If it's a way then check if it's in the box + . i type="way",$$wayInBox(ref,.bbox) s ok=1,seq="" q + ; + i ok q 1 + q 0 + + +nodePredicates(qsItem,id,constraint) ; Check whether a node satisfies all predicates + ; + n keyOk,valueOk,keySeq,cKey,cValue,key,u,value,i,j + ; + ; Need to get a match on all keys + s keyOk=1 + s keySeq=1 ; Skip first constraint as that must already be satisfied + f d i keySeq="" q + . s keySeq=$o(constraint("kv",keySeq)) i keySeq="" q + . s cKey=constraint("kv",keySeq,"key") + . s cValue=constraint("kv",keySeq,"value") + . ; + . ; For this key constraint check whether any values match + . s valueOk=0 + . f i=1:1:$l(cKey,BAR) s key=$p(cKey,BAR,i) d i valueOk=1 q + . . ; + . . s u=^keyx(key) ; TODO: do this earlier, maybe make constraint("uv",...) also what if key="@timestamp" need a solution... + . . ; + . . ; Need to match any one of the alternate values + . . f j=1:1:$l(cValue,BAR) s value=$p(cValue,BAR,j) d i valueOk q + . . . i value=$g(^e(qsItem,"n",id,"t",key)) s valueOk=1 q + . . . i value=ASTERISK,$d(^e(qsItem,"n",id,"t",key)) s valueOk=1 q + . . . i value=$g(^e(qsItem,"n",id,"u",u)) s valueOk=1 q + . . . i value=ASTERISK,$d(^e(qsItem,"n",id,"u",u)) s valueOk=1 q + . i 'valueOk s keyOk=0,cKey="" q + ; + q keyOk + + +wayPredicates(id,constraint) ; Check whether a way satisfies all predicates + ; + n keyOk,valueOk,keySeq,cKey,cValue,key,value,i,j + ; + ; Need to get a match on all keys + s keyOk=1 + s keySeq=1 ; Skip first constraint as that must already be satisfied + f d i keySeq="" q + . s keySeq=$o(constraint("kv",keySeq)) i keySeq="" q + . s cKey=constraint("kv",keySeq,"key") + . s cValue=constraint("kv",keySeq,"value") + . ; + . ; For this key constraint check whether any values match + . s valueOk=0 + . f i=1:1:$l(cKey,BAR) s key=$p(cKey,BAR,i) d i valueOk=1 q + . . ; + . . ; Need to match any one of the alternate values + . . f j=1:1:$l(cValue,BAR) s value=$p(cValue,BAR,j) d i valueOk q + . . . i value=$g(^waytag(id,key)) s valueOk=1 q + . . . i value=ASTERISK,$d(^waytag(id,key)) s valueOk=1 q + . i 'valueOk s keyOk=0,cKey="" q + ; + q keyOk + + +relationPredicates(id,constraint) ; Check whether a way satisfies all predicates + ; + n keyOk,valueOk,keySeq,cKey,cValue,key,value,i,j + ; + ; Need to get a match on all keys + s keyOk=1 + s keySeq=1 ; Skip first constraint as that must already be satisfied + f d i keySeq="" q + . s keySeq=$o(constraint("kv",keySeq)) i keySeq="" q + . s cKey=constraint("kv",keySeq,"key") + . s cValue=constraint("kv",keySeq,"value") + . ; + . ; For this key constraint check whether any values match + . s valueOk=0 + . f i=1:1:$l(cKey,BAR) s key=$p(cKey,BAR,i) d i valueOk=1 q + . . ; + . . ; Need to match any one of the alternate values + . . f j=1:1:$l(cValue,BAR) s value=$p(cValue,BAR,j) d i valueOk q + . . . i value=$g(^relationtag(id,key)) s valueOk=1 q + . . . i value=ASTERISK,$d(^relationtag(id,key)) s valueOk=1 q + . i 'valueOk s keyOk=0,cKey="" q + ; + q keyOk + + +requestAdd(request,job) ; Add request to request index + ; + s ^requestx(request,job)="" + q + + +requestDelete(request,job) ; Delete request from request index + ; + k ^requestx(request,job) + q + + +error(e,k,v,bbox,itemCount,area,logId) ; Error response + ; + n f + ; + ; Round the item count to avoid being too precise about it all + s f=10**($l($j(itemCount,0,0))-2) + s itemCount=itemCount\f*f + ; + w "",! + w "BETA: we are testing a request validation mechanism to filter out silly requests. If you have made",! + w " what you think is a sensible request that is being rejected please let me know (80n80n@gmail.com). ",! + w ! + w "Your request (",e,"/",k,"/",v,") " + i itemCount>0 w "would select about ",itemCount," elements and " + w "spans ",$j(area/64800*100,0,2),"% of the planet, which is too large. Please check your request. ",! + w "If you really do need this data then it may be better to get it directly from a planet file.",! + w " Log ID=",logId," ",! + w "",! + q + + +error1(request,logId,message) ; Generate an error response + ; + w "",$c(13,10) + w "Request: ",request,$c(13,10) + w message,$c(13,10) + w "LogId: ",logId,$c(13,10) + w "Contact: 80n80n@gmail.com for assistance",$c(13,10) + w "",$c(13,10) + q + + +fixApostrophe(string) ; Private ; Temporarily fix up apostrophes until the data is all fixed + ; Usage: + ; s xmlString=$$fixApostrophe(string) + ; Inputs: + ; string = string to be escaped + ; Outputs: + ; $$toXml = escaped string + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +xmlEscape(string) ; Private ; Escape a string using character entities + ; Usage: + ; s xmlString=$$xmlEscape(string) + ; Inputs: + ; string = string to be escaped + ; Output: + ; $$xmlEscape = escaped string + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i c="'" s out=out_"'" q + . i c="""" s out=out_""" q + . i c="&" s out=out_"&" q + . i c="<" s out=out_"<" q + . i c=">" s out=out_">" q + . s out=out_c + q out + + +renice(nice) ; Private ; Increase the niceness of this process + ; + zsystem "renice +"_nice_" -p "_$j_" >/dev/null" + q + + +decodeKVs(constraint) ; Private ; Decode key/value constraints + ; + n request,keySeq,key,value + ; + s request="" + s keySeq="" + f d i keySeq="" q + . s keySeq=$o(constraint("kv",keySeq)) i keySeq="" q + . s key=constraint("kv",keySeq,"key") + . s value=constraint("kv",keySeq,"value") + . s request=request_"["_$$decode(key)_"="_$$decode(value)_"]" + ; + q request + + +decode(string) ; Public ; Decode a query string + q $tr(string,EQUALS_LEFTBRACKET_RIGHTBRACKET_BAR_SLASH_ASTERISK,"=[]|/*") + + +encode(string) ; Public ; Encode a query string + q $tr(string,"=[]|/*",EQUALS_LEFTBRACKET_RIGHTBRACKET_BAR_SLASH_ASTERISK) + + +osm(indent) ; Public ; Generate element + ; + ; Note: We need to keep the headers all on one line as t@h can't cope + ; with a multi-line header. It assumes just one line. + ; + w indent,"",$c(13,10) + ; + q + +osmChange(indent) ; Public ; Generate element + ; + ; Note: We need to keep the headers all on one line as t@h can't cope + ; with a multi-line header. It assumes just one line. + ; + w indent,"",$c(13,10) + ; + q + + +logStart(request,qsRoot) ; Public ; Log the start of a query + ; + n logId + ; + l +^log + s logId=$g(^log)+1 + s ^log=logId + l -^log + ; + s ^log(logId,"start")=$h + s ^log(logId,"pid")=$j + s ^log(logId,"ip")=$g(%ENV("REMOTE_ADDR")) + s ^log(logId,"userAgent")=$g(%ENV("HTTP_USER_AGENT")) + ; + s ^log(logId,"request")=request + s ^log(logId,"qs")=qsRoot + ; + q logId + + +logEnd(logId,count,error) ; Public ; Log the end of a query + ; + n start,end + ; + s ^log(logId,"count")=count + s ^log(logId,"end")=$h + i error'="" s ^log(logId,"error")=error + ; + ; Calculate duration + s start=^log(logId,"start") + s end=^log(logId,"end") + s start=$p(start,",",1)*86400+$p(start,",",2) + s end=$p(end,",",1)*86400+$p(end,",",2) + s ^log(logId,"duration")=end-start + ; + ; Update munin counts + l +^munin + s ^munin("apiCalls")=$g(^munin("apiCalls"))+1 + s ^munin("responseTotal")=$g(^munin("responseTotal"))+^log(logId,"duration") + l -^munin + q + diff --git a/xapi_old.m b/xapi_old.m new file mode 100644 index 0000000..7f53d89 --- /dev/null +++ b/xapi_old.m @@ -0,0 +1,660 @@ +xapi ; OpenStreetMap API 0.5 with extensions + ; Copyright (C) 2008 Etienne Cherdlu <80n80n@gmail.com> + ; + ; This program is free software: you can redistribute it and/or modify + ; it under the terms of the GNU Affero General Public License as + ; published by the Free Software Foundation, either version 3 of the + ; License, or (at your option) any later version. + ; + ; This program is distributed in the hope that it will be useful, + ; but WITHOUT ANY WARRANTY; without even the implied warranty of + ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + ; GNU Affero General Public License for more details. + ; + ; You should have received a copy of the GNU Affero General Public License + ; along with this program. If not, see . + + +bbox(bllat,bllon,trlat,trlon,constraint,qualifiers) ; Public ; Returns an osm dataset for a bbox and tag selection + ; + ; Constraint object: + ; constraint("element") - which element to select + ; constraint("key",key,"value")=value + ; constraint("way/nd") - if undefined select all ways. If true select ways with at least one node, if false select ways + ; with no nodes. + ; constraint("way/tag") - if undefined select all ways. If true select all ways with at least one tag. If false select + ; all ways with no tags. + ; constraint("node/way") - if undefined select all nodes. If true select just nodes with ways. If false select just + ; nodes without ways. + ; constraint("relation/node") + ; constraint("relation/way") + ; constraint("relation/relation") + ; constraint("relation/tag") + + n gOrderedNodes + n request,logId,qsRoot,bbox,gCount,itemCount + n indent,nodeId,wayId,relationId + n i,j + n subElements,gNodeElements,gWayElements,gRelationsElements + ; + s e=$g(constraint("element")) + s k=$o(constraint("key","")) ; First key only for now + s v="" i k'="" s v=constraint("key",k,"value") + ; + ; Normalise request + i e="" s e="*" + i k="" s k="*" + i v="" s v="*" + ; + l +^log + s ^log=$g(^log)+1 + s logId=^log + l -^log + ; + ; + s request=e_"["_k_"="_v_"][bbox="_bllon_","_bllat_","_trlon_","_trlat_"]" + i $g(constraint("way/nd"))=1 s request=request_"[nd]" + i $g(constraint("way/nd"))=0 s request=request_"[not(nd)]" + i $g(constraint("node/tag"))=1 s request=request_"[tag]" ; Applies to ways and relations as well + i $g(constraint("node/tag"))=0 s request=request_"[not(tag)]" ; Applies to ways and relations as well + i $g(constraint("node/way"))=1 s request=request_"[way]" + i $g(constraint("node/way"))=0 s request=request_"[not(way)]" + i $g(constraint("relation/node"))=1 s request=request_"[node]" + i $g(constraint("relation/node"))=0 s request=request_"[not(node)]" + i $g(constraint("relation/way"))=1 s request=request_"[way]" + i $g(constraint("relation/way"))=0 s request=request_"[not(way)]" + i $g(constraint("relation/relation"))=1 s request=request_"[relation]" + i $g(constraint("relation/relation"))=0 s request=request_"[not(relation)]" + ; + ; Qualifiers + s subElement=$p(qualifiers,"/",1) + ; + ; Way qualifiers - can be e|e|e + s gWayElements="way|@*|" + i e="*"!(e["way") d + . i subElement="" s gWayElements=gWayElements_"nd|tag" ; Default + . e s gWayElements=gWayElements_subElements + ; + ; Node qualifiers + s gNodeElements="node|@*|" + i e="*"!(e["node") d + . i subElement="" s gNodeElements=gNodeElements_"tag" ; Default + . e s gNodeElements=gNodeElements_subElement + ; + ; Relation qualifiers + s gRelationsElements="relation|@*|" + i e="*"!(e["relation") d + . i subElement="" s gRelationsElements=gRelationsElements_"member|tag" ; Default + . e s gRelationsElements=gRelationsElements_subElement + ; + s ^log(logId,"request")=request + s ^log(logId,"start")=$h + s ^log(logId,"pid")=$j + s ^log(logId,"ip")=$g(%ENV("REMOTE_ADDR")) + s ^log(logId,"userAgent")=$g(%ENV("HTTP_USER_AGENT")) + ; + s qsRoot=$$bbox^quadString(bllat,bllon,trlat,trlon) + s ^log(logId,"qs")=qsRoot + ; + ; + k ^osmTemp($j) + s gCount=0 + s gNodeHit=0 ; In bbox + s gNodeMiss=0 ; Not in bbox + ; + s qsRoot=$$bbox^quadString(bllat,bllon,trlat,trlon) + ; + s bbox("bllat")=bllat + s bbox("bllon")=bllon + s bbox("trlat")=trlat + s bbox("trlon")=trlon + s bbox("root")=qsRoot + ; + s ^log(logId,"qs")=qsRoot + ; + ; Validate request size + i k'["!",'$$checkSize(e,k,v,.bbox,.itemCount,.area) d q + . d error(e,k,v,.bbox,itemCount,area,logId) + . s ^log(logId,"error")=e_" "_k_" "_v_" "_qsRoot_" "_itemCount_" "_area + . d requestDelete(request,logId) + ; + ; Check for duplicate request + i $d(^requestx(request)) d q + . d error1(request,logId,"Duplicate request. You or someone else already made this request recently and it is still being processed. Please try later.") + . s ^log(logId,"error")="Duplicate "_request + ; + ; Add to active request index + d requestAdd(request,logId) + ; + ; Write headers + ; Need to keep the headers all on one line as t@h can't cope with a multi-line header. It assumes just one line. + s indent="" + w indent,"",$c(13,10) + ; + ; Output nodes in order? + s gOrderedNodes=0 + ; + ; If normal map request do it the traditional way + i e="*",k="*",v="*" d + . d map(.bbox) + e d + . i e="*" d + . . f i=1:1:$l(k,"|") f j=1:1:$l(v,"|") d elements("node",$p(k,"|",i),$p(v,"|",j),qsRoot,.bbox) + . . f i=1:1:$l(k,"|") f j=1:1:$l(v,"|") d elements("way",$p(k,"|",i),$p(v,"|",j),qsRoot,.bbox) + . . ;f i=1:1:$l(k,"|") f j=1:1:$l(v,"|") d elements("relation",$p(k,"|",i),$p(v,"|",j),qsRoot,.bbox) + . e f i=1:1:$l(k,"|") f j=1:1:$l(v,"|") d elements(e,$p(k,"|",i),$p(v,"|",j),qsRoot,.bbox) + ; + s ^log(logId,"midpoint")=$h + ; + ; If ordered nodes then write them all now + i gOrderedNodes s nodeId="" f d i nodeId="" q + . s nodeId=$o(^osmTemp($j,"node",nodeId)) i nodeId="" q + . w $$xml^node(indent,nodeId,gNodeElements) + ; + s wayId="" + f d i wayId="" q + . s wayId=$o(^osmTemp($j,"way",wayId)) i wayId="" q + . w $$xml^way(indent,wayId,gWayElements) + ; + s relationId="" + f d i relationId="" q + . s relationId=$o(^osmTemp($j,"relation",relationId)) i relationId="" q + . w $$xml^relation(indent,relationId,gRelationsElements) + ; + ; Generate error and deliberately incomplete xml document if element limit reached + i gCount>1000000 w indent,"Query limit of 1,000,000 elements reached",$c(13,10) + e w indent,"",$c(13,10) + ; + k ^osmTemp($j) + ; + s ^log(logId,"end")=$h + s start=^log(logId,"start") + s midpoint=^log(logId,"midpoint") + s end=^log(logId,"end") + s start=$p(start,",",2) + s midpoint=$p(midpoint,",",2) + s end=$p(end,",",2) + i midpoint1000000 s qsItem="" q ; Abort + q + + +mapNode(qsItem,bbox) ; Process a single quadtree + ; + n nodeId,wayId + ; + s nodeId="" + f d i nodeId="" q + . s nodeId=$o(^nodex("*","*",qsItem,nodeId)) i nodeId="" q + . ; + . s gCount=gCount+1 + . i gCount#1000=0 s ^log(logId,"count")=gCount i gCount>1000000 s nodeId="" q ; Abort + . ; + . ; Check that node is actually within bounding box + . i '$$nodeInBox(nodeId,.bbox) s gNodeMiss=gNodeMiss+1 q + . d node(nodeId,"*","*",.bbox,1) + . s gNodeHit=gNodeHit+1 + . ; + . s wayId="" + . f d i wayId="" q + . . s wayId=$o(^wayByNode(nodeId,wayId)) I wayId="" q + . . d way(wayId,"*","*",.bbox,1) + q + + +checkSize(e,k,v,bbox,itemCount,area) ; Check the size of the request + ; + n lat,lon + n i,j,k1,v1 + ; + ; Normalise arguments + i k="" s k="*" + i v="" s v="*" + ; + ; Calculate area of bbox + s lat=(bbox("trlat")+90)-(bbox("bllat")+90) + s lon=(bbox("trlon")+180)-(bbox("bllon")+180) + s area=lat*lon + ; + ; Count nodes (divide by 20 as they are less expensive than ways) + s itemCount=0 + i (e="node")!(e="*") f i=1:1:$l(k,"|") d + . s k1=$p(k,"|",i) + . i k1="" q + . f j=1:1:$l(v,"|") d + . . s v1=$p(v,"|",j) + . . i v1="" q + . . s itemCount=itemCount+($g(^count("nodekv",k1,v1))/20) + ; + ; Count ways + i (e="way")!(e="*") f i=1:1:$l(k,"|") d + . s k1=$p(k,"|",i) + . i k1="" q + . f j=1:1:$l(v,"|") d + . . s v1=$p(v,"|",j) + . . i v1="" q + . . s itemCount=itemCount+$g(^count("waykv",k1,v1)) + ; + ; Allow requests for small areas even if the count is large + i itemCount>1000000,area>100 q 0 + i itemCount>100000,area>1000 q 0 + ; + ; Check bbox for [*=*] requests, * is not yet in ^count + i k="*",v="*",area>100 q 0 + ; + q 1 + + +elements(e,k,v,qsRoot,bbox) ; + ; + n lat,lon,qsItem,x + ; + i k="" s k="*" + i v="" s v="*" + ; + ; All data in the db is already xml escaped, including indexes, so escape k and v before we use them + s k=$$xmlEscape(k) + s v=$$xmlEscape(v) + ; + ; Nodes + i e="node" d + . d elementNode(k,v,"*",.bbox) + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) d elementNode(k,v,qsItem,.bbox) + ; + s qsItem=qsRoot + i e="node" f d i qsItem="" q + . s qsItem=$o(^nodex(k,v,qsItem)) i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . d elementNode(k,v,qsItem,.bbox) + . s gCount=gCount+1 + . i gCount#10000=0 s ^log(logId,"count")=gCount i gCount>1000000 s qsItem="" q ; Abort + ; + ; Ways + i e="way" d + . d elementWay(k,v,"*",.bbox) + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) d elementWay(k,v,qsItem,.bbox) + ; + s qsItem=qsRoot + i e="way" f d i qsItem="" q + . s qsItem=$o(^wayx(k,v,qsItem)) i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . d elementWay(k,v,qsItem,.bbox) + . s gCount=gCount+1 + . i gCount#10000=0 s ^log(logId,"count")=gCount i gCount>1000000 s qsItem="" q ; Abort + ; + ; + ; Relations + i e="relation" d + . d elementRelation(k,v,"*",.bbox) + . f x=1:1:$l(qsRoot) s qsItem=$e(qsRoot,1,x) d elementRelation(k,v,qsItem,.bbox) + ; + s qsItem=qsRoot + i e="relation" f d i qsItem="" q + . s qsItem=$o(^relationx(k,v,qsItem)) i qsItem="" q + . i $e(qsItem,1,$l(qsRoot))'=qsRoot s qsItem="" q + . i '$$bboxInQs^quadString(.bbox,qsItem) s qsItem=$$nextQs(.bbox,qsItem) i qsItem="" q + . d elementRelation(k,v,qsItem,.bbox) + . s gCount=gCount+1 + . i gCount#10000=0 s ^log(logId,"count")=gCount i gCount>1000000 s qsItem="" q ; Abort + ; + q + + +nextQs(bbox,qsItem) ; Get the next quad tree that is actually in the bbox + ; + n x,nextQs + ; + s nextQs=qsItem + f x=1:1:$l(qsItem) i '$$bboxInQs^quadString(.bbox,$e(qsItem,1,x)) s nextQs=$$incrementQs^quadString($e(qsItem,1,x)) q + ; + q nextQs + + +nextNode(oBox,qsItem,k,v) ; Private ; get the next tile containing a node of the right kind within the bounding box + ; + n i,done + ; + s done=0 + f d i done q + . s qsItem=$o(^nodex(k,v,qsItem)) i qsItem="" s done=1 q + . ; + . ; If we are not still inside the bbox root area then we are done + . i $e(qsItem,1,$l(oBox("root")))'=oBox("root") s qsItem="",done=1 q + . ; + . ; If we are still inside the bbox area then we have the next tile + . i $$bboxInQs^quadString(.oBox,qsItem) s done=1 q + . ; + . ; Walk down the tree until we find a tile that is not in the bbox area + . ; This potentially skips large parts of the tree that are outside the box + . f i=1:1:$l(qsItem) i '$$bboxInQs^quadString(.oBox,$e(qsItem,1,i)) q + . ; + . ; Increment to the next tile, then rinse and repeat + . s qsItem=$$incrementQs^quadString($e(qsItem,1,i)) i qsItem="" s done=1 q + ; + q qsItem + + +elementNode(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id,relationId + ; + s id="" + f d i id="" q + . s id=$o(^nodex(k,v,qsItem,id)) i id="" q + . ; + . ; Check the node/way constraint + . ; + . i $g(constraint("node/way"))=1,$d(^wayByNode(id))\10=0 q + . i $g(constraint("node/way"))=0,$d(^wayByNode(id))\10=1 q + . ; + . ; Check the node/tag constraint + . i $g(constraint("node/tag"))=1,$$hasRealTag^node(id)=0 q + . i $g(constraint("node/tag"))=0,$$hasRealTag^node(id)=1 q + . ; + . ; Check that node is actually within bounding box + . i $$nodeInBox(id,.bbox) d node(id,k,v,.bbox,1) + q + + +node(nodeId,k,v,bbox,relations) ; Add node and all it's relations to workfile + ; + n relationId + ; + i $d(^osmTemp($j,"node",nodeId)) q + i 'gOrderedNodes w $$xml^node(indent,nodeId,gNodeElements) + s ^osmTemp($j,"node",nodeId)="" + ; + ; Optionally select any relations that belong to this node + s relationId="" + i relations f d i relationId="" q + . s relationId=$o(^relationMx("node",nodeId,relationId)) i relationId="" q + . i '$d(^osmTemp($j,"relation",relationId)) s ^osmTemp($j,"relation",relationId)="" + ; + q + + +elementWay(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id + ; + s id="" + f d i id="" q + . s id=$o(^wayx(k,v,qsItem,id)) i id="" q + . ; + . ; Check the way/nd constraint + . i $g(constraint("way/nd"))=0,$d(^way(id))\10=1 q + . i $g(constraint("way/nd"))=1,$d(^way(id))\10=0 q + . ; + . ; Check the way/tag constraint + . i $g(constraint("way/tag"))=0,$$hasRealTag^way(id)=1 q + . i $g(constraint("way/tag"))=1,$$hasRealTag^way(id)=0 q + . ; + . ; Check that the way is actually within the bounding box + . i $$wayInBox(id,.bbox) d way(id,k,v,.bbox,1) + q + + +way(wayId,k,v,bbox,relations) ; Add way and all it's nodes and relations to workfile + ; + n ndSeq,nodeId,relationId + ; + ; Has the way already been selected? + i $d(^osmTemp($j,"way",wayId)) q + s ^osmTemp($j,"way",wayId)="" + ; + ; Add all nodes that belong to this way + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i $d(^osmTemp($j,"node",nodeId)) q + . i 'gOrderedNodes w $$xml^node(indent,nodeId,gNodeElements) + . s ^osmTemp($j,"node",nodeId)="" + ; + ; Optionally, add all relations that belong to this way + s relationId="" + i relations f d i relationId="" q + . s relationId=$o(^relationMx("way",wayId,relationId)) i relationId="" q + . i '$d(^osmTemp($j,"relation",relationId)) s ^osmTemp($j,"relation",relationId)="" + ; + q + + +elementRelation(k,v,qsItem,bbox) ; Process a single quadtree + ; + n id + ; + s id="" + f d i id="" q + . s id=$o(^relationx(k,v,qsItem,id)) i id="" q + . ; + . ; Check the relation/node constraint + . i $g(constraint("relation/node"))=0,$d(^relation(id,"node"))\10=1 q + . i $g(constraint("relation/node"))=1,$d(^relation(id,"node"))\10=0 q + . ; + . ; Check the relation/way constraint + . i $g(constraint("relation/way"))=0,$d(^relation(id,"way"))\10=1 q + . i $g(constraint("relation/way"))=1,$d(^relation(id,"way"))\10=0 q + . ; + . ; Check the relation/relation constraint + . i $g(constraint("relation/relation"))=0,$d(^relation(id,"relation"))\10=1 q + . i $g(constraint("relation/relation"))=1,$d(^relation(id,"relation"))\10=0 q + . ; + . ; Check the relation/tag constraint + . i $g(constraint("relation/tag"))=0,$$hasRealTag^relation(id)=1 q + . i $g(constraint("relation/tag"))=1,$$hasRealTag^relation(id)=0 q + . ; + . ; Check that the way is actually within the bounding box + . i $$relationInBox(id,.bbox) d relation(id,k,v,.bbox) + q + + +relation(relationId,k,v,bbox) ; Add relation and all it's constituent elements to workfile + ; + n type,rel + ; + ; Has the relation already been selected? + i $d(^osmTemp($j,"relation",relationId)) q + s ^osmTemp($j,"relation",relationId)="" + ; + ; Add all elements that belong to this relation + s type="" + f d i type="" q + . s type=$o(^relation(relationId,type)) i type="" q + . s rel="" + . f d i rel="" q + . . s rel=$o(^relation(relationId,type,rel)) i rel="" q + . . ; + . . ; If it's a relation then add the relation recursively + . . i type="relation" d relation(rel,k,v,.bbox) + . . ; + . . ; If it's a node then add the node, but not the node's relations + . . i type="node" d node(rel,k,v,.bbox,0) + . . ; + . . ; If it's a way then add the way's nodes, but not its relations + . . i type="way" d way(rel,k,v,.bbox,0) + ; + q + + +nodeInBox(nodeId,bbox) ; Is a node within the bbox? + ; + n lat,lon,latlon + ; + s latlon=$g(^node(nodeId)) + i latlon="" q 0 + s lat=$p(latlon,$c(0),1) + i latbbox("trlat") q 0 + ; + s lon=$p(latlon,$c(0),2) + i lonbbox("trlon") q 0 + q 1 + + +wayInBox(wayId,bbox) ; Is a way within the bbox? + ; Stop looking as soon as we find one node that is actually within the bbox + ; + n wayInBox,ndSeq,nodeId + ; + s wayInBox=0 + s ndSeq="" + f d i ndSeq="" q + . s ndSeq=$o(^way(wayId,ndSeq)) i ndSeq="" q + . s nodeId=^way(wayId,ndSeq) + . i $$nodeInBox(nodeId,.bbox) s wayInBox=1,ndSeq="" q + ; + q wayInBox + + +relationInBox(relationId,bbox) ; Is a relation within the bbox? + ; + n qsItem + ; + s qsItem=^relation(relationId) + i $$bboxInQs^quadString(.bbox,qsItem) q 1 + ; + q 0 + + +requestAdd(request,job) ; Add request to request index + ; + s ^requestx(request,job)="" + q + + +requestDelete(request,job) ; Delete request from request index + ; + k ^requestx(request,job) + q + + +error(e,k,v,bbox,itemCount,area,logId) ; Error response + ; + n f + ; + ; Round the item count to avoid being too precise about it all + s f=10**($l($j(itemCount,0,0))-2) + s itemCount=itemCount\f*f + ; + w "",! + w "BETA: we are testing a request validation mechanism to filter out silly requests. If you have made",! + w " what you think is a sensible request that is being rejected please let me know (80n80n@gmail.com). ",! + w ! + w "Your request (",e,"/",k,"/",v,") " + i itemCount>0 w "would select about ",itemCount," elements and " + w "spans ",$j(area/64800*100,0,2),"% of the planet, which is too large. Please check your request. ",! + w "If you really do need this data then it may be better to get it directly from a planet file.",! + w " Log ID=",logId," ",! + w "",! + q + + +error1(request,logId,message) ; Generate an error response + ; + w "",$c(13,10) + w "Request: ",request,$c(13,10) + w message,$c(13,10) + w "LogId: ",logId,$c(13,10) + w "Contact: 80n80n@gmail.com for assistance",$c(13,10) + w "",$c(13,10) + q + + +fixApostrophe(string) ; Private ; Temporarily fix up apostrophes until the data is all fixed + ; Usage: + ; s xmlString=$$fixApostrophe(string) + ; Inputs: + ; string = string to be escaped + ; Outputs: + ; $$toXml = escaped string + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i "'"[c s out=out_"'" q + . s out=out_c + q out + + +xmlEscape(string) ; Private ; Escape a string using character entities + ; Usage: + ; s xmlString=$$xmlEscape(string) + ; Inputs: + ; string = string to be escaped + ; Output: + ; $$xmlEscape = escaped string + ; + n out,x,c + ; + s out="" + f x=1:1:$l(string) d + . s c=$e(string,x) + . i c="'" s out=out_"'" q + . i c="""" s out=out_""" q + . i c="&" s out=out_"&" q + . i c="<" s out=out_"<" q + . i c=">" s out=out_">" q + . s out=out_c + q out + + +renice ; Private ; Increase the niceness of this process + ; + zsystem "renice +1 -p "_$j ">/dev/null" + q diff --git a/xapi_up b/xapi_up new file mode 100755 index 0000000..db09d30 --- /dev/null +++ b/xapi_up @@ -0,0 +1,5 @@ +# Start up a xapi daemon +source profile +export GTMCI=$zappy/scripts/xapi.ci +cd $zappy/data +($zappy/scripts/xapid /dev/null 2>>xapid.err &) diff --git a/xapid.c b/xapid.c new file mode 100644 index 0000000..fde3438 --- /dev/null +++ b/xapid.c @@ -0,0 +1,24 @@ +#include +#include "gtmxc_types.h" +#define BUF_LEN 1024 +int main() +{ + gtm_char_t port[] = "6520"; + gtm_char_t logLevel[] = "0"; + gtm_char_t msgbuf[BUF_LEN]; + gtm_status_t status; + status = gtm_init(); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + return status; + } + status = gtm_ci("xapid", port, logLevel); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + fprintf(stderr, "%s\n", msgbuf); + return status; + } + return 0; +} diff --git a/zappy.c b/zappy.c new file mode 100644 index 0000000..8779d37 --- /dev/null +++ b/zappy.c @@ -0,0 +1,25 @@ +#include +#include "gtmxc_types.h" +#define BUF_LEN 1024 +int main(int argc, char *argv[]) +{ + gtm_char_t port[] = "6520"; + gtm_char_t logLevel[] = "0"; + gtm_char_t process[100]; + gtm_char_t msgbuf[BUF_LEN]; + gtm_status_t status; + status = gtm_init(); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + return status; + } + status = gtm_ci("zappy", argv[1], argv[2], argv[3]); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + fprintf(stderr, "%s\n", msgbuf); + return status; + } + return 0; +} diff --git a/zappy1_down b/zappy1_down new file mode 100755 index 0000000..4937954 --- /dev/null +++ b/zappy1_down @@ -0,0 +1,3 @@ + . /home/etienne/scripts06/profile_zappy1 + cd /home/etienne/zappy1/data06 + $gtmrun ^shutdown zappy1_down diff --git a/zappy1_up b/zappy1_up new file mode 100755 index 0000000..81d6e18 --- /dev/null +++ b/zappy1_up @@ -0,0 +1,15 @@ + . /home/etienne/scripts06/profile_zappy1 + cd /home/etienne/zappy1/data06 + export GTMCI=/home/etienne/scripts06/zappy.ci + $mupip rundown -file node.dat + $mupip rundown -file nodetag.dat + $mupip rundown -file nodex.dat + $mupip rundown -file way.dat + $mupip rundown -file waytag.dat + $mupip rundown -file wayx.dat + $mupip rundown -file osmTemp.dat + $mupip rundown -file osmapi.dat + (/home/etienne/scripts06/zappyd1 /dev/null 2>>zappyd1.err &) + (/home/etienne/scripts06/zappyd1 /dev/null 2>>zappyd1.err &) + (/home/etienne/scripts06/zappyd1 /dev/null 2>>zappyd1.err &) + ps -Al|grep zappy diff --git a/zappyd.c b/zappyd.c new file mode 100644 index 0000000..93e09a4 --- /dev/null +++ b/zappyd.c @@ -0,0 +1,24 @@ +#include +#include "gtmxc_types.h" +#define BUF_LEN 1024 +int main() +{ + gtm_char_t port[] = "6520"; + gtm_char_t logLevel[] = "0"; + gtm_char_t msgbuf[BUF_LEN]; + gtm_status_t status; + status = gtm_init(); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + return status; + } + status = gtm_ci("zappyd", port, logLevel); + if (status != 0) + { + gtm_zstatus(msgbuf, BUF_LEN); + fprintf(stderr, "%s\n", msgbuf); + return status; + } + return 0; +}