# $Id: s.HttpPlace.xotcl 1.23 01/04/18 21:24:34+02:00 neumann@mohegan.wu-wien.ac.at $
package provide xotcl::actiweb::httpPlace 0.8

package require xotcl::trace
package require xotcl::actiweb::invoker
package require xotcl::actiweb::webObject
package require xotcl::comm::httpd
package require xotcl::scriptCreation::scriptCreator
package require xotcl::store::persistence
package require xotcl::pattern::singleton
package require xotcl::registry::registry
package require xotcl::actiweb::agentManagement
package require xotcl::rdf::tripleRecreator

Singleton Place -superclass Invoker -parameter {
  {exportedObjs ""} 
  {startingObj ""}
  {startCommand ""}
  {root $::env(HOME)/public_html}
  {port 8086}
  {redirect [list]}
  {logdir $::xotcl::logdir} 
  {host localhost}
  {allowImmigrationHosts ""}
  persistenceFile persistenceDir bccFile bccDir dbPackage
  {startHTTPServer 1}
}

#    Giving a bccFile (and possibly bccDir) as optional parameter means 
#    that an identical copy database will be created in that 
#    location (e.g. for creating a backup on a second hard drive.

Place instproc exportObjs args {
  foreach obj $args {
    my lappend exportedObjs [string trimleft $obj :]
    puts stderr "*** exporting $obj, self=[self], objs=[my set exportedObjs]"
  }
} 
Place instproc isExportedObj obj {
  expr {[lsearch [my exportedObjs] [string trimleft $obj :]] != -1}
}
Place instproc default {} {
  [self]
}
Place instproc init args {
  if {[my set startHTTPServer]} {
	Httpd [self]::httpd \
	    -port [my port] \
	    -root [my root] \
	    -redirect [my redirect] \
	    -logdir [my logdir] \
	    -httpdWrk Place::HttpdWrk
  }
  #
  # PersistenceMgr object for web entities
  #
  ##### so ist das nicht toll ... init args sollten anders konfigurierbar sein
  PersistenceMgr [self]::agentPersistenceMgr -dbPackage multi

  if {[my exists dbPackage]} {
    set dbp [my set dbPackage]
  } else {
    set dbp ""
  }


  if {![my exists persistenceDir]} {
    my persistenceDir [string trimleft [self] :]
  }
  if {![my exists persistenceFile]} {
    my persistenceFile persistentObjs-[my port]
  }

  [self]::agentPersistenceMgr store add $dbp \
      -dirName [my persistenceDir] \
      -fileName [my persistenceFile]

  if {[my exists bccDir] || [my exists bccFile]} {
    if {![my exists bccDir]} {
      my bccDir [my set persistenceDir]
    }
    if {![my exists bccFile]} {
      my bccFile [my persistenceFile]
    }
    [self]::agentPersistenceMgr store add $dbp \
	-dirName [my bccDir] \
	-fileName [my bccFile]
  }

  AgentMgr create [self]::agentMgr 
  RDFCreator create [self]::rdfCreator

  #
  # minimal obj for default behavior of the place -> calls go
  # to web entities default (customize through a redirecting proc
  # as in HtmlPlace or changing startingObj)
  #
  WebObject create [self]::start
  my startingObj [self]::start
  Registry [self]::registry
  ErrorMgr [self]::error

  ScriptCreator [self]::scriptCreator -dependencyChecking 0

  my exportObjs [self]::start [self]::agentMgr [self]::registry
  next
}

Place instproc startEventLoop args {
  if {[llength $args] > 0} {
    set startCommand [lindex $args 0]
    ::eval $startCommand
  }

  vwait forever  ;# if we are in xotclsh call the event loop...
}

