1
###########################################################################/**
2
# @RdocClass HttpDaemon
3
#
4
# @title "The HttpDaemon class"
5
#
6
# \description{
7
#  @classhierarchy
8
#
9
#  A minimalistic HTTP daemon (web server) that also preprocesses RSP.
10
# }
11
#
12
# @synopsis
13
#
14
# \arguments{
15
#   \item{...}{Not used.}
16
# }
17
#
18
# \section{Fields and Methods}{
19
#  @allmethods
20
# }
21
#
22
# \details{
23
#  The actual server is written in Tcl such that it runs in a non-blocking
24
#  mode, which means that the R prompt will be available for other things.
25
#  This class is tightly coupled with the source code of the Tcl script.
26
#
27
#  For security reasons, the server only accept connections from the
28
#  local host (127.0.0.1).  This lowers the risk for external computers
29
#  to gain access to the R session.
30
#  This is asserted by the \code{accept_connect} Tcl procedure in
31
#  r-httpd.tcl (located in \code{system("tcl/", package="R.rsp")}).
32
#  If access from other hosts are wanted, then this procedure needs to
33
#  be modified.
34
#
35
#  The Tcl server was written by Steve Uhlers, and later adopted for R by
36
#  Philippe Grosjean and Tom Short (Rpad package author) [1].
37
# }
38
#
39
# @examples "../incl/HttpDaemon.Rex"
40
#
41
# \references{
42
#   [1] Rpad package, Tom Short, 2005.\cr
43
# }
44
#
45
# @author
46
#
47
# @keyword IO
48
# @keyword internal
49
#*/###########################################################################
50
setConstructorS3("HttpDaemon", function(...) {
51 1
  this <- extend(Object(), "HttpDaemon",
52 1
    .debug = FALSE,
53 1
    .count = 0L,
54 1
    .rootPaths = NULL
55
  )
56

57 1
  this$count <- this$count + 1L
58

59
  # Check if another server is already running.
60 1
  if (this$count > 1L) {
61 0
    throw("ERROR: There is already an HttpDaemon running. Sorry, but the current implementation allows only one per R session.")
62
  }
63

64 1
  this
65
})
66

67
setMethodS3("finalize", "HttpDaemon", function(this, ...) {
68 0
  if (isStarted(this))
69 0
    terminate(this)
70 0
  this$count <- this$count - 1L
71
}, protected=TRUE, createGeneric=FALSE)
72

73

74
setMethodS3("getCount", "HttpDaemon", function(static, ...) {
75 1
  as.integer(static$.count)
76
}, protected=TRUE)
77

78

79
setMethodS3("setCount", "HttpDaemon", function(static, count, ...) {
80 1
  static$.count <- as.integer(count)
81
}, protected=TRUE)
82

83

84

85
###########################################################################/**
86
# @RdocMethod as.character
87
#
88
# @title "Returns a short string describing the HTTP daemon"
89
#
90
# \description{
91
#  @get "title".
92
# }
93
#
94
# @synopsis
95
#
96
# \arguments{
97
#   \item{...}{Not used.}
98
# }
99
#
100
# \value{
101
#  Returns a @character string.
102
# }
103
#
104
# @author
105
#
106
# \seealso{
107
#   @seeclass
108
# }
109
#
110
# @keyword IO
111
# @keyword programming
112
#*/###########################################################################
113
setMethodS3("as.character", "HttpDaemon", function(x, ...) {
114
  # To please R CMD check
115 0
  static <- x
116

117 0
  s <- paste(class(static)[1L], ":", sep="")
118 0
  if (isStarted(static)) {
119 0
    s <- paste(s, " HTTP daemon is started.", sep="")
120 0
    s <- paste(s, " Current root paths: ", paste(getRootPaths(static), collapse=";"), ".", sep="")
121 0
    s <- paste(s, " Port: ", getPort(static), ".", sep="")
122 0
    s <- paste(s, " Default filename: ", getDefaultFilenamePattern(static),
123 0
                                                        ".", sep="")
124
  } else {
125 0
    s <- paste(s, " HTTP daemon is not started.", sep="")
126
  }
127 0
  s
128
})
129

130

131

