| # Tcl package providing access to Taverna 2 Server release 1. |
| # This code also works as an executable script. Use it like this: |
| # |
| # tclsh taverna2server.tcl http://host/taverna-server workflow.t2flow \ |
| # input1Name input1.file input2Name input2.file ... |
| # |
| # Dependencies: |
| # Tcl 8.5 |
| # TclOO 0.6.2 |
| # tdom 0.8.2 |
| # base64 2.4.1 |
| # _or_ |
| # Tcl 8.6 |
| # tdom 0.8.2 |
| # |
| # Copyright (c) 2010, The University of Manchester |
| # |
| # $Id$ |
| # |
| |
| if {[package vsatisfies [package require Tcl 8.5] 8.6]} { |
| # Skip requiring features that are built in to 8.6 |
| } else { |
| package require TclOO 0.6.2 |
| package require base64 2.4.1 |
| } |
| package require http |
| package require tdom 0.8.2 |
| |
| namespace eval ::taverna2server { |
| namespace path ::oo |
| variable LogWADL 0 |
| variable SNS "http://ns.taverna.org.uk/2010/xml/server/" |
| variable RNS "http://ns.taverna.org.uk/2010/xml/server/rest/" |
| namespace export service |
| |
| class create RestSupportCore { |
| variable base wadls acceptedmimetypestack |
| constructor baseURL { |
| set base $baseURL |
| my LogWADL $baseURL |
| } |
| |
| method ExtractError {tok} { |
| return [http::code $tok],[http::data $tok] |
| } |
| |
| method OnRedirect {tok location} { |
| upvar 1 url url |
| set url $location |
| set where $location |
| my LogWADL $where |
| if {[string equal -length [string length $base/] $location $base/]} { |
| set where [string range $where [string length $base/] end] |
| return -level 2 [split $where /] |
| } |
| return -level 2 $where |
| } |
| |
| method LogWADL url { |
| variable ::taverna2server::LogWADL |
| if {!$LogWADL} { |
| return;# do nothing |
| } |
| set tok [http::geturl $url?_wadl] |
| set w [http::data $tok] |
| http::cleanup $tok |
| if {![info exist wadls($w)]} { |
| set wadls($w) 1 |
| puts stderr $w |
| } |
| } |
| |
| method PushAcceptedMimeTypes args { |
| lappend acceptedmimetypestack [http::config -accept] |
| http::config -accept [join $args ", "] |
| return |
| } |
| method PopAcceptedMimeTypes {} { |
| set old [lindex $acceptedmimetypestack end] |
| set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1] |
| http::config -accept $old |
| return |
| } |
| |
| method DoRequest {method url {type ""} {value ""}} { |
| for {set reqs 0} {$reqs < 5} {incr reqs} { |
| if {[info exists tok]} { |
| http::cleanup $tok |
| } |
| set tok [http::geturl $url -method $method -type $type \ |
| -query $value] |
| if {[http::ncode $tok] > 399} { |
| set msg [my ExtractError $tok] |
| http::cleanup $tok |
| return -code error $msg |
| } elseif {[http::ncode $tok]>299 || [http::ncode $tok]==201} { |
| set location {} |
| if {[catch { |
| set location [dict get [http::meta $tok] Location] |
| }]} { |
| http::cleanup $tok |
| error "missing a location header!" |
| } |
| my OnRedirect $tok $location |
| } else { |
| set s [http::data $tok] |
| http::cleanup $tok |
| return $s |
| } |
| } |
| error "too many redirections!" |
| } |
| |
| method GET args { |
| return [my DoRequest GET $base/[join $args /]] |
| } |
| |
| method POST {args} { |
| set type [lindex $args end-1] |
| set value [lindex $args end] |
| set path [join [lrange $args 0 end-2] /] |
| return [my DoRequest POST $base/$path $type $value] |
| } |
| |
| method PUT {args} { |
| set type [lindex $args end-1] |
| set value [lindex $args end] |
| set path [join [lrange $args 0 end-2] /] |
| return [my DoRequest PUT $base/$path $type $value] |
| } |
| |
| method DELETE args { |
| return [my DoRequest DELETE $base/[join $args /]] |
| } |
| } |
| |
| class create service { |
| superclass RestSupportCore |
| self { |
| variable service |
| method address= serviceURL { |
| set service $serviceURL |
| } |
| method address {{suffix {}}} { |
| if {$suffix ne ""} { |
| return $service/$suffix |
| } else { |
| return $service |
| } |
| } |
| |
| method SimpleGet path { |
| set tok [http::geturl [my address rest/$path]] |
| set result [http::data $tok] |
| http::cleanup $tok |
| return $result |
| } |
| forward runLimit my SimpleGet policy/runLimit |
| forward permittedWorkflows my SimpleGet policy/permittedWorkflows |
| forward permittedListeners my SimpleGet policy/permittedListeners |
| method runs {} { |
| variable ::taverna2server::RNS |
| dom parse [my SimpleGet runs] doc |
| set result {} |
| foreach run [doc selectNodes -namespaces [list t2sr $RNS] \ |
| "/t2sr:runs/t2sr:run"] { |
| lappend result [$run @xlink:href] |
| } |
| return $result |
| } |
| |
| method withFile {filename as varName do script} { |
| # Verify the sugar |
| if {$as ne "as" || $do ne "do"} { |
| return -code error "syntax error" |
| } |
| upvar 1 $varName var |
| set var [[self] new -file $filename] |
| catch { |
| uplevel 1 $script |
| } msg opt |
| $var destroy |
| return -options $opt $msg |
| } |
| } |
| variable SNS RNS created |
| constructor {op arg} { |
| set created 0 |
| my eval {namespace upvar ::taverna2server SNS SNS RNS RNS} |
| |
| if {$op eq "-file"} { |
| set f [open $arg] |
| set t2flow [read $f] |
| close $f |
| } elseif {$op eq "-id"} { |
| next [[self class] address rest/runs/$arg] |
| return |
| } else { |
| return -code error "unknown operation: must be -file or -id" |
| } |
| |
| dom parse $t2flow workflow |
| set contents [[$workflow documentElement] asList] |
| dom createDocumentNS $SNS workflow wrapped |
| [$wrapped documentElement] appendFromList $contents |
| |
| set tok [http::geturl [[self class] address rest/runs] \ |
| -type application/xml -query [$wrapped asXML]] |
| if {[http::ncode $tok] > 399} { |
| set msg [my ExtractError $tok] |
| http::cleanup $tok |
| return -code error $msg |
| } elseif {[http::ncode $tok] < 300 && [http::ncode $tok] != 201} { |
| http::cleanup $tok |
| return -code error "unexpected OK" |
| } |
| next [dict get [http::meta $tok] Location] |
| set created 1 |
| http::cleanup $tok |
| } |
| destructor { |
| if {$created && [catch {my DELETE} msg]} { |
| puts stderr "WARNING: $msg" |
| } |
| } |
| |
| method status {{status ""}} { |
| if {$status eq ""} { |
| return [my GET status] |
| } else { |
| return [my PUT status text/plain $status] |
| } |
| } |
| |
| method executeSynchronously {} { |
| if {[my status] eq "Initialized"} { |
| my status Operating |
| } |
| while {[my status] eq "Operating"} { |
| after 1000 |
| } |
| } |
| |
| method expiry {{expiry ""}} { |
| if {$expiry eq ""} { |
| set t [my GET expiry] |
| } else { |
| set t [my PUT expiry text/plain $expiry] |
| } |
| clock scan $t -format %Y-%m-%dT%H:%M:%S%z |
| } |
| |
| method createTime {} { |
| clock scan [my GET createTime] -format %Y-%m-%dT%H:%M:%S%z |
| } |
| method startTime {} { |
| set t [my GET startTime] |
| if {$t eq ""} return |
| clock scan $t -format %Y-%m-%dT%H:%M:%S%z |
| } |
| method finishTime {} { |
| set t [my GET finishTime] |
| if {$t eq ""} return |
| clock scan $t -format %Y-%m-%dT%H:%M:%S%z |
| } |
| |
| method property {listener property {value ""}} { |
| if {[llength [info level 0]] == 4} { |
| my GET listeners $listener properties $property |
| } else { |
| my PUT listeners $listener properties $property text/plain $value |
| } |
| } |
| |
| method input {port file|value literal} { |
| switch ${file|value} { |
| file - value { |
| # OK |
| } |
| default { |
| return -code error "unknown input type" |
| } |
| } |
| dom createDocumentNS $RNS runInput valuedoc |
| set v [$valuedoc createElementNS $RNS ${file|value}] |
| $v appendChild [$valuedoc createTextNode $literal] |
| [$valuedoc documentElement] appendChild $v |
| my PUT input input $port application/xml [$valuedoc asXML] |
| return |
| } |
| |
| method inputs file { |
| my PUT input baclava text/plain $file |
| return |
| } |
| |
| method outputs file { |
| my PUT output text/plain $file |
| } |
| |
| method ls {{base ""}} { |
| my PushAcceptedMimeTypes application/xml |
| set code [catch { |
| my GET wd $base |
| } result opt] |
| my PopAcceptedMimeTypes |
| if {$code} { |
| return -options $opt $result |
| } |
| |
| set items {} |
| dom parse $result doc |
| set nsmap [list ts2 $SNS t2sr $RNS] |
| foreach dir [$doc selectNodes -namespaces $nsmap \ |
| "t2sr:directoryContents/t2s:dir"] { |
| lappend items [$dir @name]/ |
| } |
| foreach file [$doc selectNodes -namespaces $nsmap \ |
| "t2sr:directoryContents/t2s:file"] { |
| lappend items [$file @name] |
| } |
| return $items |
| } |
| |
| method get file { |
| my PushAcceptedMimeTypes application/octet-stream |
| set out [my GET wd $file] |
| my PopAcceptedMimeTypes |
| return $out |
| } |
| |
| # Helper for file operations |
| method FileOp {op name {content ""}} { |
| dom createDocumentNS $RNS $op doc |
| set element [$doc documentElement] |
| $element setAttributeNS "" xmlns:t2sr $RNS |
| $element setAttributeNS $RNS t2sr:name $name |
| if {[llength [info level 0]] == 5} { |
| if {[info tclversion] eq "8.5"} { |
| $element appendChild [$doc createTextNode \ |
| [base64::encode $content]] |
| } else { |
| $element appendChild [$doc createTextNode \ |
| [binary encode base64 $content]] |
| } |
| } |
| return [$doc asXML] |
| } |
| |
| method put {fileName contents} { |
| set path [file split $fileName] |
| #### <t2sr:upload t2sr:name="..."> base64data </t2sr:upload> |
| set message [my FileOp upload [lindex $path end] $contents] |
| return [join [lrange [my POST wd {*}[lrange $path 0 end-1] \ |
| application/xml $message] 1 end] "/"] |
| } |
| |
| method mkdir {dirName} { |
| set path [file split $dirName] |
| #### <t2sr:mkdir t2sr:name="..."/> |
| set message [my FileOp mkdir [lindex $path end]] |
| return [join [lrange [my POST wd {*}[lrange $path 0 end-1] \ |
| application/xml $message] 1 end] "/"] |
| } |
| } |
| } |
| |
| package provide taverna2server 1.0 |
| |
| # Demonstration code |
| if {[info script] ne $::argv0} { |
| return |
| } |
| |
| namespace eval sample-code { |
| proc ReadBinaryFile filename { |
| set f [open $filename] |
| fconfigure $f -translation binary |
| set data [read $f] |
| close $f |
| return $data |
| } |
| proc WriteBinaryFile {filename data} { |
| set f [open $filename w] |
| fconfigure $f -translation binary |
| puts -nonewline $f $data |
| close $f |
| } |
| |
| namespace import taverna2server::service |
| service address= [lindex $argv 0] |
| service withFile [lindex $argv 1] as run do { |
| $run mkdir in |
| foreach {name filename} [lrange $argv 2 end] { |
| # Upload the file to a synthetic name |
| $run input $name file [$run put in/f[incr i] \ |
| [ReadBinaryFile $filename]] |
| } |
| $run executeSynchronously |
| puts STDOUT:\t[$run property io stdout] |
| puts STDERR:\t[$run property io stderr] |
| puts EXIT:\t[$run property io exitcode] |
| foreach filename [$run ls out] { |
| puts FILE:\t$filename |
| # Ignore subdirectories |
| if {[string match */ $filename]} continue |
| # Download the file |
| WriteBinaryfile [file tail $filename] [$run get out/$filename] |
| } |
| } |
| } |
| |
| return |
| |
| # Local Variables: |
| # mode: tcl |
| # indent-tabs-mode: nil |
| # End: |