###
### Mixin-Classes for Http/Wrk that restricts the usable HTTP methods
###
Class RestrictHTTPMethods -parameter {
  {allowedHTTPMethods "GET PUT HEAD POST CGI"}
}
RestrictHTTPMethods instproc init args {
  next
  my lappend workerMixins RestrictHTTPMethods::Wrk
}
Class RestrictHTTPMethods::Wrk
RestrictHTTPMethods::Wrk instproc respond {} {
  my instvar method 
  [my info parent] instvar allowedHTTPMethods
  if {[lsearch $allowedHTTPMethods $method] != -1} {
    return [next]
  } else {
    my log Error "Restricted Method $method called"
    my replyCode 405
    my replyErrorMsg
  }
}

Class Place::HttpdWrk -superclass Httpd::Wrk 

Place::HttpdWrk instproc init args {
  my set place [Place getInstance] 
  next
  #puts "New Http-Worker: [self class]->[self] on [my set place]" 
} 

Place::HttpdWrk instproc parseParams {o m a call} {
  upvar [self callinglevel] $o obj $m method $a args 
  ### 
  set decodedCall [url decodeItem $call]
  #my showMsg decodedCall=$decodedCall
  if {[regexp {^([^ ]*) ?([^ ]*) ?(.*)$} $decodedCall _ \
	   obj method args]} {
    #foreach a [my set formData] {lappend args [$a set content]}
    #puts stderr "Parsed -- Obj: $obj, Method: $method, Args: $args" 
    return 1
  } else {
    puts stderr "could not parse <$decodedCall>"
    return 0
  }
}
Place::HttpdWrk instproc respond-HEAD {} {
  my respond-GET;  ### sendMsg inhibits content for method HEAD
}
Place::HttpdWrk instproc respond-GET {} {
  my instvar fileName resourceName place
  if {$resourceName == ""} {
    my sendMsg [$place default] text/html  ;# kind of index.html
  } elseif {[my parseParams obj method arguments $resourceName]} {
    if {![my isobject $obj] && [file readable $fileName]} {
      next      ;# let Httpd handle this
    } else {
      set response [$place invokeCall obj status $method $arguments]
      #puts stderr "RESPONSE: $response"
      #
      # let the object's sending strategy mixin choose 
      # the appropriate sending mode
      #
      # $obj showClass
      if {[info exists status] && $status >= 300} {
	my replyCode $status
	my replyErrorMsg $response
      } else {
	#my lappend replyHeaderFields Cache-Control maxage=0
	my lappend replyHeaderFields Pragma no-cache
	$obj send [self] $response
      }
    }
  } else {
    my set version 1.0
    my replyCode 400
    my replyErrorMsg [my callError "Could not parse: " $resourceName]
  }
}
Place::HttpdWrk instproc respond-POST {} {
  my instvar resourceName place
  my respond-GET
}


Place::HttpdWrk instproc respond-PUT {} {
  my instvar resourceName place data
  #my showCall
  
  if {$resourceName != ""} {
    if {[my parseParams obj m a $resourceName]} {
      set obj [string trimleft $obj :]
      set AMgr ${place}::agentMgr

      if {[info commands $obj] == "" &&
	  ![$AMgr info agents $obj]} {
	#puts stderr "Receiving to put --------------------------------$obj  $data"
	set AI [$AMgr parseData $obj $data]
	#puts stderr "parray --${AI}::agentData------------------------"
	#parray ${AI}::agentData
	#puts stderr "parray --${AI}::agentData----------------DONE--------"
	#$AI showVars
	#puts stderr "----[$AI exists agentData(agent:script)]----"
	if {[$AI exists agentData(agent:script)]} {
	  set immigrateResult [$AMgr immigrate $AI]
	  #puts stderr "immigrateResult=<$immigrateResult>"
	  my replyCode 200  
	  my sendMsg $immigrateResult text/plain
	} else {
	  my set version 1.0
	  my replyCode 400
	  my replyErrorMsg "Migration failed"
	}
      } else {
	my set version 1.0
	my replyCode 400
	my replyErrorMsg "Migration: object name already in use."
      }
    } else {
      my set version 1.0
      my replyCode 400 
      my replyErrorMsg "Migration call must provide object name"
    }
  } else {
    # return the own place name -> any client can call the place via
    # placename::start !
    my sendMsg $place text/plain
  }
}