132
#########################################################################/**
133
# @RdocMethod openUrl
134
#
135
# @title "Starts the HTTP daemon and launches the specified URL"
136
#
137
# \description{
138
#  @get "title".
139
# }
140
#
141
# @synopsis
142
#
143
# \arguments{
144
#   \item{url}{The URL to be opened.}
145
#   \item{host}{The host where the HTTP server is running.}
146
#   \item{port}{The port to be used.}
147
#   \item{path}{The path to the document to be opened.}
148
#   \item{...}{Not used.}
149
# }
150
#
151
# \value{
152
#  Returns nothing.
153
# }
154
#
155
# @author
156
#
157
# \seealso{
158
#   Called by for instance @seemethod "startHelp".
159
#   @seeclass
160
# }
161
#
162
# @keyword IO
163
#*/#########################################################################
164
setMethodS3("openUrl", "HttpDaemon", function(static, url=sprintf("http://%s:%d/%s", host, port, path), host="127.0.0.1", port=8074, path="", ...) {
165
  # - - - - - - - g- - - - - - - - - - - - - - - - - - - - - - - - - - - - -
166
  # Validate arguments
167
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
168
  # Argument 'port':
169 0
  port <- Arguments$getInteger(port, range=c(0,65535))
170

171

172
  # Start HTTP server, if not started.
173 0
  if (!isStarted(static)) {
174
    # Start the web server
175 0
    rootPath <- system.file("rsp", package="R.rsp")
176 0
    start(static, rootPath=rootPath, port=port, ...)
177
  }
178

179 0
  if (!is.null(url))
180 0
    browseURL(url)
181
})
182

183

184
#########################################################################/**
185
# @RdocMethod startHelp
186
#
187
# @title "Starts the HTTP daemon and launches the help page"
188
#
189
# \description{
190
#  @get "title".
191
# }
192
#
193
# @synopsis
194
#
195
# \arguments{
196
#   \item{...}{Arguments passed to @seemethod "openUrl".}
197
# }
198
#
199
# \value{
200
#  Returns nothing.
201
# }
202
#
203
# @author
204
#
205
# \seealso{
206
#   @seeclass
207
# }
208
#
209
# @keyword IO
210
#*/#########################################################################
211
setMethodS3("startHelp", "HttpDaemon", function(static, ...) {
212 0
  openUrl(static, path="R/Help/", ...)
213
})
214

215

216

217

218

219

220

221

222
#########################################################################/**
223
# @RdocMethod getConfig
224
#
225
# @title "Retrieves the server's 'config' structure from Tcl"
226
#
227
# \description{
228
#  @get "title".
229
# }
230
#
231
# @synopsis
232
#
233
# \arguments{
234
#   \item{...}{Not used.}
235
# }
236
#
237
# \value{
238
#  Returns a tclArray object.
239
# }
240
#
241
# @author
242
#
243
# \seealso{
244
#   @seeclass
245
# }
246
#
247
# @keyword IO
248
#*/#########################################################################
249
setMethodS3("getConfig", "HttpDaemon", function(static, ...) {
250
  # Load required package
251 0
  requireNamespace("tcltk") || stop("Package not installed/found: tcltk")
252

253 0
  config <- tcltk::as.tclObj("config")
254 0
  class(config) <- c("tclArray", class(config))
255 0
  config
256
}, static=TRUE, protected=TRUE)
257

258

259

260

261

