######################################################################### # $Id$ # fhem Modul für Geräte mit Web-Oberfläche # # This file is part of fhem. # # Fhem is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 2 of the License, or # (at your option) any later version. # # Fhem is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with fhem. If not, see . # ############################################################################## # Changelog: # # 2013-12-25 initial version # 2013-12-29 modified to use non blocking HTTP # 2014-1-1 modified to use attr instead of set to define internal parameters # 2014-1-6 extended error handling and added documentation # 2014-1-15 added readingsExpr to allow some computation on raw values before put in readings # 2014-3-13 added noShutdown and disable attributes # 2014-4-8 fixed noShutdown check # 2014-4-9 added Attribute timeout as suggested by Frank # 2014-10-22 added generic set function, alternative naming of old attributes, ... # 2014-11-17 added queueing for requests, fixed timeout # 2014-11-30 fixed race condition, added ignoreRedirects # an neues HttpUtils angepasst # 2014-12-05 definierte Attribute werden zu userattr der Instanz hinzugefügt # use $hash->{HTTPHEADER} or $hash->{httpheader} # 2014-12-22 Warnung in Set korrigiert # 2015-02-11 added attributes for a generic get feature, new get function, attributes "map" for readings, # modified the map attributes handling so it works with strings containing blanks # and splits at ", " or ":" # 2015-02-15 attribute to select readings per get # 2015-02-17 new attributes getXXRegex, Map, Format, Expr, new semantics for default values of these attributes # restructured HTTPMOD_Read # 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. # 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 # Profiling von Modbus übernehmen? # # extend httpmod to support simple tcp connections aver devio instead of HttpUtils # extend devio for non blocking connect like httputils # # package main; use strict; use warnings; use Time::HiRes qw(gettimeofday); use Encode qw(decode encode); use HttpUtils; sub HTTPMOD_Initialize($); sub HTTPMOD_Define($$); sub HTTPMOD_Undef($$); sub HTTPMOD_Set($@); sub HTTPMOD_Get($@); sub HTTPMOD_Attr(@); sub HTTPMOD_GetUpdate($); sub HTTPMOD_Read($$$); sub HTTPMOD_AddToQueue($$$$$;$$$$); sub HTTPMOD_JsonFlatter($$;$); sub HTTPMOD_ExtractReading($$$$); # # FHEM module intitialisation # defines the functions to be called from FHEM ######################################################################### sub HTTPMOD_Initialize($) { my ($hash) = @_; $hash->{DefFn} = "HTTPMOD_Define"; $hash->{UndefFn} = "HTTPMOD_Undef"; $hash->{SetFn} = "HTTPMOD_Set"; $hash->{GetFn} = "HTTPMOD_Get"; $hash->{AttrFn} = "HTTPMOD_Attr"; $hash->{AttrList} = "(reading|get|set)[0-9]+(-[0-9]+)?Name " . "(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.* " . "noShutdown:0,1 " . "httpVersion " . "sslVersion " . "sslArgs " . "timeout " . "queueDelay " . "queueMax " . "minSendDelay " . "showMatched:0,1 " . "showError:0,1 " . "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 " . "[gs]et[0-9]*URLExpr " . # old "[gs]et[0-9]*DatExpr " . # old "[gs]et[0-9]*HdrExpr " . # old "get[0-9]+Poll:0,1 " . "get[0-9]+PollDelay " . "get[0-9]*PullToFile " . "get[0-9]*PullIterate " . "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 " . "enableCookies:0,1 " . "enableXPath:0,1 " . # old "enableXPath-Strict:0,1 " . # old $readingFnAttributes; } # # Define command # init internal values, # set internal timer get Updates ######################################################################### sub HTTPMOD_Define($$) { my ($hash, $def) = @_; my @a = split( "[ \t]+", $def ); return "wrong syntax: define HTTPMOD URL interval" if ( @a < 3 ); my $name = $a[0]; if ($a[2] eq "none") { Log3 $name, 3, "$name: URL is none, no periodic updates will be limited to explicit GetXXPoll attribues (if defined)"; $hash->{MainURL} = ""; } else { $hash->{MainURL} = $a[2]; } if(int(@a) > 3) { # interval specified if ($a[3] > 0) { if ($a[3] >= 5) { $hash->{Interval} = $a[3]; } else { return "interval too small, please use something > 5, default is 300"; } } else { Log3 $name, 3, "$name: interval is 0, no periodic updates will done."; $hash->{Interval} = 0; } } else { # default if no interval specified $hash->{Interval} = 300; } 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 if ($hash->{MainURL} && $hash->{Interval}) { my $firstTrigger = gettimeofday() + 2; $hash->{TRIGGERTIME} = $firstTrigger; $hash->{TRIGGERTIME_FMT} = FmtDateTime($firstTrigger); RemoveInternalTimer("update:$name"); 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_FMT} = ""; } $hash->{".getList"} = ""; $hash->{".setList"} = ""; return undef; } # # undefine command when device is deleted ######################################################################### sub HTTPMOD_Undef($$) { my ($hash, $arg) = @_; my $name = $hash->{NAME}; RemoveInternalTimer ("timeout:$name"); RemoveInternalTimer ("queue:$name"); RemoveInternalTimer ("update:$name"); return 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(@) { my ($cmd,$name,$aName,$aVal) = @_; 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 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 ($@) { Log3 $name, 3, "$name: Attr with invalid regex in attr $name $aName $aVal: $@"; return "Invalid Regex $aVal"; } 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"; } 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 =~ /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"; } } } 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]+).+/) { $steps{$1} = 1; } } Log3 $name, 4, "$name: Auth called with Steps: " . join (" ", sort keys %steps); $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) { # 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 Auth $step"; } } HTTPMOD_HandleSendQueue("direct:".$name); # AddToQueue with prio did not call this. return undef; } # create hint list for set / get ? ######################################## sub HTTPMOD_UpdateHintList($) { my ($hash, $context) = @_; my $name = $hash->{NAME}; 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 { $hash->{".setList"} = ""; } 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 } # # SET command ######################################################################### sub HTTPMOD_Set($@) { my ($hash, @a) = @_; return "\"set HTTPMOD\" needs at least an argument" if (@a < 2); # @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 "?"); return undef; } Log3 $name, 5, "$name: set called with $setName " . ($setVal ? $setVal : "") if ($setName ne "?"); if (AttrVal($name, "enableControlSet", undef)) { # spezielle Sets freigeschaltet? 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 } # Vorbereitung: # 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" ? 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)) { 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"; if (!AttrVal($name, "set${setNum}NoArg", undef)) { # soll überhaupt ein Wert übergeben werden? if (!defined($setVal)) { # Ist ein Wert übergeben? Log3 $name, 3, "$name: set without value given for $setName"; return "no value given to set $setName"; } # Eingabevalidierung von Sets mit Definition per Attributen # 1. Schritt, falls definiert, per Umkehrung der Map umwandeln (z.B. Text in numerische Codes) 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"; } else { Log3 $name, 3, "$name: set value $setVal did not match defined map"; return "set value $setVal did not match defined map"; } } else { # wenn keine map, dann wenigstens sicherstellen, dass Wert numerisch - falls nicht TextArg. if (!AttrVal($name, "set${setNum}TextArg", undef)) { if ($setVal !~ /^-?\d+\.?\d*$/) { Log3 $name, 3, "$name: set - value $setVal is not numeric"; return "set value $setVal is not numeric"; } } $rawVal = $setVal; } # kein TextArg? if (!AttrVal($name, "set${setNum}TextArg", undef)) { # 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"; return "set value $rawVal is bigger than Max ($max)" if ($rawVal > $max); } } # 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; $rawVal = eval($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"; } else { # NoArg $rawVal = 0; Log3 $name, 4, "$name: set will now set $setName"; } my ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "set", $setNum); if ($url) { HTTPMOD_AddToQueue($hash, $url, $header, $data, "set$setNum", $rawVal); } else { Log3 $name, 3, "$name: no URL for set $setNum"; } return undef; } # # GET command ######################################################################### sub HTTPMOD_Get($@) { my ($hash, @a) = @_; return "\"get HTTPMOD\" needs at least an argument" if ( @a < 2 ); # @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 "?"); # 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" ? if ($getName eq $attr{$name}{$aName}) { # ist es der im konkreten get verwendete getName? $getNum = $1; # gefunden -> merke Nummer X im Attribut } } } # gültiger get Aufruf? ($getNum oben schon gesetzt?) if(!defined ($getNum)) { 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" . ($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"; } 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 $hash = $defs{$name}; 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}; $hash->{TRIGGERTIME} = $nt; $hash->{TRIGGERTIME_FMT} = FmtDateTime($nt); InternalTimer($nt, "HTTPMOD_GetUpdate", "update:$name", 0); Log3 $name, 5, "$name: internal interval timer set to call GetUpdate again in " . int($hash->{Interval}). " seconds"; } if (AttrVal($name, "disable", undef)) { Log3 $name, 5, "$name: GetUpdate called but device is disabled"; return undef; } 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, "update"); # use request type "update" } else { Log3 $name, 3, "$name: GetUpdate: no Main URL specified"; } } # check if additional readings with individual URLs need to be requested foreach my $poll (sort grep (/^get[0-9]+Poll$/, keys %{$attr{$name}})) { $poll =~ /^get([0-9]+)Poll$/; next if (!$1); my $getNum = $1; my $getName = AttrVal($name, "get".$getNum."Name", ""); if ($getName) { Log3 $name, 5, "$name: GetUpdate checks if poll required for $getName ($getNum)"; my $lastPoll = 0; $lastPoll = $hash->{lastpoll}{$getName} if ($hash->{lastpoll} && $hash->{lastpoll}{$getName}); my $dueTime = $lastPoll + AttrVal($name, "get".$getNum."PollDelay", 0); if ($now >= $dueTime) { Log3 $name, 5, "$name: GetUpdate will request $getName"; $hash->{lastpoll}{$getName} = $now; ($url, $header, $data) = HTTPMOD_PrepareRequest($hash, "get", $getNum); if ($url) { HTTPMOD_AddToQueue($hash, $url, $header, $data, "get$getNum"); } else { 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"; } } } # Try to call a parse function if defined ######################################### sub HTTPMOD_TryCall($$$$) { my ($hash, $buffer, $fName, $type) = @_; my $name = $hash->{NAME}; 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"; } } # 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 { 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 ($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 ($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 # - callback for non blocking HTTP ################################### sub HTTPMOD_Read($$$) { 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; 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"); my $buffer = ($header ? $header . "\r\n\r\n" . $body : $body); # so header can be used to match e.g. sid if ($err) { $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)) } HTTPMOD_UpdateReadingList($hash) if ($hash->{".updateReadingList"}); HTTPMOD_GetCookies($hash, $header) if (AttrVal($name, "enableCookies", 0)); HTTPMOD_InitParsers($hash, $body); if ($context eq "sid") { HTTPMOD_ExtractSid($hash, $buffer, $context, $num); } else { $authQueued = HTTPMOD_CheckAuth($hash, $body, $request, $context, $num); } 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 ($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 { ($tried, $match, $reading, @subrlist) = HTTPMOD_ExtractReading($hash, $buffer, $context, $num); } if ($tried) { if($match) { push @matched, @subrlist; } else { 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 (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}; } } else { 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; } } } 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; } ####################################### # Aufruf aus InternalTimer mit "queue:$name" # oder direkt mit $direct:$name sub HTTPMOD_HandleSendQueue($) { my (undef,$name) = split(':', $_[0]); my $hash = $defs{$name}; my $queue = $hash->{QUEUE}; my $qlen = ($hash->{QUEUE} ? scalar(@{$hash->{QUEUE}}) : 0); Log3 $name, 5, "$name: HandleSendQueue called, qlen = $qlen"; RemoveInternalTimer ("queue:$name"); if(defined($queue) && @{$queue} > 0) { my $queueDelay = AttrVal($name, "queueDelay", 1); my $now = gettimeofday(); if (!$init_done) { # fhem not initialized, wait with IO InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); 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; } $hash->{REQUEST} = $queue->[0]; if($hash->{REQUEST}{url} ne "") { # if something to send - check min delay and send my $minSendDelay = AttrVal($hash->{NAME}, "minSendDelay", 0.2); if ($hash->{LASTSEND} && $now < $hash->{LASTSEND} + $minSendDelay) { InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); Log3 $name, 5, "$name: HandleSendQueue - minSendDelay not over, rescheduling"; return; } # 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}, " . ($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 } if(@{$queue} > 0) { # more items in queue -> schedule next handle InternalTimer($now+$queueDelay, "HTTPMOD_HandleSendQueue", "queue:$name", 0); } } } ##################################### sub 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); my %request; $request{url} = $url; $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" . ($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 ($qlen), dropping request ($type), BUSY = $hash->{BUSY}"; } else { if ($prio) { unshift (@{$hash->{QUEUE}}, \%request); # an den Anfang } else { push(@{$hash->{QUEUE}}, \%request); # ans Ende } } } 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

HTTPMOD

=end html =cut