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

package require xotcl::trace
package require xotcl::mos::invoker
package require xotcl::mos::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::mos::agentManagement
package require xotcl::rdf::tripleRecreator

Singleton Place -superclass Invoker -parameter {
  {exportedObjs ""} 
  {startingObj ""}
  {startCommand ""}
  {root $::env(HOME)/public_html}
  {port 8086}
  {host localhost}
  {allowImmigrationHosts ""}
}

Place instproc exportObjs args {
  foreach obj $args {
    [self] lappend exportedObjs [string trimleft $obj :]
  }
} 
Place instproc isExportedObj obj {
  expr {[lsearch [[self] exportedObjs] [string trimleft $obj :]] != -1}
}
Place instproc default {} {
  [self]
}
Place instproc init args {
  # Uwe: "sprachunterstuetzung fuer singeleton: man zwingt die
  #      instanz auf einen namen (wie bspw. httpd)
  Httpd [self]::httpd \
      -port [[self] set port] \
      -root [[self] set root] \
      -httpdWrk Place::HttpdWrk
  #
  # PersistenceMgr object for web entities
  #
  PersistenceMgr [self]::agentPersistenceMgr \
      -persistenceDir [string trimleft [self] :] \
      -persistenceFile agents-[[self] set port]

  AgentMgr [self]::agentMgr 
  RDFCreator [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 [self]::start
  [self] startingObj [self]::start
  Registry [self]::registry
  ErrorMgr [self]::error

  ScriptCreator [self]::scriptCreator -dependencyChecking 0

  [self] 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
  lappend [self]::workerMixins RestrictHTTPMethods::Wrk
}
Class RestrictHTTPMethods::Wrk
RestrictHTTPMethods::Wrk instproc respond {} {
  [self] instvar method 
  [[self] info parent] instvar allowedHTTPMethods
  if {[lsearch $allowedHTTPMethods $method] != -1} {
    return [next]
  } else {
    [self] log Error "Restricted Method $method called"
    [self] replyCode 405
    [self] replyErrorMsg
  }
}

Class Place::HttpdWrk -superclass Httpd::Wrk 

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

Place::HttpdWrk instproc parseParams {o m a call} {
  upvar $o obj $m method $a args 
  ### 
  set decodedCall [url decodeItem $call]
  #[self] showMsg decodedCall=$decodedCall
  if {[regexp {^([^ ]*) ?([^ ]*) ?(.*)$} $decodedCall _ \
	   obj method args]} {
    #foreach a [[self] 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 {} {
  [self] respond-GET;  ### sendMsg inhibits content for method HEAD
}
Place::HttpdWrk instproc respond-GET {} {
  [self] instvar fileName resourceName place
  if {$resourceName == ""} {
    [self] sendMsg [$place default] text/html  ;# kind of index.html
  } elseif {[[self] parseParams obj method arguments $resourceName]} {
    if {![[self] 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} {
	[self] replyCode $status
	[self] replyErrorMsg $response
      } else {
	$obj send [self] $response
      }
    }
  } else {
    [self] set version 1.0
    [self] replyCode 400
    [self] replyErrorMsg [[self] callError "Could not parse: " $resourceName]
  }
}
Place::HttpdWrk instproc respond-POST {} {
  [self] instvar resourceName place
  [self] respond-GET
}


Place::HttpdWrk instproc respond-PUT {} {
  [self] instvar resourceName place data
  #[self] showCall
  
  if {$resourceName != ""} {
    if {[[self] 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>"
	  [self] replyCode 200  
	  [self] sendMsg $immigrateResult text/plain
	} else {
	  [self] set version 1.0
	  [self] replyCode 400
	  [self] replyErrorMsg "Migration failed"
	}
      } else {
	[self] set version 1.0
	[self] replyCode 400
	[self] replyErrorMsg "Migration: object name already in use."
      }
    } else {
      [self] set version 1.0
      [self] replyCode 400 
      [self] replyErrorMsg "Migration call must provide object name"
    }
  } else {
    # return the own place name -> any client can call the place via
    # placename::start !
    [self] sendMsg $place text/plain
  }
}