262
#########################################################################/**
263
# @RdocMethod getHttpRequest
264
#
265
# @title "Gets the HTTP request"
266
#
267
# \description{
268
#  @get "title".
269
# }
270
#
271
# @synopsis
272
#
273
# \arguments{
274
#   \item{...}{Not used.}
275
# }
276
#
277
# \value{
278
#  Returns a @see "HttpRequest" object.
279
# }
280
#
281
# @author
282
#
283
# \seealso{
284
#   @seeclass
285
# }
286
#
287
# @keyword IO
288
#*/#########################################################################
289
setMethodS3("getHttpRequest", "HttpDaemon", function(static, ...) {
290
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
291
  # Local functions
292
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
293 0
  getRequestUri <- function(...) {
294 0
    url <- NA
295 0
    tryCatch({
296 0
      url <- as.character(tcltk::tclvalue("url"))
297 0
    }, error = function(ex) {
298
    })
299 0
    url
300
  }
301

302 0
  getData <- function(field=NULL, ...) {
303 0
    data <- tcltk::as.tclObj("data")
304 0
    class(data) <- c("tclArray", class(data))
305 0
    if (is.null(field))
306 0
      return(data)
307 0
    value <- data[[field]]
308 0
    if (is.null(value))
309 0
      return(NULL)
310 0
    value <- tcltk::tclvalue(value)
311 0
    value
312
  }
313

314 0
  getRequestParameters <- function(...) {
315 0
    params <- list()
316 0
    query <- getData("query")
317 0
    if (!is.null(query)) {
318 0
      query <- strsplit(query, split="&", fixed=TRUE)[[1L]]
319 0
      if (length(query) == 0L)
320 0
        return(params)
321

322 0
      query <- strsplit(query, split="=", fixed=TRUE)
323

324 0
      for (kk in seq_along(query)) {
325 0
        pair <- query[[kk]]
326 0
        name <- URLdecode(pair[1L])
327 0
        value <- URLdecode(pair[2L])
328 0
        params[[kk]] <- value
329 0
        names(params)[kk] <- name
330
      }
331
    }
332

333 0
    params
334
  }
335

336 0
  HttpRequest(
337 0
    serverPort    = getPort(static),
338 0
    contextRoot   = getParent(as.character(tcltk::tclvalue("mypath"))),
339 0
    requestUri    = getData("url"),
340 0
    queryString   = getData("query"),
341 0
    remoteAddress = getData("ipaddr"),
342 0
    parameters    = getRequestParameters(static)
343
  )
344
}, static=TRUE)
345

346

347

348

349
#########################################################################/**
350
# @RdocMethod getPort
351
#
352
# @title "Gets the socket port of the HTTP daemon"
353
#
354
# \description{
355
#  @get "title", if started.
356
# }
357
#
358
# @synopsis
359
#
360
# \arguments{
361
#   \item{...}{Not used.}
362
# }
363
#
364
# \value{
365
#  Returns an @integer if started, otherwise @NA.
366
# }
367
#
368
# @author
369
#
370
# \seealso{
371
#   @seeclass
372
# }
373
#
374
# @keyword IO
375
#*/#########################################################################
376
setMethodS3("getPort", "HttpDaemon", function(static, ...) {
377 0
  config <- getConfig(static)
378 0
  as.integer(config$port)
379
}, static=TRUE)
380

381

382

383

384
#########################################################################/**
385
# @RdocMethod getRootPaths
386
#
387
# @title "Gets the root directories of the HTTP daemon"
388
#
389
# \description{
390
#  @get "title".
391
# }
392
#
393
# @synopsis
394
#
395
# \arguments{
396
#   \item{...}{Not used.}
397
# }
398
#
399
# \value{
400
#  Returns a @vector of @character string if started, otherwise @NA.
401
# }
402
#
403
# @author
404
#
405
# \seealso{
406
#   @seemethod setRootPaths
407
#   @seemethod appendRootPaths
408
#   @seeclass
409
# }
410
#
411
# @keyword IO
412
#*/#########################################################################
413
setMethodS3("getRootPaths", "HttpDaemon", function(static, ...) {
414
  # If server is started, updated rootPaths from the servers settings
415 0
  if (isStarted(static)) {
416 0
    paths <- tcltk::tcl("getRootPaths")
417 0
    paths <- as.character(paths)
418 0
    static$.rootPaths <- paths
419
  }
420

421 0
  static$.rootPaths
422
}, static=TRUE)
423

424

425

426

