diff --git a/fhem/FHEM/98_HTTPMOD.pm b/fhem/FHEM/98_HTTPMOD.pm index e15f2fff4..452ae7260 100755 --- a/fhem/FHEM/98_HTTPMOD.pm +++ b/fhem/FHEM/98_HTTPMOD.pm @@ -1,7 +1,6 @@ ######################################################################### # $Id$ # fhem Modul für Geräte mit Web-Oberfläche -# wie z.B. Poolmanager Pro von Bayrol (PM5) # # This file is part of fhem. # @@ -45,17 +44,62 @@ # 2015-04-27 Integrated modification of jowiemann partially # settings: interval, reread, stop, start # DEVSTATE was not implemented because "disabled" is visible as attribute -# and stopped / started is visible as TRIGGERTIME. +# and stopped / started is visible as TRIGGERTIME. # also the attribute disabled will not touch the internal timer. # 2015-05-10 Integrated xpath extension as suggested in the forum # 2015-06-22 added set[0-9]*NoArg and get[0-9]*URLExpr, get[0-9]*HeaderExpr and get[0-9]*DataExpr # 2015-07-30 added set[0-9]*TextArg, Encode and Decode # 2015-08-03 added get[0-9]*PullToFile (not fully implemented yet and not yet documented) # 2015-08-24 corrected bug when handling sidIdRegex for step <> 1 +# 2015-09-14 implemented parseFunction1 and 2, modified to not return a value if successful +# 2015-10-10 major restructuring, new xpath, xpath-strict and json parsing implementation +# 2015-11-08 fixed bug which caused a recursion when reading from file:// urls +# fixed xpath handling (so far ...) +# 2015-11-19 MaxAge, aligned type and context for some functions +# 2015-11-23 fixed map handling to allow spaces in names and convert them for fhemweb +# 2015-12-03 Max age finalized +# 2015-12-05 fixed error when loading Libs inside eval{} (should have been eval"") and added documentation for showError +# 2015-12-07 fixed syntax to work with Perl older than 5.14 in a few places +# added RecombineExpr and a few performance optimisations +# 2015-12-10 fixed a bug in JSON parsing and corrected extractAllJSON to start with lower case +# 2015-12-22 fixed missing error handling for JSON parser call +# 2015-12-28 added SetParseResponse +# 2016-01-01 fixed bug where httpheader was not handled, added cookie handling +# 2016-01-09 fixed a bug which caused only one replacement per string to happen +# 2016-01-10 fixed a bug where only the first word of text passed to set is used, +# added sid extraction and reAuth detection with JSON and XPath +# 2016-01-11 modified automatic $val replacement for set values to pass the value through the request queue and +# do the actual replacement just before sending just like user definable replacements +# so they can be done by replacement attributes with other placeholders instead +# 2016-01-16 added TextArg to get and optimized creating the hint list for get / set ? +# 2016-01-21 added documentation +# added RegOpt (still needs more testing), Replacement mode delete +# 2016-01-23 changed MATCHED_READINGS to contain automatically created subreadings (-num) +# added AutoNumLen for automatic sub-reading names (multiple matches) so the number has leading zeros and a fixed length +# added new attribute upgrading mechanism (e.g. for sidIDRegex to sidIdRegex) +# 2016-01-25 modified the way attributes are added to userattr - now includes :hints for fhemweb and old entries are replaced +# 2016-02-02 added more checks to JsonFlatter (if defined ...), fixed auth to be added in the front of the queue, added clearSIdBeforeAuth, authRetries +# 2016-02-04 added a feature to name a reading "unnamed-XX" if Name attribute is missing instead of ignoring everything related +# 2016-02-05 fixed a warning caused by missing initialisation of .setList internal +# 2016-02-07 allowed more regular expression modifiers in RegOpt, added IMap / OMap / IExpr / OExpr +# 2016-02-13 enable sslVersion attribute für HttpUtils and httpVersion +# 2016-02-14 add sslArgs attribute - e.g. as attr myDevice sslArgs SSL_verify_mode,SSL_VERIFY_NONE +# Log old attrs and offer set upgradeAttributes +# 2016-02-15 added replacement type key and set storeKeyValue +# 2016-02-20 set $XML::XPath::SafeMode = 1 to avoid memory leak in XML parser lib # # Todo: +# replacement scope attribute +# Implement IMap und IExpr for get +# +# doku der wichtigsten internen Strukturen (z.B. Request auch für Replacements und für Parse-Funktionen +# make axtracting the sid after a get / update an attribute / option +# # multi page log extraction -# generic cookie handling? +# Profiling von Modbus übernehmen? +# +# extend httpmod to support simple tcp connections aver devio instead of HttpUtils +# extend devio for non blocking connect like httputils # # @@ -75,7 +119,9 @@ sub HTTPMOD_Get($@); sub HTTPMOD_Attr(@); sub HTTPMOD_GetUpdate($); sub HTTPMOD_Read($$$); -sub HTTPMOD_AddToQueue($$$$$;$$$); +sub HTTPMOD_AddToQueue($$$$$;$$$$); +sub HTTPMOD_JsonFlatter($$;$); +sub HTTPMOD_ExtractReading($$$$); # # FHEM module intitialisation @@ -91,76 +137,114 @@ sub HTTPMOD_Initialize($) $hash->{GetFn} = "HTTPMOD_Get"; $hash->{AttrFn} = "HTTPMOD_Attr"; $hash->{AttrList} = - "reading[0-9]+Name " . # new syntax for readings - "reading[0-9]+Regex " . - "reading[0-9]*Expr " . - "reading[0-9]*Map " . # new feature - "reading[0-9]*Format " . # new feature - "reading[0-9]*Decode " . # new feature - "reading[0-9]*Encode " . # new feature + "(reading|get|set)[0-9]+(-[0-9]+)?Name " . - "readingsName.* " . # old syntax - "readingsRegex.* " . - "readingsExpr.* " . + "(reading|get|set)[0-9]*(-[0-9]+)?Expr " . + "(reading|get|set)[0-9]*(-[0-9]+)?Map " . + "(reading|get|set)[0-9]*(-[0-9]+)?OExpr " . + "(reading|get|set)[0-9]*(-[0-9]+)?OMap " . + "(get|set)[0-9]*(-[0-9]+)?IExpr " . + "(get|set)[0-9]*(-[0-9]+)?IMap " . + + "(reading|get|set)[0-9]*(-[0-9]+)?Format " . + "(reading|get|set)[0-9]*(-[0-9]+)?Decode " . + "(reading|get|set)[0-9]*(-[0-9]+)?Encode " . + + "(reading|get)[0-9]*(-[0-9]+)?MaxAge " . + "(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacementMode:text,expression,delete " . + "(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacement " . + + "(reading|get|set)[0-9]+Regex " . + "(reading|get|set)[0-9]+RegOpt " . # see http://perldoc.perl.org/perlre.html#Modifiers + "(reading|get|set)[0-9]+XPath " . + "(reading|get|set)[0-9]+XPath-Strict " . + "(reading|get|set)[0-9]+JSON " . + "(reading|get|set)[0-9]*RecombineExpr " . + "(reading|get|set)[0-9]*AutoNumLen " . + "extractAllJSON " . + + "readingsName.* " . # old + "readingsRegex.* " . # old + "readingsExpr.* " . # old "requestHeader.* " . "requestData.* " . - "reAuthRegex " . - "noShutdown:0,1 " . - + "noShutdown:0,1 " . + "httpVersion " . + "sslVersion " . + "sslArgs " . "timeout " . "queueDelay " . "queueMax " . "minSendDelay " . "showMatched:0,1 " . - - "sid[0-9]*URL " . - "sid[0-9]*IDRegex " . - "sid[0-9]*Data.* " . - "sid[0-9]*Header.* " . - "sid[0-9]*IgnoreRedirects " . + "showError:0,1 " . - "set[0-9]+Name " . - "set[0-9]*URL " . - "set[0-9]*Data.* " . - "set[0-9]*Header.* " . - "set[0-9]+Min " . - "set[0-9]+Max " . - "set[0-9]+Map " . # Umwandlung von Codes für das Gerät zu sprechenden Namen, z.B. "0:mittig, 1:oberhalb, 2:unterhalb" - "set[0-9]+Hint " . # Direkte Fhem-spezifische Syntax für's GUI, z.B. "6,10,14" bzw. slider etc. - "set[0-9]+Expr " . - "set[0-9]*ReAuthRegex " . - "set[0-9]*NoArg " . # don't expect a value - for set on / off and similar. - "set[0-9]*TextArg " . # just pass on a raw text value without validation / further conversion + "parseFunction1 " . + "parseFunction2 " . + + "[gs]et[0-9]*URL " . + "[gs]et[0-9]*Data.* " . + "[gs]et[0-9]*NoData.* " . # make sure it is an HTTP GET without data - even if a more generic data is defined + "[gs]et[0-9]*Header.* " . + "[gs]et[0-9]*CheckAllReadings:0,1 " . + "[gs]et[0-9]*ExtractAllJSON:0,1 " . - "get[0-9]+Name " . - "get[0-9]*URL " . - "get[0-9]*Data.* " . - "get[0-9]*Header.* " . + "[gs]et[0-9]*URLExpr " . # old + "[gs]et[0-9]*DatExpr " . # old + "[gs]et[0-9]*HdrExpr " . # old - "get[0-9]*URLExpr " . - "get[0-9]*DatExpr " . - "get[0-9]*HdrExpr " . - - "get[0-9]+Poll " . # Todo: warum geht bei wildcards kein :0,1 Anhang ? -> in fhem.pl nachsehen + "get[0-9]+Poll:0,1 " . "get[0-9]+PollDelay " . - "get[0-9]*Regex " . - "get[0-9]*Expr " . - "get[0-9]*Map " . - "get[0-9]*Format " . - "get[0-9]*Decode " . - "get[0-9]*Encode " . - "get[0-9]*CheckAllReadings " . "get[0-9]*PullToFile " . "get[0-9]*PullIterate " . - "get[0-9]*RecombineExpr " . + + "set[0-9]+Min " . # todo: min, max und hint auch für get, Schreibweise der Liste auf (get|set) vereinheitlichen + "set[0-9]+Max " . + "set[0-9]+Hint " . # Direkte Fhem-spezifische Syntax für's GUI, z.B. "6,10,14" bzw. slider etc. + "set[0-9]*NoArg:0,1 " . # don't expect a value - for set on / off and similar. (default for get) + "[gs]et[0-9]*TextArg:0,1 " . # just pass on a raw text value without validation / further conversion + "set[0-9]*ParseResponse:0,1 " . # parse response to set as if it was a get + + "reAuthRegex " . + "reAuthJSON " . + "reAuthXPath " . + "reAuthXPath-Strict " . + "[gs]et[0-9]*ReAuthRegex " . + "[gs]et[0-9]*ReAuthJSON " . + "[gs]et[0-9]*ReAuthXPath " . + "[gs]et[0-9]*ReAuthXPath-Strict " . + + "idRegex " . + "idJSON " . + "idXPath " . + "idXPath-Strict " . + "(get|set|sid)[0-9]*IDRegex " . # old + "(get|set|sid)[0-9]*IdRegex " . + "(get|set|sid)[0-9]*IdJSON " . + "(get|set|sid)[0-9]*IdXPath " . + "(get|set|sid)[0-9]*IdXPath-Strict " . + + "sid[0-9]*URL " . + "sid[0-9]*Header.* " . + "sid[0-9]*Data.* " . + "sid[0-9]*IgnoreRedirects:0,1 " . + "sid[0-9]*ParseResponse:0,1 " . # parse response as if it was a get + "clearSIdBeforeAuth:0,1 " . + "authRetries " . + + "replacement[0-9]*Regex " . + "replacement[0-9]*Mode:reading,internal,text,expression,key " . # defaults to text + "replacement[0-9]*Value " . # device:reading, device:internal, text, replacement expression + "[gs]et[0-9]*Replacement[0-9]*Value " . # can overwrite a global replacement value - todo: auch für auth? "do_not_notify:1,0 " . "disable:0,1 " . "enableControlSet:0,1 " . - "enableXPath:0,1 " . - "enableXPath-Strict:0,1 " . + "enableCookies:0,1 " . + "enableXPath:0,1 " . # old + "enableXPath-Strict:0,1 " . # old $readingFnAttributes; } @@ -171,8 +255,8 @@ sub HTTPMOD_Initialize($) ######################################################################### sub HTTPMOD_Define($$) { - my ( $hash, $def ) = @_; - my @a = split( "[ \t][ \t]*", $def ); + my ($hash, $def) = @_; + my @a = split( "[ \t]+", $def ); return "wrong syntax: define HTTPMOD URL interval" if ( @a < 3 ); @@ -186,6 +270,7 @@ sub HTTPMOD_Define($$) } if(int(@a) > 3) { + # interval specified if ($a[3] > 0) { if ($a[3] >= 5) { $hash->{Interval} = $a[3]; @@ -197,10 +282,13 @@ sub HTTPMOD_Define($$) $hash->{Interval} = 0; } } else { + # default if no interval specified $hash->{Interval} = 300; } - Log3 $name, 3, "$name: Defined with URL $hash->{MainURL} and interval $hash->{Interval}"; + Log3 $name, 3, "$name: Defined " . + ($hash->{MainURL} ? "with URL $hash->{MainURL}" : "without URL") . + ($hash->{Interval} ? " and interval $hash->{Interval}" : ""); # Initial request after 2 secs, for further updates the timer will be set according to interval. # but only if URL is specified and interval > 0 @@ -212,18 +300,21 @@ sub HTTPMOD_Define($$) InternalTimer($firstTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); Log3 $name, 5, "$name: InternalTimer set to call GetUpdate in 2 seconds for the first time"; } else { - $hash->{TRIGGERTIME} = 0; + $hash->{TRIGGERTIME} = 0; $hash->{TRIGGERTIME_FMT} = ""; } + $hash->{".getList"} = ""; + $hash->{".setList"} = ""; return undef; } + # # undefine command when device is deleted ######################################################################### sub HTTPMOD_Undef($$) { - my ( $hash, $arg ) = @_; + my ($hash, $arg) = @_; my $name = $hash->{NAME}; RemoveInternalTimer ("timeout:$name"); RemoveInternalTimer ("queue:$name"); @@ -232,144 +323,780 @@ sub HTTPMOD_Undef($$) } +######################################################################### +sub HTTPMOD_LogOldAttr($$;$) +{ + my ($hash, $old, $new) = @_; + my $name = $hash->{NAME}; + Log3 $name, 3, "$name: the attribute $old should no longer be used." . ($new ? " Please use $new instead" : ""); + Log3 $name, 3, "$name: For most old attributes you can specify enableControlSet and then set device upgradeAttributes to automatically modify the configuration"; +} + + # # Attr command ######################################################################### -sub -HTTPMOD_Attr(@) +sub HTTPMOD_Attr(@) { my ($cmd,$name,$aName,$aVal) = @_; - my $hash = $defs{$name}; # might be needed inside a URLExpr + my $hash = $defs{$name}; + my $modHash = $modules{$hash->{TYPE}}; my ($sid, $old); # might be needed inside a URLExpr + # $cmd can be "del" or "set" # $name is device name - # aName and aVal are Attribute name and value + # aName and aVal are attribute name and attribute value # simple attributes like requestHeader and requestData need no special treatment here # readingsExpr, readingsRegex.* or reAuthRegex need validation though. + # if validation fails, return something so CommandAttr in fhem.pl doesn't assign a value to $attr if ($cmd eq "set") { - if ($aName =~ "Regex") { # catch all Regex like attributes - eval { qr/$aVal/ }; + if ($aName =~ /Regex/) { # catch all Regex like attributes + eval {qr/$aVal/}; if ($@) { Log3 $name, 3, "$name: Attr with invalid regex in attr $name $aName $aVal: $@"; return "Invalid Regex $aVal"; } - } elsif ($aName =~ "Expr") { # validate all Expressions - my $val = 1; + if ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex$/) { + $hash->{ReplacementEnabled} = 1; + } + + # conversions for legacy things + if ($aName =~ /(.+)IDRegex$/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}IdRegex"); + } + if ($aName =~ /readingsRegex.*/) { + HTTPMOD_LogOldAttr($hash, $aName, "reading01Regex syntax"); + } + } elsif ($aName =~ /readingsName.*/) { + HTTPMOD_LogOldAttr($hash, $aName, "reading01Name syntax"); + } elsif ($aName =~ /RegOpt$/) { + if ($aVal !~ /^[msxdualsig]*$/) { + Log3 $name, 3, "$name: illegal RegOpt in attr $name $aName $aVal"; + return "$name: illegal RegOpt in attr $name $aName $aVal"; + } + } elsif ($aName =~ /Expr/) { # validate all Expressions + my $val = 0; + my @matchlist = (); no warnings qw(uninitialized); eval $aVal; if ($@) { Log3 $name, 3, "$name: Attr with invalid Expression in attr $name $aName $aVal: $@"; return "Invalid Expression $aVal"; } - } elsif ($aName eq "enableXPath") { - if(!eval("use HTML::TreeBuilder::XPath;1")) { - Log3 $name, 3, "$name: Please install HTML::TreeBuilder::XPath to use the xpath-Option"; - return "Please install HTML::TreeBuilder::XPath to use the xpath-Option"; + if ($aName =~ /readingsExpr.*/) { + HTTPMOD_LogOldAttr($hash, $aName, "reading01Expr syntax"); + } elsif ($aName =~ /^(get[0-9]*)Expr/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}OExpr"); + } elsif ($aName =~ /^(reading[0-9]*)Expr/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}OExpr"); + } elsif ($aName =~ /^(set[0-9]*)Expr/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}IExpr"); } - } elsif ($aName eq "enableXPath-Strict") { - if(!eval("use XML::XPath;use XML::XPath::XMLParser;1")) { - Log3 $name, 3, "$name: Please install XML::XPath and XML::XPath::XMLParser to use the xpath-strict-Option"; - return "Please install XML::XPath and XML::XPath::XMLParser to use the xpath-strict-Option"; + + } elsif ($aName =~ /Map$/) { + if ($aName =~ /^(get[0-9]*)Map/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}OMap"); + } elsif ($aName =~ /^(reading[0-9]*)Map/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}OMap"); + } elsif ($aName =~ /^(set[0-9]*)Map/) { + HTTPMOD_LogOldAttr($hash, $aName, "${1}IMap"); + } + + } elsif ($aName =~ /replacement[0-9]*Mode/) { + if ($aVal !~ /^(reading|internal|text|expression|key)$/) { + Log3 $name, 3, "$name: illegal mode in attr $name $aName $aVal"; + return "$name: illegal mode in attr $name $aName $aVal"; + } + + } elsif ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement([0-9]*)Value/) { + Log3 $name, 5, "$name: validating attr $name $aName $aVal"; + if (AttrVal($name, "replacement${2}Mode", "text") eq "expression") { + no warnings qw(uninitialized); + eval $aVal; + if ($@) { + Log3 $name, 3, "$name: Attr with invalid Expression (mode is expression) in attr $name $aName $aVal: $@"; + return "Attr with invalid Expression (mode is expression) in attr $name $aName $aVal: $@"; + } + } + + } elsif ($aName =~ /(get|reading)[0-9]*JSON$/ + || $aName =~ /[Ee]xtractAllJSON$/ + || $aName =~ /[Rr]eAuthJSON$/ + || $aName =~ /[Ii]dJSON$/) { + eval "use JSON"; + if($@) { + # Log3 $name, 3, "$name: Please install JSON Library to use JSON (apt-get install libjson-perl) - error was $@"; + return "Please install JSON Library to use JSON (apt-get install libjson-perl) - error was $@"; + } + $hash->{JSONEnabled} = 1; + } elsif ($aName eq "enableCookies") { + if ($aVal eq "0") { + delete $hash->{HTTPCookieHash}; + delete $hash->{HTTPCookies}; + } + } elsif ($aName eq "enableXPath" + || $aName =~ /(get|reading)[0-9]+XPath$/ + || $aName =~ /[Rr]eAuthXPath$/ + || $aName =~ /[Ii]dXPath$/) { + eval "use HTML::TreeBuilder::XPath"; + if($@) { + # Log3 $name, 3, "$name: Please install HTML::TreeBuilder::XPath to use the xpath-Option (apt-get install libxml-TreeBuilder-perl libhtml-treebuilder-xpath-perl) - error was $@"; + return "Please install HTML::TreeBuilder::XPath to use the xpath-Option (apt-get install libxml-TreeBuilder-perl libhtml-treebuilder-xpath-perl) - error was $@"; + } + $hash->{XPathEnabled} = 1; + + } elsif ($aName eq "enableXPath-Strict" + || $aName =~ /(get|reading)[0-9]+XPath-Strict$/ + || $aName =~ /[Rr]eAuthXPath-Strict$/ + || $aName =~ /[Ii]dXPath-Strict$/) { + eval "use XML::XPath;use XML::XPath::XMLParser"; + if($@) { + #Log3 $name, 3, "$name: Please install XML::XPath and XML::XPath::XMLParser to use the xpath-strict-Option (apt-get install libxml-parser-perl libxml-xpath-perl) - error was $@"; + return "Please install XML::XPath and XML::XPath::XMLParser to use the xpath-strict-Option (apt-get install libxml-parser-perl libxml-xpath-perl) - error was $@"; + } + $XML::XPath::SafeMode = 1; + $hash->{XPathStrictEnabled} = 1; + + } elsif ($aName =~ /^(reading|get)[0-9]*(-[0-9]+)?MaxAge$/) { + if ($aVal !~ '([0-9]+)') { + Log3 $name, 3, "$name: wrong format in attr $name $aName $aVal"; + return "Invalid Format $aVal in $aName"; + } + $hash->{MaxAgeEnabled} = 1; + + } elsif ($aName =~ /^(reading|get)[0-9]*(-[0-9]+)?MaxAgeReplacementMode$/) { + if ($aVal !~ /^(text|expression|delete)$/) { + Log3 $name, 3, "$name: illegal mode in attr $name $aName $aVal"; + return "$name: illegal mode in attr $name $aName $aVal, choose on of text, expression"; + } + + } elsif ($aName =~ /^(reading|get)([0-9]+)(-[0-9]+)?Name$/) { + $hash->{defptr}{readingBase}{$aVal} = $1; + $hash->{defptr}{readingNum}{$aVal} = $2 if ($2); + $hash->{defptr}{readingSubNum}{$aVal} = $3 if ($3); + } + + # handle wild card attributes -> Add to userattr to allow modification in fhemweb + #Log3 $name, 3, "$name: attribute $aName checking "; + if (" $modHash->{AttrList} " !~ m/ ${aName}[ :;]/) { + # nicht direkt in der Liste -> evt. wildcard attr in AttrList + foreach my $la (split " ", $modHash->{AttrList}) { + $la =~ /([^:;]+)(:?.*)/; + my $vgl = $1; # attribute name in list - probably a regex + my $opt = $2; # attribute hint in list + if ($aName =~ $vgl) { # yes - the name in the list now matches as regex + # $aName ist eine Ausprägung eines wildcard attrs + #Log3 $name, 3, "$name: attribute $aName specified from $vgl, add to userattr" . + # ($opt ? " with extension $opt" : ""); + addToDevAttrList($name, "$aName" . $opt); # create userattr with hint to allow changing by click in fhemweb + if ($opt) { + # remove old entries without hint + my $ualist = $attr{$name}{userattr}; + $ualist = "" if(!$ualist); + my %uahash; + foreach my $a (split(" ", $ualist)) { + if ($a !~ /^${aName}$/) { # entry in userattr list is attribute without hint + $uahash{$a} = 1; + } else { + Log3 $name, 3, "$name: added hint $opt to attr $a in userattr list"; + } + } + $attr{$name}{userattr} = join(" ", sort keys %uahash); + } + } + } + } else { + # exakt in Liste enthalten -> sicherstellen, dass keine +* etc. drin sind. + if ($aName =~ /\|\*\+\[/) { + Log3 $name, 3, "$name: Atribute $aName is not valid. It still contains wildcard symbols"; + return "$name: Atribute $aName is not valid. It still contains wildcard symbols"; + } + } + + # Deletion of Attributes + } elsif ($cmd eq "del") { + #Log3 $name, 5, "$name: del attribute $aName"; + if ($aName =~ /(reading|get)[0-9]*JSON$/ + || $aName =~ /[Ee]xtractAllJSON$/ + || $aName =~ /[Rr]eAuthJSON$/ + || $aName =~ /[Ii]dJSON$/) { + if (!(grep !/$aName/, grep (/((reading|get)[0-9]*JSON$)|[Ee]xtractAllJSON$|[Rr]eAuthJSON$|[Ii]dJSON$/, + keys %{$attr{$name}}))) { + delete $hash->{JSONEnabled}; + #Log3 $name, 5, "$name: disable JSON"; + } + } elsif ($aName eq "enableXPath" + || $aName =~ /(get|reading)[0-9]+XPath$/ + || $aName =~ /[Rr]eAuthXPath$/ + || $aName =~ /[Ii]dXPath$/) { + if (!(grep !/$aName/, grep (/(get|reading)[0-9]+XPath$|enableXPath|[Rr]eAuthXPath$|[Ii]dXPath$/, + keys %{$attr{$name}}))) { + delete $hash->{XPathEnabled}; + #Log3 $name, 5, "$name: disable XPath"; + } + } elsif ($aName eq "enableXPath-Strict" + || $aName =~ /(get|reading)[0-9]+XPath-Strict$/ + || $aName =~ /[Rr]eAuthXPath-Strict$/ + || $aName =~ /[Ii]dXPath-Strict$/) { + + if (!(grep !/$aName/, grep (/(get|reading)[0-9]+XPath-Strict$|enableXPath-Strict|[Rr]eAuthXPath-Strict$|[Ii]dXPath-Strict$/, + keys %{$attr{$name}}))) { + delete $hash->{XPathStrictEnabled}; + #Log3 $name, 5, "$name: disable XPathStrict"; + } + } elsif ($aName eq "enableCookies") { + delete $hash->{HTTPCookieHash}; + delete $hash->{HTTPCookies}; + } elsif ($aName =~ /(reading|get)[0-9]*(-[0-9]+)?MaxAge$/) { + if (!(grep !/$aName/, grep (/(reading|get)[0-9]*(-[0-9]+)?MaxAge$/, keys %{$attr{$name}}))) { + delete $hash->{MaxAgeEnabled}; + #Log3 $name, 5, "$name: disable MaxAge"; + } + } elsif ($aName =~ /([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex/) { + if (!(grep !/$aName/, grep (/([gs]et[0-9]*)?[Rr]eplacement[0-9]*Regex/, keys %{$attr{$name}}))) { + delete $hash->{ReplacementEnabled}; + #Log3 $name, 5, "$name: disable Replacement"; } } - addToDevAttrList($name, $aName); } + if ($aName =~ /^[gs]et/ || $aName eq "enableControlSet") { + $hash->{".updateHintList"} = 1; + } + if ($aName =~ /^(get|reading)/) { + $hash->{".updateReadingList"} = 1; + } + return undef; } + + +# Upgrade attribute names from older versions +############################################## +sub HTTPMOD_UpgradeAttributes($) +{ + my ($hash) = @_; + my $name = $hash->{NAME}; + my %dHash; + my %numHash; + + #Log3 $name, 3, "$name: UpgradeAttributes called, userattr list is $attr{$name}{userattr}"; + foreach my $aName (keys %{$attr{$name}}) { + if ($aName =~ /(.+)IDRegex$/) { + my $new = $1 . "IdRegex"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); # also adds new attr to userattr list through _Attr function + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /(.+)Regex$/) { + my $ctx = $1; + my $val = $attr{$name}{$aName}; + #Log3 $name, 3, "$name: upgradeAttributes check attr $aName, val $val"; + if ($val =~ /^xpath:(.*)/) { + $val = $1; + my $new = $ctx . "XPath"; + CommandAttr(undef, "$name $new $val"); + CommandAttr(undef, "$name $ctx" . "RecombineExpr join(\",\", \@matchlist)"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } + if ($val =~ /^xpath-strict:(.*)/) { + $val = $1; + my $new = $ctx . "XPath-Strict"; + CommandAttr(undef, "$name $new $val"); + CommandAttr(undef, "$name $ctx" . "RecombineExpr join(\",\", \@matchlist)"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } + } elsif ($aName eq "enableXPath" || $aName eq "enableXPath-Strict" ) { + CommandDeleteAttr(undef, "$name $aName"); + Log3 $name, 3, "$name: removed attribute name $aName"; + + } elsif ($aName =~ /(set[0-9]*)Expr$/) { + my $new = $1 . "IExpr"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /(get[0-9]*)Expr$/) { + my $new = $1 . "OExpr"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /(reading[0-9]*)Expr$/) { + my $new = $1 . "OExpr"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + + } elsif ($aName =~ /(set[0-9]*)Map$/) { + my $new = $1 . "IMap"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /(get[0-9]*)Map$/) { + my $new = $1 . "OMap"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /(reading[0-9]*)Map$/) { + my $new = $1 . "OMap"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } elsif ($aName =~ /^readings(Name|Expr|Regex)(.*)$/) { + my $typ = $1; + my $sfx = $2; + my $num; + if (defined($numHash{$sfx})) { + $num = $numHash{$sfx}; + } else { + my $max = 0; + foreach my $a (keys %{$attr{$name}}) { + if ($a =~ /^reading([0-9]+)\D+$/) { + $max = $1 if ($1 > $max); + } + } + $num = sprintf("%02d", $max + 1); + $numHash{$sfx} = $num; + } + my $new = "reading${num}${typ}"; + my $val = $attr{$name}{$aName}; + CommandAttr(undef, "$name $new $val"); + CommandDeleteAttr(undef, "$name $aName"); + $dHash{$aName} = 1; + Log3 $name, 3, "$name: upgraded attribute name $aName to new sytax $new"; + } + } + + $dHash{"enableXpath"} = 1; + $dHash{"enableXpath-Strict"} = 1; + + my $ualist = $attr{$name}{userattr}; + $ualist = "" if(!$ualist); + my %uahash; + foreach my $a (split(" ", $ualist)) { + if (!$dHash{$a}) { + $uahash{$a} = 1; + #Log3 $name, 3, "$name: keeping $a in userattr list"; + } else { + Log3 $name, 3, "$name: dropping $a from userattr list"; + } + } + $attr{$name}{userattr} = join(" ", sort keys %uahash); + #Log3 $name, 3, "$name: UpgradeAttribute done, userattr list is $attr{$name}{userattr}"; +} + + +# get attribute based specification +# for format, map or similar +# with generic and absolute default (empty variable num part) +# if num is like 1-1 then check for 1 if 1-1 not found +############################################################# +sub HTTPMOD_GetFAttr($$$$;$) +{ + my ($name, $prefix, $num, $type, $val) = @_; + # first look for attribute with the full num in it + if (defined ($attr{$name}{$prefix . $num . $type})) { + $val = $attr{$name}{$prefix . $num . $type}; + # if not found then check if num contains a subnum (for regexes with multiple capture groups etc) and look for attribute without this subnum + } elsif (($num =~ /([0-9]+)-[0-9]+/) && defined ($attr{$name}{$prefix .$1 . $type})) { + $val = $attr{$name}{$prefix . $1 . $type}; + # if again not found then look for generic attribute without num + } elsif (defined ($attr{$name}{$prefix . $type})) { + $val = $attr{$name}{$prefix . $type}; + } + return $val; +} + + +################################################### +# checks and stores obfuscated keys like passwords +# based on / copied from FRITZBOX_storePassword +sub HTTPMOD_StoreKeyValue($$$) +{ + my ($hash, $kName, $value) = @_; + + my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName; + my $key = getUniqueId().$index; + my $enc = ""; + + if(eval "use Digest::MD5;1") + { + $key = Digest::MD5::md5_hex(unpack "H*", $key); + $key .= Digest::MD5::md5_hex($key); + } + + for my $char (split //, $value) + { + my $encode=chop($key); + $enc.=sprintf("%.2x",ord($char)^ord($encode)); + $key=$encode.$key; + } + + my $err = setKeyValue($index, $enc); + return "error while saving the value - $err" if(defined($err)); + return undef; +} + + +##################################################### +# reads obfuscated value +sub HTTPMOD_ReadKeyValue($$) +{ + my ($hash, $kName) = @_; + my $name = $hash->{NAME}; + + my $index = $hash->{TYPE}."_".$hash->{NAME}."_".$kName; + my $key = getUniqueId().$index; + + my ($value, $err); + + Log3 $name, 5, "$name: ReadKeyValue tries to read value for $kName from file"; + ($err, $value) = getKeyValue($index); + + if ( defined($err) ) { + Log3 $name, 4, "$name: ReadKeyValue is unable to read value from file: $err"; + return undef; + } + + if ( defined($value) ) { + if ( eval "use Digest::MD5;1" ) { + $key = Digest::MD5::md5_hex(unpack "H*", $key); + $key .= Digest::MD5::md5_hex($key); + } + + my $dec = ''; + + for my $char (map { pack('C', hex($_)) } ($value =~ /(..)/g)) { + my $decode=chop($key); + $dec.=chr(ord($char)^ord($decode)); + $key=$decode.$key; + } + + return $dec; + } + else { + Log3 $name, 4, "$name: ReadKeyValue could not find key $kName in file"; + return undef; + } +} + + +# replace strings as defined in Attributes for URL, Header and Data +# type is request type and can be set01, get03, auth01, update +######################################################################### +sub HTTPMOD_Replace($$$) +{ + my ($hash, $type, $string) = @_; + my $name = $hash->{NAME}; + my $context = ""; + + if ($type =~ /(auth|set|get)(.*)/) { + $context = $1; # context is type without num + # for type update there is no num so no individual replacement - only one for the whiole update request + } + + #Log3 $name, 4, "$name: Replace called for request type $type"; + # Loop through all Replacement Regex attributes + foreach my $rr (sort grep (/replacement[0-9]*Regex/, keys %{$attr{$name}})) { + $rr =~ /replacement([0-9]*)Regex/; + my $rNum = $1; + #Log3 $name, 5, "$name: Replace: rr=$rr, rNum $rNum, look for ${type}Replacement${rNum}Value"; + my $regex = AttrVal($name, "replacement${rNum}Regex", ""); + my $mode = AttrVal($name, "replacement${rNum}Mode", "text"); + next if (!$regex); + + my $value = ""; + if ($context && defined ($attr{$name}{"${type}Replacement${rNum}Value"})) { + # get / set / auth mit individuellem Replacement für z.B. get01 + $value = $attr{$name}{"${type}Replacement${rNum}Value"}; + } elsif ($context && defined ($attr{$name}{"${context}Replacement${rNum}Value"})) { + # get / set / auth mit generischem Replacement für alle gets / sets + $value = $attr{$name}{"${context}Replacement${rNum}Value"}; + } elsif (defined ($attr{$name}{"replacement${rNum}Value"})) { + # ganz generisches Replacement + $value = $attr{$name}{"replacement${rNum}Value"}; + } + Log3 $name, 5, "$name: Replace called for type $type, regex $regex, mode $mode, " . + ($value ? "value $value" : "empty value") . " input: $string"; + + my $match = 0; + if ($mode eq 'text') { + $match = ($string =~ s/$regex/$value/g); + } elsif ($mode eq 'reading') { + my $device = $name; + my $reading = $value; + if ($value =~ /^([^\:]+):(.+)$/) { + $device = $1; + $reading = $2; + } + my $rvalue = ReadingsVal($device, $reading, ""); + if ($string =~ s/$regex/$rvalue/g) { + Log3 $name, 5, "$name: Replace: reading value is $rvalue"; + $match = 1; + } + } elsif ($mode eq 'internal') { + my $device = $name; + my $internal = $value; + if ($value =~ /^([^\:]+):(.+)$/) { + $device = $1; + $internal = $2; + } + my $rvalue = InternalVal($device, $internal, ""); + if ($string =~ s/$regex/$rvalue/g) { + Log3 $name, 5, "$name: Replace: internal value is $rvalue"; + $match = 1; + } + } elsif ($mode eq 'expression') { + $match = eval {$string =~ s/$regex/$value/gee}; + if ($@) { + Log3 $name, 3, "$name: Replace: invalid regex / expression: /$regex/$value/gee - $@"; + } + } elsif ($mode eq 'key') { + my $rvalue = HTTPMOD_ReadKeyValue($hash, $value); + if ($string =~ s/$regex/$rvalue/g) { + Log3 $name, 5, "$name: Replace: key $value value is $rvalue"; + $match = 1; + } + } + Log3 $name, 5, "$name: Replace: match and result is $string" if ($match); + } + return $string; +} + + +# +######################################################################### +sub HTTPMOD_ModifyWithExpr($$$$$) +{ + my ($name, $context, $num, $attr, $text) = @_; + my $exp = AttrVal($name, "${context}${num}${attr}", undef); + if ($exp) { + my $old = $text; + $text = eval($exp); + if ($@) { + Log3 $name, 3, "$name: error in $attr for $context $num: $@"; + } + Log3 $name, 5, "$name: $context $num used $attr to convert\n$old\nto\n$text\nusing expr $exp"; + } + return $text; +} + + + +# +######################################################################### +sub HTTPMOD_PrepareRequest($$;$) +{ + my ($hash, $context, $num) = @_; + my $name = $hash->{NAME}; + my ($url, $header, $data, $exp); + $num = 0 if (!$num); # num is not passed wehn called for update request + + if ($context eq "reading") { + # called from GetUpdate - not Get / Set / Auth + $url = $hash->{MainURL}; + $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestHeader/, keys %{$attr{$name}}))); + $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestData/, keys %{$attr{$name}}))); + } else { + # called for Get / Set / Auth + # hole alle Header bzw. generischen Header ohne Nummer + $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}${num}Header/, keys %{$attr{$name}}))); + if (length $header == 0) { + $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}Header/, keys %{$attr{$name}}))); + } + if (! HTTPMOD_GetFAttr($name, $context, $num, "NoData")) { + # hole Bestandteile der Post data + $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}${num}Data/, keys %{$attr{$name}}))); + if (length $data == 0) { + $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/${context}Data/, keys %{$attr{$name}}))); + } + } + # hole URL + $url = HTTPMOD_GetFAttr($name, $context, $num, "URL"); + if (!$url) { + $url = $hash->{MainURL}; + } + } + + $header = HTTPMOD_ModifyWithExpr($name, $context, $num, "HdrExpr", $header); + $data = HTTPMOD_ModifyWithExpr($name, $context, $num, "DatExpr", $data); + $url = HTTPMOD_ModifyWithExpr($name, $context, $num, "URLExpr", $url); + + if (AttrVal($name, "enableCookies", 0) && $hash->{HTTPCookies}) { + Log3 $name, 5, "$name: PrepareRequest is adding Cookies: " . $hash->{HTTPCookies}; + $header .= "Cookie: " . $hash->{HTTPCookies}; + } + + return ($url, $header, $data); +} + + # create a new authenticated session ######################################################################### sub HTTPMOD_Auth($@) { my ( $hash, @a ) = @_; my $name = $hash->{NAME}; - + my ($url, $header, $data); + # get all steps my %steps; foreach my $attr (keys %{$attr{$name}}) { - if ($attr =~ "sid([0-9]+).+") { + if ($attr =~ /sid([0-9]+).+/) { $steps{$1} = 1; } } Log3 $name, 4, "$name: Auth called with Steps: " . join (" ", sort keys %steps); - - $hash->{sid} = ""; - foreach my $step (sort keys %steps) { - - my ($url, $header, $data, $type, $retrycount, $ignoreredirects); - # hole alle Header bzw. generischen Header ohne Nummer - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/sid${step}Header/, keys %{$attr{$name}}))); - if (length $header == 0) { - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/sidHeader/, keys %{$attr{$name}}))); - } - # hole Bestandteile der Post Data - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/sid${step}Data/, keys %{$attr{$name}}))); - if (length $data == 0) { - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/sidData/, keys %{$attr{$name}}))); - } - # hole URL - $url = AttrVal($name, "sid${step}URL", undef); - if (!$url) { - $url = AttrVal($name, "sidURL", undef); - } - $ignoreredirects = AttrVal($name, "sid${step}IgnoreRedirects", undef); - $retrycount = 0; - $type = "Auth$step"; + + $hash->{sid} = "" if AttrVal($name, "clearSIdBeforeAuth", 0); + foreach my $step (sort {$b cmp $a} keys %steps) { # reverse sort + ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "sid", $step); if ($url) { - HTTPMOD_AddToQueue($hash, $url, $header, $data, $type, $retrycount, $ignoreredirects); + # add to front of queue (prio) + HTTPMOD_AddToQueue($hash, $url, $header, $data, "auth$step", undef, 0, AttrVal($name, "sid${step}IgnoreRedirects", 0), 1); } else { - Log3 $name, 3, "$name: no URL for $type"; + Log3 $name, 3, "$name: no URL for Auth $step"; } } + HTTPMOD_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this. return undef; } -# put URL, Header, Data etc. in hash for HTTPUtils Get -# for set with index $setNum -######################################################################### -sub HTTPMOD_DoSet($$$) +# create hint list for set / get ? +######################################## +sub HTTPMOD_UpdateHintList($) { - my ($hash, $setNum, $rawVal) = @_; + my ($hash, $context) = @_; my $name = $hash->{NAME}; - my ($url, $header, $data, $type, $count); - - # hole alle Header bzw. generischen Header ohne Nummer - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/set${setNum}Header/, keys %{$attr{$name}}))); - if (length $header == 0) { - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/setHeader/, keys %{$attr{$name}}))); - } - # hole Bestandteile der Post data - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/set${setNum}Data/, keys %{$attr{$name}}))); - if (length $data == 0) { - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/setData/, keys %{$attr{$name}}))); - } - # hole URL - $url = AttrVal($name, "set${setNum}URL", undef); - if (!$url) { - $url = AttrVal($name, "setURL", undef); - } - if (!$url) { - $url = $hash->{MainURL}; - } - - # ersetze $val in header, data und URL - $header =~ s/\$val/$rawVal/g; - $data =~ s/\$val/$rawVal/g; - $url =~ s/\$val/$rawVal/g; - - $type = "Set$setNum"; - if ($url) { - HTTPMOD_AddToQueue($hash, $url, $header, $data, $type); + Log3 $name, 5, "$name: UpdateHintList called"; + $hash->{".getList"} = ""; + if (AttrVal($name, "enableControlSet", undef)) { # spezielle Sets freigeschaltet? + #$hash->{".setList"} = "interval reread:noArg stop:noArg start:noArg "; + $hash->{".setList"} = "interval reread:noArg stop:noArg start:noArg upgradeAttributes:noArg storeKeyValue "; } else { - Log3 $name, 3, "$name: no URL for $type"; + $hash->{".setList"} = ""; } - return undef; + foreach my $aName (grep /[gs]et[0-9]+Name/, keys %{$attr{$name}}) { + if ($aName =~ /([gs]et)([0-9]+)Name/) { + my $context = $1; + my $num = $2; + my $opt; + my $oName = $attr{$name}{$aName}; # value of the [gs]etXName attribute is name of the set/get option + + if ($context eq "set") { + my $map = ""; + $map = AttrVal($name, "${context}${num}Map", "") if ($context ne "get"); # old Map for set is now IMap (Input) + $map = AttrVal($name, "${context}${num}IMap", $map); # new syntax ovverides old one + if ($map) { + my $hint = $map; # create hint from map + $hint =~ s/([^,\$]+):([^,\$]+)(,?) */$2$3/g; # allow spaces in names + $hint =~ s/\s/ /g; # convert spaces for fhemweb + $opt = $oName . ":$hint"; # opt is Name:Hint (from Map) + } elsif (AttrVal($name, "${context}${num}NoArg", undef)) { # NoArg explicitely specified for a set? + $opt = $oName . ":noArg"; + } else { + $opt = $oName; # nur den Namen für opt verwenden. + } + } elsif ($context eq "get") { + if (AttrVal($name, "${context}${num}TextArg", undef)) { # TextArg explicitely specified for a get? + $opt = $oName; # nur den Namen für opt verwenden. + } else { + $opt = $oName . ":noArg"; # sonst noArg bei get + } + } + if (AttrVal($name, "${context}${num}Hint", undef)) { # gibt es einen expliziten Hint? + $opt = $oName . ":" . AttrVal($name, "${context}${num}Hint", undef); + } + $hash->{".${context}List"} .= $opt . " "; # save new hint list + } + } + delete $hash->{".updateHintList"}; + Log3 $name, 5, "$name: UpdateHintList: setlist = " . $hash->{".setList"}; + Log3 $name, 5, "$name: UpdateHintList: getlist = " . $hash->{".getList"}; +} + + +# +# SET command - handle predifined control sets +################################################ +sub HTTPMOD_ControlSet($$$) +{ + my ($hash, $setName, $setVal) = @_; + my $name = $hash->{NAME}; + + if ($setName eq 'interval') { + if (!$setVal) { + Log3 $name, 3, "$name: no interval (sec) specified in set, continuing with $hash->{Interval} (sec)"; + return "No Interval specified"; + } else { + if (int $setVal > 5) { + $hash->{Interval} = $setVal; + my $nextTrigger = gettimeofday() + $hash->{Interval}; + RemoveInternalTimer("update:$name"); + $hash->{TRIGGERTIME} = $nextTrigger; + $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); + InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); + Log3 $name, 3, "$name: timer interval changed to $hash->{Interval} seconds"; + return "0"; + } elsif (int $setVal <= 5) { + Log3 $name, 3, "$name: interval $setVal (sec) to small (must be >5), continuing with $hash->{Interval} (sec)"; + return "interval too small"; + } + } + } elsif ($setName eq 'reread') { + HTTPMOD_GetUpdate("reread:$name"); + return "0"; + } elsif ($setName eq 'stop') { + RemoveInternalTimer("update:$name"); + $hash->{TRIGGERTIME} = 0; + $hash->{TRIGGERTIME_FMT} = ""; + Log3 $name, 3, "$name: internal interval timer stopped"; + return "0"; + } elsif ($setName eq 'start') { + my $nextTrigger = gettimeofday() + $hash->{Interval}; + $hash->{TRIGGERTIME} = $nextTrigger; + $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); + RemoveInternalTimer("update:$name"); + InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); + Log3 $name, 5, "$name: internal interval timer set to call GetUpdate in " . int($hash->{Interval}). " seconds"; + return "0"; + } elsif ($setName eq 'upgradeAttributes') { + HTTPMOD_UpgradeAttributes($hash); + return "0"; + } elsif ($setName eq 'storeKeyValue') { + my $key; + if ($setVal =~ /([^ ]+) +(.*)/) { + $key = $1; + my $err = HTTPMOD_StoreKeyValue($hash, $key, $2); + return $err if ($err); + } else { + return "Please give a key and a value to storeKeyValue"; + } + return "0"; + } + return undef; # no control set identified - continue with other sets } @@ -378,14 +1105,14 @@ sub HTTPMOD_DoSet($$$) ######################################################################### sub HTTPMOD_Set($@) { - my ( $hash, @a ) = @_; - return "\"set HTTPMOD\" needs at least an argument" if ( @a < 2 ); + my ($hash, @a) = @_; + return "\"set HTTPMOD\" needs at least an argument" if (@a < 2); - # @a is an array with DeviceName, setName and setVal - my ($name, $setName, $setVal) = @a; - my (%rmap, $setNum, $setOpt, $setList, $rawVal); - $setList = ""; - + # @a is an array with the command line: DeviceName, setName. Rest is setVal (splitted in fhem.pl by space and tab) + my ($name, $setName, @setValArr) = @a; + my $setVal = (@setValArr ? join(' ', @setValArr) : ""); + my (%rmap, $setNum, $setOpt, $rawVal); + if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: set called with $setName but device is disabled" if ($setName ne "?"); @@ -396,75 +1123,27 @@ sub HTTPMOD_Set($@) if ($setName ne "?"); if (AttrVal($name, "enableControlSet", undef)) { # spezielle Sets freigeschaltet? - $setList = "interval reread:noArg stop:noArg start:noArg "; - if ($setName eq 'interval') { - if (int $setVal > 5) { - $hash->{Interval} = $setVal; - my $nextTrigger = gettimeofday() + $hash->{Interval}; - RemoveInternalTimer("update:$name"); - $hash->{TRIGGERTIME} = $nextTrigger; - $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); - InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); - Log3 $name, 3, "$name: timer interval changed to $hash->{Interval} seconds"; - return undef; - } elsif (int $setVal <= 5) { - Log3 $name, 3, "$name: interval $setVal (sec) to small (must be >5), continuing with $hash->{Interval} (sec)"; - } else { - Log3 $name, 3, "$name: no interval (sec) specified in set, continuing with $hash->{Interval} (sec)"; - } - } elsif ($setName eq 'reread') { - HTTPMOD_GetUpdate("reread:$name"); - return undef; - } elsif ($setName eq 'stop') { - RemoveInternalTimer("update:$name"); - $hash->{TRIGGERTIME} = 0; - $hash->{TRIGGERTIME_FMT} = ""; - Log3 $name, 3, "$name: internal interval timer stopped"; - return undef; - } elsif ($setName eq 'start') { - my $nextTrigger = gettimeofday() + $hash->{Interval}; - $hash->{TRIGGERTIME} = $nextTrigger; - $hash->{TRIGGERTIME_FMT} = FmtDateTime($nextTrigger); - RemoveInternalTimer("update:$name"); - InternalTimer($nextTrigger, "HTTPMOD_GetUpdate", "update:$name", 0); - Log3 $name, 5, "$name: internal interval timer set to call GetUpdate in " . int($hash->{Interval}). " seconds"; - return undef; - } + my $error = HTTPMOD_ControlSet($hash, $setName, $setVal); + return undef if (defined($error) && $error eq "0"); # control set found and done. + return $error if ($error); # error + # continue if function returned undef } - # verarbeite Attribute "set[0-9]*Name set[0-9]*URL set[0-9]*Data.* set[0-9]*Header.* - # set[0-9]*Min set[0-9]*Max set[0-9]*Map set[0-9]*Expr set[0-9]*Hint - # Vorbereitung: - # suche den übergebenen setName in den Attributen, setze setNum und erzeuge rmap falls gefunden + # suche den übergebenen setName in den Attributen und setze setNum + foreach my $aName (keys %{$attr{$name}}) { - if ($aName =~ "set([0-9]+)Name") { # ist das Attribut ein "setXName" ? - my $setI = $1; # merke die Nummer im Namen - my $iName = $attr{$name}{$aName}; # Name der Set-Option diser Schleifen-Iteration - - if ($setName eq $iName) { # ist es der im konkreten Set verwendete setName? - $setNum = $setI; # gefunden -> merke Nummer X im Attribut - } - - # erzeuge setOpt für die Rückgabe bei set X ? - if (AttrVal($name, "set${setI}Map", undef)) { # nochmal: gibt es eine Map (für Hint) - my $hint = AttrVal($name, "set${setI}Map", undef); # create hint from map - $hint =~ s/([^ ,\$]+):([^ ,\$]+,?) ?/$2/g; - $setOpt = $iName . ":$hint"; # setOpt ist Name:Hint (aus Map) - } else { - $setOpt = $iName; # nur den Namen für setopt verwenden. - } - if (AttrVal($name, "set${setI}Hint", undef)) { # gibt es einen expliziten Hint? - $setOpt = $iName . ":" . - AttrVal($name, "set${setI}Hint", undef); - } - $setList .= $setOpt . " "; # speichere Liste mit allen Sets inkl. der Hints nach ":" für Rückgabe bei Set ? + if ($aName =~ /set([0-9]+)Name/) { # ist das Attribut ein "setXName" ? + if ($setName eq $attr{$name}{$aName}) { # ist es der im konkreten Set verwendete setName? + $setNum = $1; # gefunden -> merke Nummer X im Attribut + } } } # gültiger set Aufruf? ($setNum oben schon gesetzt?) if(!defined ($setNum)) { - return "Unknown argument $setName, choose one of $setList"; + HTTPMOD_UpdateHintList($hash) if ($hash->{".updateHintList"}); + return "Unknown argument $setName, choose one of " . $hash->{".setList"}; } Log3 $name, 5, "$name: set found option $setName in attribute set${setNum}Name"; @@ -476,11 +1155,18 @@ sub HTTPMOD_Set($@) # Eingabevalidierung von Sets mit Definition per Attributen # 1. Schritt, falls definiert, per Umkehrung der Map umwandeln (z.B. Text in numerische Codes) - if (AttrVal($name, "set${setNum}Map", undef)) { # gibt es eine Map? - my $rm = AttrVal($name, "set${setNum}Map", undef); - #$rm =~ s/([^ ,\$]+):([^ ,\$]+),? ?/$2 $1 /g; # reverse map string erzeugen - $rm =~ s/([^, ][^,\$]*):([^, ][^,\$]*),? ?/$2:$1, /g; # reverse map string erzeugen - %rmap = split (/, +|:/, $rm); # reverse hash aus dem reverse string + + + my $map = AttrVal($name, "set${setNum}Map", ""); # old Map for set is now IMap (Input) + $map = AttrVal($name, "set${setNum}IMap", $map); # new syntax ovverides old one + if ($map) { + my $rm = $map; + $rm =~ s/([^, ][^,\$]*):([^,][^,\$]*),? */$2:$1, /g; # reverse map string erzeugen + $setVal = decode ('UTF-8', $setVal); # convert nbsp from fhemweb + $setVal =~ s/\s| / /g; # back to normal spaces + + %rmap = split (/, *|:/, $rm); # reverse hash aus dem reverse string + if (defined($rmap{$setVal})) { # Eintrag für den übergebenen Wert in der Map? $rawVal = $rmap{$setVal}; # entsprechender Raw-Wert für das Gerät Log3 $name, 5, "$name: set found $setVal in rmap and converted to $rawVal"; @@ -498,15 +1184,17 @@ sub HTTPMOD_Set($@) } $rawVal = $setVal; } - + + # kein TextArg? if (!AttrVal($name, "set${setNum}TextArg", undef)) { - # 2. Schritt: falls definiert Min- und Max-Werte prüfen - falls kein TextArg + # prüfe Min if (AttrVal($name, "set${setNum}Min", undef)) { my $min = AttrVal($name, "set${setNum}Min", undef); Log3 $name, 5, "$name: is checking value $rawVal against min $min"; return "set value $rawVal is smaller than Min ($min)" if ($rawVal < $min); } + # Prüfe Max if (AttrVal($name, "set${setNum}Max", undef)) { my $max = AttrVal($name, "set${setNum}Max", undef); Log3 $name, 5, "$name: set is checking value $rawVal against max $max"; @@ -515,82 +1203,30 @@ sub HTTPMOD_Set($@) } } - # 3. Schritt: Konvertiere mit setexpr falls definiert - if (AttrVal($name, "set${setNum}Expr", undef)) { + # Konvertiere input mit IExpr falls definiert + my $exp = AttrVal($name, "set${setNum}Expr", ""); # old syntax for input in set + $exp = AttrVal($name, "set${setNum}IExpr", ""); # new syntax overrides old one + if ($exp) { my $val = $rawVal; - my $exp = AttrVal($name, "set${setNum}Expr", undef); $rawVal = eval($exp); - Log3 $name, 5, "$name: set converted value $val to $rawVal using expr $exp"; - } - + if ($@) { + Log3 $name, 3, "$name: Set error in setExpr $exp: $@"; + } else { + Log3 $name, 5, "$name: set converted value $val to $rawVal using expr $exp"; + } + } Log3 $name, 4, "$name: set will now set $setName -> $rawVal"; - my $result = HTTPMOD_DoSet($hash, $setNum, $rawVal); - return "$setName -> $rawVal"; } else { + # NoArg + $rawVal = 0; Log3 $name, 4, "$name: set will now set $setName"; - HTTPMOD_DoSet($hash, $setNum, 0); - return $setName; } - -} - - - -# put URL, Header, Data etc. in hash for HTTPUtils Get -# for get with index $getNum -######################################################################### -sub HTTPMOD_DoGet($$) -{ - my ($hash, $getNum) = @_; - my $name = $hash->{NAME}; - my ($url, $header, $data, $type, $count); - my $seq = $hash->{GetSeq}; - - # hole alle Header bzw. generischen Header ohne Nummer - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/get${getNum}Header/, keys %{$attr{$name}}))); - if (length $header == 0) { - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/getHeader/, keys %{$attr{$name}}))); - } - if (AttrVal($name, "get${getNum}HdrExpr", undef)) { - my $exp = AttrVal($name, "get${getNum}HdrExpr", undef); - my $old = $header; - $header = eval($exp); - Log3 $name, 5, "$name: get converted the header $old\n to $header\n using expr $exp"; - } - - # hole Bestandteile der Post data - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/get${getNum}Data/, keys %{$attr{$name}}))); - if (length $data == 0) { - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/getData/, keys %{$attr{$name}}))); - } - if (AttrVal($name, "get${getNum}DatExpr", undef)) { - my $exp = AttrVal($name, "get${getNum}DatExpr", undef); - my $old = $data; - $data = eval($exp); - Log3 $name, 5, "$name: get converted the post data $old\n to $data\n using expr $exp"; - } - - # hole URL - $url = AttrVal($name, "get${getNum}URL", undef); - if (!$url) { - $url = AttrVal($name, "getURL", undef); - } - if (AttrVal($name, "get${getNum}URLExpr", undef)) { - my $exp = AttrVal($name, "get${getNum}URLExpr", undef); - my $old = $url; - $url = eval($exp); - Log3 $name, 5, "$name: get converted the url $old to $url using expr $exp"; - } - if (!$url) { - $url = $hash->{MainURL}; - } - - $type = "Get$getNum"; + my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "set", $setNum); if ($url) { - HTTPMOD_AddToQueue($hash, $url, $header, $data, $type); + HTTPMOD_AddToQueue($hash, $url, $header, $data, "set$setNum", $rawVal); } else { - Log3 $name, 3, "$name: no URL for $type"; + Log3 $name, 3, "$name: no URL for set $setNum"; } return undef; @@ -602,65 +1238,64 @@ sub HTTPMOD_DoGet($$) ######################################################################### sub HTTPMOD_Get($@) { - my ( $hash, @a ) = @_; + my ($hash, @a) = @_; return "\"get HTTPMOD\" needs at least an argument" if ( @a < 2 ); - # @a is an array with DeviceName, getName - my ($name, $getName) = @a; - my ($getNum, $getList); - $hash->{GetSeq} = 0; - $getList = ""; + # @a is an array with DeviceName, getName, options + my ($name, $getName, @getValArr) = @a; + my $getVal = (@getValArr ? join(' ', @getValArr) : ""); # optional value after get name - might be used in HTTP request + my $getNum; if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: get called with $getName but device is disabled" if ($getName ne "?"); return undef; } - - Log3 $name, 5, "$name: get called with $getName " - if ($getName ne "?"); + Log3 $name, 5, "$name: get called with $getName " if ($getName ne "?"); - # verarbeite Attribute "get[0-9]*Name get[0-9]*URL get[0-9]*Data.* get[0-9]*Header.* - # Vorbereitung: # suche den übergebenen getName in den Attributen, setze getNum falls gefunden foreach my $aName (keys %{$attr{$name}}) { - if ($aName =~ "get([0-9]+)Name") { # ist das Attribut ein "getXName" ? - my $getI = $1; # merke die Nummer im Namen - my $iName = $attr{$name}{$aName}; # Name der get-Option diser Schleifen-Iteration - - if ($getName eq $iName) { # ist es der im konkreten get verwendete getName? - $getNum = $getI; # gefunden -> merke Nummer X im Attribut + if ($aName =~ /get([0-9]+)Name/) { # ist das Attribut ein "getXName" ? + if ($getName eq $attr{$name}{$aName}) { # ist es der im konkreten get verwendete getName? + $getNum = $1; # gefunden -> merke Nummer X im Attribut } - $getList .= $iName . " "; # speichere Liste mit allen gets für Rückgabe bei get ? } } - + # gültiger get Aufruf? ($getNum oben schon gesetzt?) if(!defined ($getNum)) { - return "Unknown argument $getName, choose one of $getList"; + HTTPMOD_UpdateHintList($hash) if ($hash->{".updateHintList"}); + return "Unknown argument $getName, choose one of " . $hash->{".getList"}; } Log3 $name, 5, "$name: get found option $getName in attribute get${getNum}Name"; - Log3 $name, 4, "$name: get will now request $getName"; + Log3 $name, 4, "$name: get will now request $getName" . + ($getVal ? ", value = $getVal" : ", no optional value"); + + my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $getNum); + if ($url) { + HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$getNum", $getVal); + } else { + Log3 $name, 3, "$name: no URL for Get $getNum"; + } - my $result = HTTPMOD_DoGet($hash, $getNum); return "$getName requested, watch readings"; } - # # request new data from device +# calltype can be update and reread ################################### sub HTTPMOD_GetUpdate($) { - my ($calltype,$name) = split(':', $_[0]); + my ($calltype, $name) = split(':', $_[0]); my $hash = $defs{$name}; - my ($url, $header, $data, $type, $count); + my ($url, $header, $data, $count); my $now = gettimeofday(); Log3 $name, 4, "$name: GetUpdate called ($calltype)"; - + if ($calltype eq "update" && $hash->{Interval}) { RemoveInternalTimer ("update:$name"); my $nt = gettimeofday() + $hash->{Interval}; @@ -675,17 +1310,13 @@ sub HTTPMOD_GetUpdate($) return undef; } - if ( $hash->{MainURL} ne "none" ) { - $url = $hash->{MainURL}; - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestHeader/, keys %{$attr{$name}}))); - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/requestData/, keys %{$attr{$name}}))); - $type = "Update"; - + if ($hash->{MainURL}) { # queue main get request + ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "reading"); # context "reading" is used for other attrs relevant for GetUpdate if ($url) { - HTTPMOD_AddToQueue($hash, $url, $header, $data, $type); + HTTPMOD_AddToQueue($hash, $url, $header, $data, "update"); # use request type "update" } else { - Log3 $name, 3, "$name: no URL for $type"; + Log3 $name, 3, "$name: GetUpdate: no Main URL specified"; } } @@ -705,147 +1336,638 @@ sub HTTPMOD_GetUpdate($) Log3 $name, 5, "$name: GetUpdate will request $getName"; $hash->{lastpoll}{$getName} = $now; - # hole alle Header bzw. generischen Header ohne Nummer - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/get${getNum}Header/, keys %{$attr{$name}}))); - if (length $header == 0) { - $header = join ("\r\n", map ($attr{$name}{$_}, sort grep (/getHeader/, keys %{$attr{$name}}))); - } - # hole Bestandteile der Post data - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/get${getNum}Data/, keys %{$attr{$name}}))); - if (length $data == 0) { - $data = join ("\r\n", map ($attr{$name}{$_}, sort grep (/getData/, keys %{$attr{$name}}))); - } - # hole URL - $url = AttrVal($name, "get${getNum}URL", undef); - if (!$url) { - $url = AttrVal($name, "getURL", undef); - } - if (!$url) { - $url = $hash->{MainURL} if ( $hash->{MainURL} ne "none" ); - } - - $type = "Get$getNum"; + ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $getNum); if ($url) { - HTTPMOD_AddToQueue($hash, $url, $header, $data, $type); + HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$getNum"); } else { - Log3 $name, 3, "$name: no URL to get $type"; - } + Log3 $name, 3, "$name: no URL for Get $getNum"; + } } else { Log3 $name, 5, "$name: GetUpdate will skip $getName, delay not over"; } + } else { + Log3 $name, 3, "$name: GetUpdate found $poll without a matching Name attribute - ignoring it"; } } } -# extract one reading for a buffer -# and apply Expr, Map and Format -################################### -sub HTTPMOD_ExtractReading($$$$$$$$$) +# Try to call a parse function if defined +######################################### +sub HTTPMOD_TryCall($$$$) { - my ($hash, $buffer, $reading, $regex, $expr, $map, $format, $decode, $encode) = @_; + my ($hash, $buffer, $fName, $type) = @_; my $name = $hash->{NAME}; - my $val = ""; - my $match; + if (AttrVal($name, $fName, undef)) { + Log3 $name, 5, "$name: Read is calling $fName for HTTP Response to $type"; + my $func = AttrVal($name, 'parseFunction1', undef); + no strict "refs"; + eval { &{$func}($hash,$buffer) }; + if( $@ ) { + Log3 $name, 3, "$name: error calling $func: $@"; + } + use strict "refs"; + } +} - if (AttrVal($name, "enableXPath", undef) && $regex =~ /^xpath:(.*)/) { - Log3 $name, 5, "$name: ExtractReading $reading with xpath $1 ..."; - my $xpath = $1; - my $tree = HTML::TreeBuilder::XPath->new; - my $html = $buffer; - $html =~ s/.*?(\r\n){2}//s; # remove HTTP-header - - # if the xpath isn't syntactically correct, fhem would crash - # the use of eval prevents this from happening - $val = eval(' - $tree->parse($html); - $val = join ",", $tree->findvalues($xpath); - $tree->delete(); - $val; - '); - $match = $val; - } elsif (AttrVal($name, "enableXPath-Strict", undef) && $regex =~ /^xpath-strict:(.*)/) { - Log3 $name, 5, "$name: ExtractReading $reading with strict xpath $1 ..."; - my $xpath = $1; - my $xml= $buffer; - $xml =~ s/.*?(\r\n){2}//s; # remove HTTP-header - - # if the xml isn't wellformed, fhem would crash - # the use of eval prevents this from happening - $val = eval(' - my $xp = XML::XPath->new(xml => $xml); - my $nodeset = $xp->find($xpath); - my @vals; - foreach my $node ($nodeset->get_nodelist) { - push @vals, XML::XPath::XMLParser::as_string($node); - } - $val = join ",", @vals; - $xp->cleanup(); - $val; - '); - $match = $val; + +# recoursive main part for +# HTTPMOD_FlattenJSON($$) +################################### +sub HTTPMOD_JsonFlatter($$;$) +{ + my ($hash,$ref,$prefix) = @_; + my $name = $hash->{NAME}; + + $prefix = "" if( !$prefix ); + + #Log3 $name, 5, "$name: JSON Flatter with prefix $prefix, ref $ref, pointer to " . ref($ref); + if (ref($ref) eq "ARRAY" ) { + while( my ($key,$value) = each @{$ref}) { + #Log3 $name, 5, "$name: JSON Flatter recursive call in array while, key = $key, value = $value"; + HTTPMOD_JsonFlatter($hash, $value, $prefix.sprintf("%02i",$key+1)."_"); + } + } elsif (ref($ref) eq "HASH" ) { + while( my ($key,$value) = each %{$ref}) { + #Log3 $name, 5, "$name: JSON Flatter in hash while, key = $key, value = $value, ref(value) = " . ref($value); + if(ref($value) eq "HASH" or ref($value) eq "ARRAY") { + #Log3 $name, 5, "$name: JSON Flatter recursive call in hash while, key = $key, value = $value"; + HTTPMOD_JsonFlatter($hash, $value, $prefix.$key."_"); + } else { + if (defined ($value)) { + Log3 $name, 5, "$name: JSON Flatter sets $prefix$key to $value"; + $hash->{ParserData}{JSON}{$prefix.$key} = $value; + } + } + } + } +} + +# entry to create a flat hash +# out of a pares JSON hash hierarchy +#################################### +sub HTTPMOD_FlattenJSON($$) +{ + my ($hash, $buffer) = @_; + my $name = $hash->{NAME}; + + my $decoded = eval 'decode_json($buffer)'; + if ($@) { + Log3 $name, 3, "$name: error while parsing JSON data: $@"; } else { - Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/..."; - $match = ($buffer =~ /$regex/); - $val = $1 if ($match); + HTTPMOD_JsonFlatter($hash, $decoded); + Log3 $name, 5, "$name: extracted JSON values to internal"; + } +} + + +# format a reading value +################################### +sub HTTPMOD_FormatReading($$$$) +{ + my ($name, $context, $num, $val) = @_; + my ($format, $decode, $encode); + my $expr = ""; + my $map = ""; + + if ($context eq "reading") { + $expr = AttrVal($name, 'readingsExpr' . $num, "") if ($context ne "set"); # very old syntax, not for set! + } + + $decode = HTTPMOD_GetFAttr($name, $context, $num, "Decode"); + $encode = HTTPMOD_GetFAttr($name, $context, $num, "Encode"); + $map = HTTPMOD_GetFAttr($name, $context, $num, "Map") if ($context ne "set"); # not for set! + $map = HTTPMOD_GetFAttr($name, $context, $num, "OMap", $map); # new syntax + $format = HTTPMOD_GetFAttr($name, $context, $num, "Format"); + $expr = HTTPMOD_GetFAttr($name, $context, $num, "Expr", $expr) if ($context ne "set"); # not for set! + $expr = HTTPMOD_GetFAttr($name, $context, $num, "OExpr", $expr); # new syntax + + $val = decode($decode, $val) if ($decode); + $val = encode($encode, $val) if ($encode); + + if ($expr) { + my $old = $val; + $val = eval $expr; + if ($@) { + Log3 $name, 3, "$name: FormatReading error, context $context, expression $expr: $@"; + } + + Log3 $name, 5, "$name: FormatReading changed value with Expr $expr from $old to $val"; } - if ($match) { - - $val = decode($decode, $val) if ($decode); - $val = encode($encode, $val) if ($encode); - - if ($expr) { - $val = eval $expr; - Log3 $name, 5, "$name: ExtractReading changed $reading with Expr $expr from $1 to $val"; + if ($map) { # gibt es eine Map? + my %map = split (/, +|:/, $map); # hash aus dem map string + if (defined($map{$val})) { # Eintrag für den gelesenen Wert in der Map? + my $nVal = $map{$val}; # entsprechender sprechender Wert für den rohen Wert aus dem Gerät + Log3 $name, 5, "$name: FormatReading found $val in map and converted to $nVal"; + $val = $nVal; + } else { + Log3 $name, 3, "$name: FormatReading could not match $val to defined map"; } - - if ($map) { # gibt es eine Map? - my %map = split (/, +|:/, $map); # hash aus dem map string - if (defined($map{$val})) { # Eintrag für den gelesenen Wert in der Map? - my $nVal = $map{$val}; # entsprechender sprechender Wert für den rohen Wert aus dem Gerät - Log3 $name, 5, "$name: ExtractReading found $val in map and converted to $nVal"; - $val = $nVal; - } else { - Log3 $name, 3, "$name: ExtractReading cound not match $val to defined map"; - } - } - - if ($format) { - Log3 $name, 5, "$name: ExtractReading for $reading does sprintf with format " . $format . - " value is $val"; - $val = sprintf($format, $val); - Log3 $name, 5, "$name: ExtractReading for $reading sprintf result is $val"; - } - - Log3 $name, 5, "$name: ExtractReading sets $reading to $val"; - readingsBulkUpdate( $hash, $reading, $val ); - return 1; - } else { - Log3 $name, 5, "$name: ExtractReading $reading did not match (val is >$val<)"; - return 0; } -} - - -# get attribute based specification -# for format, map or similar -# with generic default (empty variable part) -############################################# -sub HTTPMOD_GetFAttr($$$$) -{ - my ($name, $prefix, $num, $type) = @_; - my $val = ""; - if (defined ($attr{$name}{$prefix . $num . $type})) { - $val = $attr{$name}{$prefix . $num . $type}; - } elsif - (defined ($attr{$name}{$prefix . $type})) { - $val = $attr{$name}{$prefix . $type}; + + if ($format) { + Log3 $name, 5, "$name: FormatReading does sprintf with format " . $format . + " value is $val"; + $val = sprintf($format, $val); + Log3 $name, 5, "$name: FormatReading sprintf result is $val"; } return $val; } +# extract reading for a buffer +################################### +sub HTTPMOD_ExtractReading($$$$) +{ + my ($hash, $buffer, $context, $num) = @_; + my $name = $hash->{NAME}; + my ($val, $reading, $regex) = ("", "", ""); + my ($json, $xpath, $xpathst, $recomb, $regopt, $sublen); + my @subrlist = (); + my @matchlist = (); + my $try = 1; # was there any applicable parsing definition? + + $json = HTTPMOD_GetFAttr($name, $context, $num, "JSON"); + $xpath = HTTPMOD_GetFAttr($name, $context, $num, "XPath"); + $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "XPath-Strict"); + $regopt = HTTPMOD_GetFAttr($name, $context, $num, "RegOpt"); + $recomb = HTTPMOD_GetFAttr($name, $context, $num, "RecombineExpr"); + $sublen = HTTPMOD_GetFAttr($name, $context, $num, "AutoNumLen"); + + # support for old syntax + if ($context eq "reading") { + $reading = AttrVal($name, 'readingsName'.$num, ($json ? $json : "unnamed-$num")); + $regex = AttrVal($name, 'readingsRegex'.$num, ""); + } + # new syntax overrides reading and regex + $reading = HTTPMOD_GetFAttr($name, $context, $num, "Name", $reading); + $regex = HTTPMOD_GetFAttr($name, $context, $num, "Regex", $regex); + + + if ($regex) { + # old syntax for xpath and xpath-strict as prefix in regex - one result joined + if (AttrVal($name, "enableXPath", undef) && $regex =~ /^xpath:(.*)/) { + $xpath = $1; + Log3 $name, 5, "$name: ExtractReading $reading with old XPath syntax in regex /$regex/, xpath = $xpath"; + eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; + Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); + @matchlist = (join ",", @matchlist); # old syntax returns only one value + } elsif (AttrVal($name, "enableXPath-Strict", undef) && $regex =~ /^xpath-strict:(.*)/) { + $xpathst = $1; + Log3 $name, 5, "$name: ExtractReading $reading with old XPath-strict syntax in regex /$regex/..."; + my $nodeset; + eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; + if ($@) { + Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; + } else { + foreach my $node ($nodeset->get_nodelist) { + push @matchlist, XML::XPath::XMLParser::as_string($node); + } + } + @matchlist = (join ",", @matchlist); # old syntax returns only one value + } else { + # normal regex + if ($regopt) { + Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/$regopt ..."; + eval '@matchlist = ($buffer =~ /' . "$regex/$regopt" . ')'; + Log3 $name, 3, "$name: error in regex matching with regex option: $@" if ($@); + } else { + Log3 $name, 5, "$name: ExtractReading $reading with regex /$regex/..."; + @matchlist = ($buffer =~ /$regex/); + } + Log3 $name, 5, "$name: " . @matchlist . " capture group(s), matchlist = " . join ",", @matchlist if (@matchlist); + } + } elsif ($json) { + if (defined($hash->{ParserData}{JSON}) && + defined($hash->{ParserData}{JSON}{$json})) { + @matchlist = ($hash->{ParserData}{JSON}{$json}); + } + } elsif ($xpath) { + Log3 $name, 5, "$name: ExtractReading $reading with XPath $xpath"; + eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; + Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); + } elsif ($xpathst) { + Log3 $name, 5, "$name: ExtractReading $reading with XPath-Strict $xpathst"; + my $nodeset; + eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; + if ($@) { + Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; + } else { + foreach my $node ($nodeset->get_nodelist) { + push @matchlist, XML::XPath::XMLParser::as_string($node); + } + } + } else { + $try = 0; # neither regex, xpath nor json attribute found ... + Log3 $name, 5, "$name: ExtractReading for context $context, num $num - no individual parse definition"; + } + + my $match = @matchlist; + if ($match) { + my ($eNum, $subReading); + my $group = 1; + my $subNum = ""; + + if ($recomb) { + Log3 $name, 5, "$name: ExtractReading is recombining $match matches with expression $recomb"; + my $val = (eval $recomb); + if ($@) { + Log3 $name, 3, "$name: ExtractReading error in RecombineExpr: $@"; + } + Log3 $name, 5, "$name: ExtractReading recombined matchlist to $val"; + @matchlist = ($val); + $match = 1; + } + foreach $val (@matchlist) { + if ($match == 1) { + # only one match + $eNum = $num; + $subReading = $reading; + @subrlist = ($reading); + } else { + # multiple matches -> check for special name of readings + $eNum = $num ."-".$group; + # don't use GetFAttr here because we don't want to get the value of the generic attribute "Name" + # but this name with -group number added as default + if (defined ($attr{$name}{$context . $eNum . "Name"})) { + $subReading = $attr{$name}{$context . $eNum . "Name"}; + } else { + if ($sublen) { + $subReading = "${reading}-" . sprintf ("%0${sublen}d", $group); + } else { + $subReading = "${reading}-$group"; + } + $subNum = "-$group"; + } + push @subrlist, $subReading; + } + $val = HTTPMOD_FormatReading($name, $context, $eNum, $val); + Log3 $name, 5, "$name: ExtractReading for match $group sets $subReading to $val"; + readingsBulkUpdate( $hash, $subReading, $val ); + $hash->{defptr}{readingBase}{$subReading} = $context; + $hash->{defptr}{readingNum}{$subReading} = $num; + $hash->{defptr}{readingSubNum}{$subReading} = $subNum; + delete $hash->{defptr}{readingOutdated}{$subReading}; + $group++; + } + } else { + Log3 $name, 5, "$name: ExtractReading $reading did not match" if ($try); + } + return ($try, $match, $reading, @subrlist); +} + + + +# pull log lines to a file +################################### +sub HTTPMOD_PullToFile($$$$) +{ + my ($hash, $buffer, $num, $file) = @_; + my $name = $hash->{NAME}; + + my $reading = HTTPMOD_GetFAttr($name, "get", $num, "Name"); + my $regex = HTTPMOD_GetFAttr($name, "get", $num, "Regex"); + my $iterate = HTTPMOD_GetFAttr($name, "get", $num, "PullIterate"); + my $recombine = HTTPMOD_GetFAttr($name, "get", $num, "RecombineExpr"); + $recombine = '$1' if not ($recombine); + my $matches = 0; + $hash->{GetSeq} = 0 if (!$hash->{GetSeq}); + + Log3 $name, 5, "$name: Read is pulling to file, sequence is $hash->{GetSeq}"; + while ($buffer =~ /$regex/g) { + $matches++; + no warnings qw(uninitialized); + my $val = eval($recombine); + if ($@) { + Log3 $name, 3, "$name: PullToFile error in RecombineExpr $recombine: $@"; + } else { + Log3 $name, 3, "$name: Read pulled line $val"; + } + } + Log3 $name, 3, "$name: Read pulled $matches lines"; + if ($matches) { + if ($iterate && $hash->{GetSeq} < $iterate) { + $hash->{GetSeq}++; + Log3 $name, 5, "$name: Read is iterating pull until $iterate, next is $hash->{GetSeq}"; + my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $num); + HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$num"); + } else { + Log3 $name, 5, "$name: Read is done with pull after $hash->{GetSeq}."; + } + } else { + Log3 $name, 5, "$name: Read is done with pull, no more lines matched"; + } + return (1, 1, $reading); +} + + +# check max age of all readings +################################### +sub HTTPMOD_DoMaxAge($) +{ + my ($hash) = @_; + my $name = $hash->{NAME}; + my ($base, $num, $sub, $max, $rep, $mode, $time, $now); + my $readings = $hash->{READINGS}; + return if (!$readings); + $now = gettimeofday(); + readingsBeginUpdate($hash); + foreach my $reading (sort keys %{$readings}) { + my $key = $reading; # in most cases the reading name can be looked up in the readingBase hash + Log3 $name, 5, "$name: MaxAge: check reading $reading"; + if ($hash->{defptr}{readingOutdated}{$reading}) { + Log3 $name, 5, "$name: MaxAge: reading $reading was outdated before - skipping"; + next; + } + + # get base name of definig attribute like "reading" or "get" + $base = $hash->{defptr}{readingBase}{$reading}; + if (!$base && $reading =~ /(.*)(-[0-9]+)$/) { + # reading name endet auf -Zahl und ist nicht selbst per attr Name definiert + # -> suche nach attr Name mit Wert ohne -Zahl + $key = $1; + $base = $hash->{defptr}{readingBase}{$key}; + Log3 $name, 5, "$name: MaxAge: no defptr for this name - reading name seems automatically created with $2 from $key and not updated recently"; + } + if (!$base) { + Log3 $name, 5, "$name: MaxAge: reading $reading doesn't come from a -Name attr -> skipping"; + next; + } + + $num = $hash->{defptr}{readingNum}{$key}; + if ($hash->{defptr}{readingSubNum}{$key}) { + $sub = $hash->{defptr}{readingSubNum}{$key}; + } else { + $sub = ""; + } + + Log3 $name, 5, "$name: MaxAge: reading definition comes from $base, $num" . ($sub ? ", $sub" : ""); + $max = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAge"); + if ($max) { + $rep = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAgeReplacement", ""); + $mode = HTTPMOD_GetFAttr($name, $base, $num . $sub, "MaxAgeReplacementMode", "text"); + $time = ReadingsTimestamp($name, $reading, 0); + Log3 $name, 5, "$name: MaxAge: max = $max, mode = $mode, rep = $rep"; + if ($now - time_str2num($time) > $max) { + if ($mode eq "expression") { + Log3 $name, 5, "$name: MaxAge: reading $reading too old - using Perl expression as MaxAge replacement: $rep"; + my $val = ReadingsVal($name, $reading, ""); + $rep = eval($rep); + if($@) { + Log3 $name, 3, "$name: MaxAge: error in replacement expression $1: $@"; + $rep = "error in replacement expression"; + } else { + Log3 $name, 5, "$name: MaxAge: result is $rep"; + } + readingsBulkUpdate($hash, $reading, $rep); + } elsif ($mode eq "text") { + Log3 $name, 5, "$name: MaxAge: reading $reading too old - using $rep instead"; + readingsBulkUpdate($hash, $reading, $rep); + } elsif ($mode eq "delete") { + Log3 $name, 5, "$name: MaxAge: reading $reading too old - delete it"; + delete($defs{$name}{READINGS}{$reading}); + delete $hash->{defptr}{readingOutdated}{$reading}; + } + $hash->{defptr}{readingOutdated}{$reading} = 1; + } + } else { + Log3 $name, 5, "$name: MaxAge: No MaxAge attr for $base, $num, $sub"; + } + } + readingsEndUpdate($hash, 1); +} + + +# +# extract cookies from HTTP Response Header +# called from _Read +########################################### +sub HTTPMOD_GetCookies($$) +{ + my ($hash, $header) = @_; + my $name = $hash->{NAME}; + Log3 $name, 5, "$name: looking for Cookies in $header"; + foreach my $cookie ($header =~ m/set-cookie: ?(.*)/gi) { + Log3 $name, 5, "$name: Set-Cookie: $cookie"; + $cookie =~ /([^,; ]+)=([^,; ]+)[;, ]*(.*)/; + Log3 $name, 5, "$name: Cookie: $1 Wert $2 Rest $3"; + $hash->{HTTPCookieHash}{$1}{Value} = $2; + $hash->{HTTPCookieHash}{$1}{Options} = ($3 ? $3 : ""); + } + $hash->{HTTPCookies} = join ("; ", map ($_ . "=".$hash->{HTTPCookieHash}{$_}{Value}, + sort keys %{$hash->{HTTPCookieHash}})); +} + + +# initialize Parsers +# called from _Read +################################### +sub HTTPMOD_InitParsers($$) +{ + my ($hash, $body) = @_; + my $name = $hash->{NAME}; + + # initialize parsers + if ($hash->{JSONEnabled}) { + HTTPMOD_FlattenJSON($hash, $body); + } + if ($hash->{XPathEnabled} && $body) { + $hash->{ParserData}{XPathTree} = HTML::TreeBuilder::XPath->new; + eval {$hash->{ParserData}{XPathTree}->parse($body)}; + Log3 $name, ($@ ? 3 : 5), "$name: InitParsers: XPath parsing " . ($@ ? "error: $@" : "done."); + } + if ($hash->{XPathStrictEnabled} && $body) { + eval {$hash->{ParserData}{XPathStrictNodeset} = XML::XPath->new(xml => $body)}; + Log3 $name, ($@ ? 3 : 5), "$name: InitParsers: XPath-Strict parsing " . ($@ ? "error: $@" : "done."); + } +} + + +# cleanup Parsers +# called from _Read +################################### +sub HTTPMOD_CleanupParsers($) +{ + my ($hash) = @_; + my $name = $hash->{NAME}; + + if ($hash->{XPathEnabled}) { + eval {$hash->{ParserData}{XPathTree}->delete()}; + Log3 $name, 3, "$name: error deleting XPathTree: $@" if ($@); + } + if ($hash->{XPathStrictEnabled}) { + eval {$hash->{ParserData}{XPathStrictNodeset}->cleanup()}; + Log3 $name, 3, "$name: error deleting XPathStrict nodeset: $@" if ($@); + } + delete $hash->{ParserData}; +} + + +# Extract SID +# called from _Read +################################### +sub HTTPMOD_ExtractSid($$$$) +{ + my ($hash, $buffer, $context, $num) = @_; + my $name = $hash->{NAME}; + + Log3 $name, 5, "$name: ExtractSid called, context $context, num $num"; + my $regex = AttrVal($name, "idRegex", ""); + my $json = AttrVal($name, "idJSON", ""); + my $xpath = AttrVal($name, "idXPath", ""); + my $xpathst = AttrVal($name, "idXPath-Strict", ""); + + $regex = HTTPMOD_GetFAttr($name, $context, $num, "IDRegex", $regex); + $regex = HTTPMOD_GetFAttr($name, $context, $num, "IdRegex", $regex); + $json = HTTPMOD_GetFAttr($name, $context, $num, "IdJSON", $json); + $xpath = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath", $xpath); + $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "IdXPath-Strict", $xpathst); + + my @matchlist; + if ($json) { + Log3 $name, 5, "$name: Checking SID with JSON $json"; + if (defined($hash->{ParserData}{JSON}) && + defined($hash->{ParserData}{JSON}{$json})) { + @matchlist = ($hash->{ParserData}{JSON}{$json}); + } + } elsif ($xpath) { + Log3 $name, 5, "$name: Checking SID with XPath $xpath"; + eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; + Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); + } elsif ($xpathst) { + Log3 $name, 5, "$name: Checking SID with XPath-Strict $xpathst"; + my $nodeset; + eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; + if ($@) { + Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; + } else { + foreach my $node ($nodeset->get_nodelist) { + push @matchlist, XML::XPath::XMLParser::as_string($node); + } + } + } + + if (@matchlist) { + $buffer = join (' ', @matchlist); + if ($regex) { + Log3 $name, 5, "$name: ExtractSis is replacing buffer to check with match: $buffer"; + } else { + $hash->{sid} = $buffer; + Log3 $name, 5, "$name: ExtractSid set sid to $hash->{sid}"; + return 1; + } + } + + if ($regex) { + if ($buffer =~ $regex) { + $hash->{sid} = $1; + Log3 $name, 5, "$name: ExtractSid set sid to $hash->{sid}"; + return 1; + } else { + Log3 $name, 5, "$name: ExtractSid could not match buffer to IdRegex $regex"; + } + } + return 0; +} + + +# Check if Auth is necessary +# called from _Read +################################### +sub HTTPMOD_CheckAuth($$$$$) +{ + my ($hash, $buffer, $request, $context, $num) = @_; + my $name = $hash->{NAME}; + + my $regex = AttrVal($name, "reAuthRegex", ""); + my $json = AttrVal($name, "reAuthJSON", ""); + my $xpath = AttrVal($name, "reAuthXPath", ""); + my $xpathst = AttrVal($name, "reAuthXPath-Strict", ""); + + if ($context =~ /([gs])et/) { + $regex = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthRegex", $regex); + $json = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthJSON", $json); + $xpath = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath", $xpath); + $xpathst = HTTPMOD_GetFAttr($name, $context, $num, "ReAuthXPath-Strict", $xpathst); + } + + my @matchlist; + if ($json) { + Log3 $name, 5, "$name: Checking Auth with JSON $json"; + if (defined($hash->{ParserData}{JSON}) && + defined($hash->{ParserData}{JSON}{$json})) { + @matchlist = ($hash->{ParserData}{JSON}{$json}); + } + } elsif ($xpath) { + Log3 $name, 5, "$name: Checking Auth with XPath $xpath"; + eval {@matchlist = $hash->{ParserData}{XPathTree}->findnodes_as_strings($xpath)}; + Log3 $name, 3, "$name: error in findvalues for XPathTree: $@" if ($@); + } elsif ($xpathst) { + Log3 $name, 5, "$name: Checking Auth with XPath-Strict $xpathst"; + my $nodeset; + eval {$nodeset = $hash->{ParserData}{XPathStrictNodeset}->find($xpathst)}; + if ($@) { + Log3 $name, 3, "$name: error in find for XPathStrictNodeset: $@"; + } else { + foreach my $node ($nodeset->get_nodelist) { + push @matchlist, XML::XPath::XMLParser::as_string($node); + } + } + } + + if (@matchlist) { + if ($regex) { + $buffer = join (' ', @matchlist); + Log3 $name, 5, "$name: CheckAuth is replacing buffer to check with match: $buffer"; + } else { + Log3 $name, 5, "$name: CheckAuth matched: $buffer"; + return 1; + } + } + + if ($regex) { + Log3 $name, 5, "$name: CheckAuth is checking buffer with ReAuthRegex $regex"; + if ($buffer =~ $regex) { + Log3 $name, 4, "$name: CheckAuth decided new authentication required (ReAuthRegex matched: $regex)"; + if ($request->{retryCount} < AttrVal($name, "authRetries", 1)) { + HTTPMOD_Auth $hash; + #$request->{retryCount}++; # better add one in the call to AddToQueue + HTTPMOD_AddToQueue ($hash, $request->{url}, $request->{header}, + $request->{data}, $request->{type}, $request->{value}, $request->{retryCount}+1); + Log3 $name, 4, "$name: CheckAuth requeued request $request->{type} after auth, retryCount $request->{retryCount} ..."; + return 1; + } else { + Log3 $name, 4, "$name: CheckAuth has no more retries left - did authentication fail?"; + } + } + } + return 0; +} + + +# update List of Readings to parse +# during GetUpdate cycle +################################### +sub HTTPMOD_UpdateReadingList($) +{ + my ($hash) = @_; + my $name = $hash->{NAME}; + + my %khash; + foreach my $a (sort (grep (/readings?[0-9]*/, keys %{$attr{$name}}))) { + if (($a =~ /readingsName(.*)/) && defined ($attr{$name}{'readingsName' . $1})) { + $khash{$1} = 1; # old syntax + } elsif ($a =~ /reading([0-9]+).*/) { + $khash{$1} = 1; # new syntax + } + } + my @list = sort keys %khash; + $hash->{".readingParseList"} = \@list; + Log3 $name, 5, "$name: UpdateReadingList created list of reading.* nums to parse during getUpdate as @list"; + delete $hash->{".updateReadingList"}; +} + # # read / parse new data from device @@ -853,174 +1975,153 @@ sub HTTPMOD_GetFAttr($$$$) ################################### sub HTTPMOD_Read($$$) { - my ($hash, $err, $buffer) = @_; + my ($hash, $err, $body) = @_; my $name = $hash->{NAME}; my $request = $hash->{REQUEST}; + my $header = ($hash->{httpheader} ? $hash->{httpheader} : ""); my $type = $request->{type}; + my ($num, $context, $authQueued); + my @subrlist = (); + + + # set attribute prefix and num for parsing and formatting depending on request type + if ($type =~ /(set|get)(.*)/) { + $num = $2; + $context = $1; + } elsif ($type =~ /(auth)(.*)/) { + $num = $2; + $context = "sid"; + } else { + # request type was update for GetUpdate cycle + $num = ""; + $context = "reading"; # relevant attributes start with "reading..." + } $hash->{BUSY} = 0; - RemoveInternalTimer ($hash); # Remove remaining timeouts of HttpUtils (should be done in HttpUtils) + my $ll = ($err ? 3 : 5); # Log Level - 3 if error + Log3 $name, $ll, "$name: Read callback: request type was $type" . + " retry $request->{retryCount}" . + ($header ? ",\r\nHeader: $header" : ", no headers") . + ($body ? ",\r\nBody: $body" : ", body empty") . + ($err ? ", \r\nError: $err" : "no error"); - $hash->{HTTPHEADER} = "" if (!$hash->{HTTPHEADER}); - $hash->{httpheader} = "" if (!$hash->{httpheader}); - my $header = $hash->{HTTPHEADER} . $hash->{httpheader}; + my $buffer = ($header ? $header . "\r\n\r\n" . $body : $body); # so header can be used to match e.g. sid if ($err) { - Log3 $name, 3, "$name: Read callback: request type was $type" . - ($header ? ",\r\nheader: $header" : ", no headers") . - ($buffer ? ",\r\nbuffer: $buffer" : ", buffer empty") . - ($err ? ", \r\nError $err" : ""); - return; + $buffer = $buffer . "\r\n\r\n" . $err; # so err can be used in reAuthRegex matching + readingsSingleUpdate ($hash, "LAST_ERROR", $err, 1) + if (AttrVal($name, "showError", undef)) } - Log3 $name, 5, "$name: Read Callback: Request type was $type" . - ($header ? ",\r\nheader: $header" : ", no headers") . - ($buffer ? ",\r\nbuffer: $buffer" : ", buffer empty"); + HTTPMOD_UpdateReadingList($hash) if ($hash->{".updateReadingList"}); - - $buffer = $header . "\r\n\r\n" . $buffer if ($header); - - $type =~ "(Auth|Set|Get)(.*)"; - my $num = $2; - - if ($type =~ "Auth") { - # Doing Authentication step -> extract sid - my $idRegex = HTTPMOD_GetFAttr($name, "sid", $num, "IDRegex"); - if ($idRegex) { - if ($buffer =~ $idRegex) { - $hash->{sid} = $1; - Log3 $name, 5, "$name: Read set sid to $hash->{sid}"; - } else { - Log3 $name, 5, "$name: Read could not match buffer to IDRegex $idRegex"; - } - } - return undef; + HTTPMOD_GetCookies($hash, $header) if (AttrVal($name, "enableCookies", 0)); + + HTTPMOD_InitParsers($hash, $body); + + if ($context eq "sid") { + HTTPMOD_ExtractSid($hash, $buffer, $context, $num); } else { - # not in Auth, so check if Auth is necessary - my $ReAuthRegex; - if ($type =~ "Set") { - $ReAuthRegex = AttrVal($name, "set${num}ReAuthRegex", AttrVal($name, "setReAuthRegex", undef)); - } else { - $ReAuthRegex = AttrVal($name, "reAuthRegex", undef); - } - if ($ReAuthRegex) { - Log3 $name, 5, "$name: Read is checking response with ReAuthRegex $ReAuthRegex"; - if ($buffer =~ $ReAuthRegex) { - Log3 $name, 4, "$name: Read decided new authentication required"; - if ($request->{retryCount} < 1) { - HTTPMOD_Auth $hash; - $request->{retryCount}++; - Log3 $name, 4, "$name: Read is requeuing request $type after Auth, retryCount $request->{retryCount} ..."; - HTTPMOD_AddToQueue ($hash, $request->{url}, $request->{header}, - $request->{data}, $request->{type}, $request->{retryCount}); - return undef; - } else { - Log3 $name, 4, "$name: Read has no more retries left - did authentication fail?"; - } - } - } + $authQueued = HTTPMOD_CheckAuth($hash, $body, $request, $context, $num); } - - return undef if ($type =~ "Set"); - - my $checkAll = 0; - my $unmatched = ""; - my $matched = ""; - my ($reading, $regex, $expr, $map, $format, $encode, $decode, $pull); + + if ($err || $authQueued || + ($context =~ "set|sid" && !HTTPMOD_GetFAttr($name, $context, $num, "ParseResponse"))) { + # don't continue parsing response but still check maxAge for all readings + HTTPMOD_DoMaxAge($hash) if ($hash->{MaxAgeEnabled}); + #Log3 $name, 4, "$name: Read: no further parsing"; + HTTPMOD_CleanupParsers($hash); + return undef; + } + + my ($checkAll, $tried, $match, $reading); + my @unmatched = (); my @matched = (); readingsBeginUpdate($hash); - if ($type =~ "Get") { - $checkAll = AttrVal($name, "get" . $num . "CheckAllReadings", 0); - $reading = $attr{$name}{"get" . $num . "Name"}; - $regex = HTTPMOD_GetFAttr($name, "get", $num, "Regex"); - #Log3 $name, 5, "$name: Read is extracting Reading with $regex from HTTP Response to $type"; - if (!$regex) { - $checkAll = 1; + if ($context =~ "get|set") { + my $file = HTTPMOD_GetFAttr($name, $context, $num, "PullToFile"); + if ($file) { + ($tried, $match, $reading) = HTTPMOD_PullToFile($hash, $buffer, $num, $file); + @subrlist = ($reading); } else { - $expr = HTTPMOD_GetFAttr($name, "get", $num, "Expr"); - $map = HTTPMOD_GetFAttr($name, "get", $num, "Map"); - $format = HTTPMOD_GetFAttr($name, "get", $num, "Format"); - $decode = HTTPMOD_GetFAttr($name, "get", $num, "Decode"); - $encode = HTTPMOD_GetFAttr($name, "get", $num, "Encode"); - $pull = HTTPMOD_GetFAttr($name, "get", $num, "PullToFile"); - - if ($pull) { - Log3 $name, 5, "$name: Read is pulling to file, sequence is $hash->{GetSeq}"; - my $iterate = HTTPMOD_GetFAttr($name, "get", $num, "PullIterate"); - my $matches = 0; - while ($buffer =~ /$regex/g) { - my $recombine = HTTPMOD_GetFAttr($name, "get", $num, "RecombineExpr"); - no warnings qw(uninitialized); - $recombine = '$1' if not ($recombine); - my $val = eval($recombine); - Log3 $name, 3, "$name: Read pulled line $val"; - $matched = $reading; - $matches++; - } - Log3 $name, 3, "$name: Read pulled $matches lines"; - if ($matches) { - if ($iterate && $hash->{GetSeq} < $iterate) { - $hash->{GetSeq}++; - Log3 $name, 5, "$name: Read is iterating pull until $iterate, next is $hash->{GetSeq}"; - HTTPMOD_DoGet($hash, $num); - } else { - Log3 $name, 5, "$name: Read is done with pull after $hash->{GetSeq}."; - } - } else { - Log3 $name, 5, "$name: Read is done with pull, no more lines matched"; - } - } elsif (HTTPMOD_ExtractReading($hash, $buffer, $reading, $regex, $expr, $map, $format, $decode, $encode)) { - $matched = ($matched ? "$matched $reading" : "$reading"); + ($tried, $match, $reading, @subrlist) = HTTPMOD_ExtractReading($hash, $buffer, $context, $num); + } + if ($tried) { + if($match) { + push @matched, @subrlist; } else { - $unmatched = ($unmatched ? "$unmatched $reading" : "$reading"); + push @unmatched, $reading; } } + + $checkAll = HTTPMOD_GetFAttr($name, $context, $num, 'CheckAllReadings', !$tried); + # if ExtractReading2 could not find any parsing instruction (e.g. regex) then check all Readings + } else { + $checkAll = 1; } - if (($type eq "Update") || ($checkAll)) { - Log3 $name, 5, "$name: Read starts extracting all Readings from HTTP Response to $type"; - foreach my $a (sort (grep (/readings?[0-9]*Name/, keys %{$attr{$name}}))) { - if (($a =~ /readingsName(.*)/) && defined ($attr{$name}{'readingsName' . $1}) - && defined ($attr{$name}{'readingsRegex' . $1})) { - # old syntax - $reading = AttrVal($name, 'readingsName' . $1, ""); - $regex = AttrVal($name, 'readingsRegex' . $1, ""); - $expr = AttrVal($name, 'readingsExpr' . $1, ""); - } elsif(($a =~ /reading([0-9]+)Name/) && defined ($attr{$name}{"reading${1}Name"}) - && defined ($attr{$name}{"reading${1}Regex"})) { - # new syntax - $reading = AttrVal($name, "reading${1}Name", ""); - $regex = AttrVal($name, "reading${1}Regex", ""); - $expr = HTTPMOD_GetFAttr($name, "reading", $1, "Expr"); - $map = HTTPMOD_GetFAttr($name, "reading", $1, "Map"); - $format = HTTPMOD_GetFAttr($name, "reading", $1, "Format"); - $decode = HTTPMOD_GetFAttr($name, "reading", $1, "Decode"); - $encode = HTTPMOD_GetFAttr($name, "reading", $1, "Encode"); - } else { - Log3 $name, 3, "$name: Read found inconsistant attributes for $a"; - next; + if (AttrVal($name, "extractAllJSON", "") || HTTPMOD_GetFAttr($name, $context, $num, "ExtractAllJSON")) { + # create a reading for each JSON object and use formatting options if a correspondig reading name / formatting is defined + if (ref $hash->{ParserData}{JSON} eq "HASH") { + foreach my $object (keys %{$hash->{ParserData}{JSON}}) { + my $value = $hash->{ParserData}{JSON}{$object}; + my $rname = $object; + my $rnum = 0; + #Log3 $name, 5, "$name: looking at JSON object $object, value $value"; + # is there a defined reading with that JSON path? -> take name and formatting + foreach my $rx (sort grep (/^reading[0-9]+JSON$/, keys %{$attr{$name}})) { + if ($object eq AttrVal($name, $rx, "")) { + # Name und ggf. Formattierung angegeben, nutze sie. + $rx =~ /^reading([0-9]+)JSON$/; + $rnum = $1; + $rname = AttrVal($name, "reading${rnum}Name", ""); + $value = HTTPMOD_FormatReading($name, "reading", $rnum, $value); + } + } + Log3 $name, 5, "$name: Read set JSON $object as reading $rname to value " . $value; + readingsBulkUpdate($hash, $object, $value); + push @matched, $rname; + # unmatched is not filled for "ExtractAllJSON" + delete $hash->{defptr}{readingOutdated}{$object}; } - if (HTTPMOD_ExtractReading($hash, $buffer, $reading, $regex, $expr, $map, $format, $decode, $encode)) { - $matched = ($matched ne "" ? "$matched $reading" : "$reading"); - } else { - $unmatched = ($unmatched ne "" ? "$unmatched $reading" : "$reading"); - } - } - } - if ($type =~ "(Update|Get)") { - if (!$matched) { - readingsBulkUpdate( $hash, "MATCHED_READINGS", "") - if (AttrVal($name, "showMatched", undef)); - Log3 $name, 3, "$name: Read response to $type didn't match any Reading(s)"; } else { - readingsBulkUpdate( $hash, "MATCHED_READINGS", $matched) - if (AttrVal($name, "showMatched", undef)); - Log3 $name, 4, "$name: Read response to $type matched Reading(s) $matched"; - Log3 $name, 4, "$name: Read response to $type did not match $unmatched" if ($unmatched); + Log3 $name, 3, "$name: no parsed JSON structure available"; + } + } elsif ($checkAll && defined($hash->{".readingParseList"})) { + # check all defined readings and try to extract them + + Log3 $name, 5, "$name: Read starts parsing response to $type with defined readings: " . + join (",", @{$hash->{".readingParseList"}}); + foreach $num (@{$hash->{".readingParseList"}}) { + # try to parse readings defined in reading.* attributes + (undef, $match, $reading, @subrlist) = HTTPMOD_ExtractReading($hash, $buffer, 'reading', $num); + if($match) { + push @matched, @subrlist; + } else { + push @unmatched, $reading; + } } } - readingsEndUpdate( $hash, 1 ); + readingsBulkUpdate($hash, "MATCHED_READINGS", join ' ', @matched) + if (AttrVal($name, "showMatched", undef)); + + if (!@matched) { + Log3 $name, 3, "$name: Read response to $type didn't match any Reading"; + } else { + Log3 $name, 4, "$name: Read response to $type matched Reading(s) " . join ' ', @matched; + Log3 $name, 4, "$name: Read response to $type did not match " . join ' ', @unmatched if (@unmatched); + } + + HTTPMOD_TryCall($hash, $buffer, 'parseFunction1', $type); + readingsEndUpdate($hash, 1); + HTTPMOD_TryCall($hash, $buffer, 'parseFunction2', $type); HTTPMOD_HandleSendQueue("direct:".$name); + + HTTPMOD_CleanupParsers($hash); + + # check maxAge for all readings + HTTPMOD_DoMaxAge($hash) if ($hash->{MaxAgeEnabled}); + return undef; } @@ -1050,10 +2151,10 @@ HTTPMOD_HandleSendQueue($) Log3 $name, 3, "$name: HandleSendQueue - init not done, delay sending from queue"; return; } - if ($hash->{BUSY}) { # still waiting for reply to last request - InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); - Log3 $name, 5, "$name: HandleSendQueue - still waiting for reply to last request, delay sending from queue"; - return; + if ($hash->{BUSY}) { # still waiting for reply to last request + InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); + Log3 $name, 5, "$name: HandleSendQueue - still waiting for reply to last request, delay sending from queue"; + return; } $hash->{REQUEST} = $queue->[0]; @@ -1067,33 +2168,66 @@ HTTPMOD_HandleSendQueue($) return; } - $hash->{BUSY} = 1; # HTTPMOD queue is busy until response is received - $hash->{LASTSEND} = $now; # remember when last sent - $hash->{redirects} = 0; - $hash->{callback} = \&HTTPMOD_Read; - $hash->{url} = $hash->{REQUEST}{url}; - $hash->{header} = $hash->{REQUEST}{header}; - $hash->{data} = $hash->{REQUEST}{data}; - $hash->{timeout} = AttrVal($name, "timeout", 2); + # set parameters for HttpUtils from request into hash + $hash->{BUSY} = 1; # HTTPMOD queue is busy until response is received + $hash->{LASTSEND} = $now; # remember when last sent + $hash->{redirects} = 0; + $hash->{callback} = \&HTTPMOD_Read; + $hash->{url} = $hash->{REQUEST}{url}; + $hash->{header} = $hash->{REQUEST}{header}; + $hash->{data} = $hash->{REQUEST}{data}; + $hash->{value} = $hash->{REQUEST}{value}; + $hash->{timeout} = AttrVal($name, "timeout", 2); $hash->{ignoreredirects} = $hash->{REQUEST}{ignoreredirects}; + $hash->{httpversion} = AttrVal($name, "httpVersion", "1.0"); + + my $sslArgList = AttrVal($name, "sslArgs", undef); + if ($sslArgList) { + Log3 $name, 5, "$name: sslArgs is set to $sslArgList"; + my %sslArgs = split (',', $sslArgList); + Log3 $name, 5, "$name: sslArgs hash keys: " . join(",", keys %sslArgs); + Log3 $name, 5, "$name: sslArgs hash values: " . join(",", values %sslArgs); + $hash->{sslargs} = \%sslArgs; + } if (AttrVal($name, "noShutdown", undef)) { $hash->{noshutdown} = 1; } else { delete $hash->{noshutdown}; }; - + + # do user defined replacements first + if ($hash->{ReplacementEnabled}) { + $hash->{header} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{header}); + $hash->{data} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{data}); + $hash->{url} = HTTPMOD_Replace($hash, $hash->{REQUEST}{type}, $hash->{url}); + } + + # then replace $val in header, data and URL with value from request (setVal) if it is still there + $hash->{header} =~ s/\$val/$hash->{value}/g; + $hash->{data} =~ s/\$val/$hash->{value}/g; + $hash->{url} =~ s/\$val/$hash->{value}/g; + + # sid replacement is also done here - just before sending so changes in session while request was queued will be reflected if ($hash->{sid}) { $hash->{header} =~ s/\$sid/$hash->{sid}/g; $hash->{data} =~ s/\$sid/$hash->{sid}/g; $hash->{url} =~ s/\$sid/$hash->{sid}/g; } + Log3 $name, 4, "$name: HandleSendQueue sends request type $hash->{REQUEST}{type} to " . - "URL $hash->{url}, data $hash->{data}, header $hash->{header}, timeout $hash->{timeout}"; + "URL $hash->{url}, " . + ($hash->{data} ? "data $hash->{data}, " : "No Data, ") . + ($hash->{header} ? "header $hash->{header}, " : "No Header, ") . + "timeout $hash->{timeout}"; + + shift(@{$queue}); # remove first element from queue HttpUtils_NonblockingGet($hash); + } else { + shift(@{$queue}); # remove invalid first element from queue } - shift(@{$queue}); # remove first element from queue + if(@{$queue} > 0) { # more items in queue -> schedule next handle InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); } @@ -1104,10 +2238,11 @@ HTTPMOD_HandleSendQueue($) ##################################### sub -HTTPMOD_AddToQueue($$$$$;$$$){ - my ($hash, $url, $header, $data, $type, $count, $ignoreredirects, $prio) = @_; +HTTPMOD_AddToQueue($$$$$;$$$$){ + my ($hash, $url, $header, $data, $type, $value, $count, $ignoreredirects, $prio) = @_; my $name = $hash->{NAME}; + $value = 0 if (!$value); $count = 0 if (!$count); $ignoreredirects = 0 if (!$ignoreredirects); @@ -1116,18 +2251,23 @@ HTTPMOD_AddToQueue($$$$$;$$$){ $request{header} = $header; $request{data} = $data; $request{type} = $type; + $request{value} = $value; $request{retryCount} = $count; $request{ignoreredirects} = $ignoreredirects; my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0); - Log3 $name, 5, "$name: AddToQueue called, initial send queue length : $qlen"; - Log3 $name, 5, "$name: AddToQueue adds type $request{type} to " . - "URL $request{url}, data $request{data}, header $request{header}"; + Log3 $name, 5, "$name: AddToQueue called, initial send queue length : $qlen" . ($prio ? " prio" : ""); + Log3 $name, 5, "$name: AddToQueue " . ($prio ? "prepends " : "adds ") . + "type $request{type} to " . + "URL $request{url}, " . + ($request{data} ? "data $request{data}, " : "no data, ") . + ($request{header} ? "header $request{header}, " : "no headers, ") . + "retry $count"; if(!$qlen) { $hash->{QUEUE} = [ \%request ]; } else { if ($qlen > AttrVal($name, "queueMax", 20)) { - Log3 $name, 3, "$name: AddToQueue - send queue too long, dropping request"; + Log3 $name, 3, "$name: AddToQueue - send queue too long ($qlen), dropping request ($type), BUSY = $hash->{BUSY}"; } else { if ($prio) { unshift (@{$hash->{QUEUE}}, \%request); # an den Anfang @@ -1136,12 +2276,11 @@ HTTPMOD_AddToQueue($$$$$;$$$){ } } } - HTTPMOD_HandleSendQueue("direct:".$name); + HTTPMOD_HandleSendQueue("direct:".$name) if (!$prio); # if prio is set, wait until all steps are added to the front - Auth will call HandleSendQueue then. } 1; - =pod =begin html @@ -1149,10 +2288,10 @@ HTTPMOD_AddToQueue($$$$$;$$$){

HTTPMOD