427
#########################################################################/**
428
# @RdocMethod setRootPaths
429
#
430
# @title "Sets a new set of root directories for the HTTP daemon"
431
#
432
# \description{
433
#  @get "title", if started.
434
# }
435
#
436
# @synopsis
437
#
438
# \arguments{
439
#   \item{paths}{A @vector of paths.}
440
#   \item{...}{Not used.}
441
# }
442
#
443
# \value{
444
#  Returns (invisibly) the previously known root directories.
445
# }
446
#
447
# @author
448
#
449
# \seealso{
450
#   @seemethod getRootPaths
451
#   @seemethod appendRootPaths
452
#   @seeclass
453
# }
454
#
455
# @keyword IO
456
#*/#########################################################################
457
setMethodS3("setRootPaths", "HttpDaemon", function(static, paths, ...) {
458 0
  oldPaths <- getRootPaths(static)
459

460
  # Keep only unique paths
461 0
  paths <- unlist(strsplit(paths, split=";", fixed=TRUE), use.names=FALSE)
462 0
  paths <- unique(paths)
463 0
  static$.rootPaths <- paths
464

465
  # If server is started, updated servers settings
466 0
  if (isStarted(static)) {
467 0
    paths <- paste(paths, collapse=";")
468 0
    res <- tcltk::tcl("setRootPaths", paths)
469
  }
470

471 0
  invisible(oldPaths)
472
}, static=TRUE)
473

474

475
## setMethodS3("refreshRootPaths", "HttpDaemon", function(static, ...) {
476
##   # If server is started, updated servers settings
477
##   if (isStarted(static)) {
478
##     paths <- getRootPaths(static)
479
##     paths <- paste(paths, collapse=";")
480
##     res <- tcltk::tcl("setRootPaths", paths)
481
##   }
482
##   invisible(getRootPaths(static))
483
## }, static=TRUE)
484

485

486

487
#########################################################################/**
488
# @RdocMethod appendRootPaths
489
# @aliasmethod insertRootPaths
490
#
491
# @title "Appends and inserts new paths to the list of known root directories"
492
#
493
# \description{
494
#  @get "title", if started.
495
# }
496
#
497
# @synopsis
498
#
499
# \arguments{
500
#   \item{paths}{A @vector of paths.}
501
#   \item{...}{Not used.}
502
# }
503
#
504
# \value{
505
#  Returns (invisibly) the previously known root directories.
506
# }
507
#
508
# @author
509
#
510
# \seealso{
511
#   @seemethod getRootPaths
512
#   @seeclass
513
# }
514
#
515
# @keyword IO
516
#*/#########################################################################
517
setMethodS3("appendRootPaths", "HttpDaemon", function(static, paths, ...) {
518 0
  setRootPaths(static, c(getRootPaths(static), paths), ...)
519
}, static=TRUE)
520

521

522
setMethodS3("insertRootPaths", "HttpDaemon", function(static, paths, ...) {
523 0
  setRootPaths(static, c(paths, getRootPaths(static)), ...)
524
}, static=TRUE)
525

526

527

528

529

530
#########################################################################/**
531
# @RdocMethod getDefaultFilenamePattern
532
#
533
# @title "Gets the default filename pattern to be loaded by the HTTP daemon"
534
#
535
# \description{
536
#  @get "title", if started.
537
# }
538
#
539
# @synopsis
540
#
541
# \arguments{
542
#   \item{...}{Not used.}
543
# }
544
#
545
# \value{
546
#  Returns an @character string if started, otherwise @NA.
547
# }
548
#
549
# @author
550
#
551
# \seealso{
552
#   @seeclass
553
# }
554
#
555
# @keyword IO
556
#*/#########################################################################
557
setMethodS3("getDefaultFilenamePattern", "HttpDaemon", function(static, ...) {
558 0
  config <- getConfig(static)
559 0
  as.character(config$default)
560
}, static=TRUE)
561

562

563

564

565
#########################################################################/**
566
# @RdocMethod isStarted
567
#
568
# @title "Checks if the HTTP daemon is started"
569
#
570
# \description{
571
#  @get "title".
572
# }
573
#
574
# @synopsis
575
#
576
# \arguments{
577
#   \item{...}{Not used.}
578
# }
579
#
580
# \value{
581
#  Returns @TRUE if the server is started, otherwise @FALSE.
582
# }
583
#
584
# @author
585
#
586
# \seealso{
587
#   @seemethod "start" and @seemethod "terminate".
588
#   @seeclass
589
# }
590
#
591
# @keyword IO
592
#*/#########################################################################
593
setMethodS3("isStarted", "HttpDaemon", function(x, ...) {
594
  # To please R CMD check...
595 0
  static <- x
596

597 0
  port <- getPort(static)
598 0
  (length(port) != 0L)
599
}, static=TRUE)
600

601

602

603

604
#########################################################################/**
605
# @RdocMethod sourceTcl
606
#
607
# @title "Loads the Tcl source for the HTTP daemon into R"
608
#
609
# \description{
610
#  @get "title".
611
# }
612
#
613
# @synopsis
614
#
615
# \arguments{
616
#   \item{...}{Not used.}
617
# }
618
#
619
# \value{
620
#  Returns nothing.
621
# }
622
#
623
# @author
624
#
625
# \seealso{
626
#   @seeclass
627
# }
628
#
629
# @keyword IO
630
#*/#########################################################################
631
setMethodS3("sourceTcl", "HttpDaemon", function(static, ...) {
632
  # Load required package
633 0
  requireNamespace("tcltk") || stop("Package not installed/found: tcltk")
634

635 0
  tclPath <- system.file("tcl", package="R.rsp")
636 0
  pathname <- file.path(tclPath, "r-httpd.tcl")
637 0
  if (!isFile(pathname))
638 0
    stop("Tcl source code file not found: ", pathname)
639

640 0
  res <- tcltk::tcl("source", pathname)
641 0
  invisible(res)
642
}, static=TRUE, protected=TRUE)
643

644

645

646

647
#########################################################################/**
648
# @RdocMethod start
649
#
650
# @title "Starts the HTTP daemon"
651
#
652
# \description{
653
#  @get "title".  Currently, only one HTTP daemon can run at each time,
654
#  regardless of port used.
655
# }
656
#
657
# @synopsis
658
#
659
# \arguments{
660
#   \item{rootPaths}{The path(s) to act as the root of the web server file
661
#       system.  Files in parent directories of the root, will not be
662
#       accessible.  If @NULL, the preset paths will be used,
663
#       cf. @seemethod "setRootPaths".}
664
#   \item{port}{The socket port the server listens to.}
665
#   \item{default}{The default filename pattern to be retrieved if
666
#       not specified.}
667
#   \item{...}{Not used.}
668
# }
669

670
#
671
# \value{
672
#  Returns nothing.
673
# }
674
#
675
# @author
676
#
677
# \seealso{
678
#   @seemethod "setRootPaths".
679
#   @seemethod "isStarted".
680
#   @seemethod "terminate".
681
#   @seemethod "restart".
682
#   @seeclass
683
# }
684
#
685
# @keyword IO
686
#*/#########################################################################
687
setMethodS3("start", "HttpDaemon", function(x, rootPaths=NULL, port=8080, default="^index[.](html|.*)$", ...) {
688
  # The R.rsp package needs to be attached in order to make certain
689
  # R functions of R.rsp available to the Tcl HTTP daemon.
690 0
  use("R.rsp", quietly=TRUE)
691

692
  # To please R CMD check...
693 0
  static <- x
694

695
  # Is HTTP daemon already started?
696 0
  if (isStarted(static))
697 0
    stop("HTTP daemon is already started: ", as.character(static))
698

699
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
700
  # Validate arguments
701
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
702
  # Argument 'rootPaths':
703 0
  if (length(rootPaths) > 0L) {
704 0
    rootPaths <- unlist(strsplit(rootPaths, split=";", fixed=TRUE), use.names=FALSE)
705 0
    rootPaths <- unlist(sapply(rootPaths, FUN=function(path) {
706 0
      Arguments$getReadablePathname(path, mustExist=TRUE)
707 0
    }), use.names=FALSE)
708 0
    setRootPaths(static, rootPaths)
709
  } else {
710 0
    rootPaths <- getRootPaths(static)
711
  }
712

713
  # Argument 'port':
714 0
  port <- Arguments$getInteger(port, range=c(0L,65535L))
715

716
  # Argument 'default':
717 0
  default <- Arguments$getCharacter(default, nchar=c(1L,256L))
718

719
  # Source the TCL httpd code
720 0
  sourceTcl(static)
721

722
  # Start the HTTP daemon (the webserver)
723 0
  res <- tcltk::tcl("server", paste(rootPaths, collapse=";"), port, default)
724

725
  # Validate opened port.
726 0
  port <- Arguments$getInteger(tcltk::tclvalue(res), range=c(0L,65535L))
727

728 0
  invisible(port)
729
}, static=TRUE, createGeneric=FALSE)
730

731

732

733

734
#########################################################################/**
735
# @RdocMethod terminate
736
#
737
# @title "Terminates the HTTP daemon"
738
#
739
# \description{
740
#  @get "title".
741
# }
742
#
743
# @synopsis
744
#
745
# \arguments{
746
#   \item{...}{Not used.}
747
# }
748
#
749
# \value{
750
#  Returns nothing.
751
# }
752
#
753
# @author
754
#
755
# \seealso{
756
#   @seemethod "isStarted".
757
#   @seemethod "start".
758
#   @seemethod "restart".
759
#   @seeclass
760
# }
761
#
762
# @keyword IO
763
#*/#########################################################################
764
setMethodS3("terminate", "HttpDaemon", function(static, ...) {
765
  # Is HTTP daemon already started?
766 0
  if (!isStarted(static))
767 0
    stop("HTTP daemon is not started.")
768

769
  # Close the httpd socket.
770 0
  tcltk::.Tcl("close $config(listen)")
771 0
  tcltk::.Tcl("unset config")
772

773 0
  invisible(TRUE)
774
}, static=TRUE)
775

776

777

778

779
#########################################################################/**
780
# @RdocMethod restart
781
#
782
# @title "Restarts the HTTP daemon"
783
#
784
# \description{
785
#  @get "title".
786
# }
787
#
788
# @synopsis
789
#
790
# \arguments{
791
#   \item{...}{Not used.}
792
# }
793
#
794
# \value{
795
#  Returns nothing.
796
# }
797
#
798
# @author
799
#
800
# \seealso{
801
#   @seemethod "isStarted".
802
#   @seemethod "start".
803
#   @seemethod "terminate".
804
#   @seeclass
805
# }
806
#
807
# @keyword IO
808
#*/#########################################################################
809
setMethodS3("restart", "HttpDaemon", function(static, ...) {
810 0
  if (!isStarted(static))
811 0
    throw("HTTP daemon not started.")
812

813 0
  rootPaths <- getRootPaths(static)
814 0
  port <- getPort(static)
815 0
  default <- getDefaultFilenamePattern(static)
816

817 0
  terminate(static, ...)
818

819 0
  start(static, rootPaths=rootPaths, port=port, default=default, ...)
820
}, static=TRUE)
821

822

823

824

825
#########################################################################/**
826
# @RdocMethod writeResponse
827
#
828
# @title "Writes a string to the HTTP output connection"
829
#
830
# \description{
831
#  @get "title".
832
# }
833
#
834
# @synopsis
835
#
836
# \arguments{
837
#   \item{...}{A set of @character strings to be outputted.}
838
# }
839
#
840
# \details{
841
#   \emph{Note: For efficiency, there is no check if the HTTP daemon is
842
#         started or not.}
843
# }
844
#
845
# \value{
846
#  Returns (invisibly) the number of characters written.
847
# }
848
#
849
# @author
850
#
851
# \seealso{
852
#   @seeclass
853
# }
854
#
855
# @keyword IO
856
#*/#########################################################################
857
setMethodS3("writeResponse", "HttpDaemon", function(static, ...) {
858 0
  str <- paste(..., collapse="", sep="")
859

860
  # Nothing to do?
861 0
  if (nchar(str) == 0L) {
862 0
    return(invisible(0L))
863
  }
864

865 0
  if (isTRUE(static$.debug)) {
866 0
    mcat("=========================================================\n")
867 0
    mcat("= BEGIN: Fake HttpDaemon response\n")
868 0
    mcat("=========================================================\n")
869 0
    mcat(str)
870 0
    mcat("=========================================================\n")
871 0
    mcat("= END: Fake HttpDaemon response\n")
872 0
    mcat("=========================================================\n")
873
  } else {
874
    # Escape certain characters, by converting the string to a Tcl string
875
    # and back.
876 0
    str <- as.character(tcltk::tclVar(str))
877

878
    # Write the string to HTTP output connection.
879 0
    tcltk::.Tcl(paste("catch { puts $sock $", str, " }", sep=""))
880
  }
881

882 0
  invisible(nchar(str))
883
})

Read our documentation on viewing source code .

Loading