http/main.st

   1 "
   2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
   3  Understanding is not required. Only obedience.
   4
   5  This program is free software. It comes without any warranty, to
   6  the extent permitted by applicable law. You can redistribute it
   7  and/or modify it under the terms of the Do What The Fuck You Want
   8  To Public License, Version 2, as published by Sam Hocevar. See
   9  http://sam.zoy.org/wtfpl/COPYING for more details.
  10 "
  11 Requires [ httpsvx ahah ]
  12
  13 Package [
  14   HttpClassBrowser
  15 ]
  16
  17
  18 HttpHandler subclass: HttpHandlerFiles
  19 | d2t |
  20 [
  21   ^initialize [
  22     (d2t := Dictionary new);
  23       at: '/js/' put: 'text/javascript';
  24       at: '/css/' put: 'text/css';
  25       .
  26   ]
  27
  28   ^d2t: aReq [
  29     ^d2t at: aReq path ifAbsent: [ nil ]
  30   ]
  31
  32   openFile [
  33     | fl pt |
  34     (fl := req file) isEmpty ifTrue: [ ^nil ].
  35     (pt := self class d2t: req) ifNil: [ ^nil ].
  36     [ 'WANT FILE: ' print. req path print. fl printNl. ' type: ' print. pt printNl. ] runLocked.
  37     (fl := File openRead: (req path from: 2) + fl) opened ifFalse: [ ^nil ].
  38     self set2xx.
  39     self fileType: pt.
  40     ^fl
  41   ]
  42
  43   emitBody [
  44     self set4xx.
  45     self
  46       emit: '<html><body>file not found: <i>';
  47       emit: (req path htmlEscape);
  48       emit: (req file htmlEscape);
  49       emit: '</i></body></html>'.
  50   ]
  51 ]
  52
  53 HttpHandler subclass: HttpHandlerMain [
  54   openFile [
  55     | fl |
  56     (fl := req file) isEmpty ifTrue: [ fl := 'index.html' ].
  57     fl = 'cbr.html' ifTrue: [ ^nil ].
  58     [ 'WANT FILE: ' print. fl printNl ] runLocked.
  59     (fl := File openRead: 'html/' + fl) opened ifFalse: [ ^nil ].
  60     self set2xx.
  61     self fileType: 'text/html'.
  62     ^fl
  63   ]
  64
  65   emitVar: aName skip: aSkipName [
  66     | v |
  67     (aSkipName = 'method' and: [ aName = 'srctext' ]) ifTrue: [ ^self ].
  68     aName = aSkipName ifFalse: [
  69       (v := req var: aName) ifNotNil: [
  70         (aName = 'srctext' or: [ aName = 'sterror' ]) ifTrue: [ v := v toUrl ].
  71         self
  72           emit: '<input type="hidden" name="';
  73           emit: aName htmlEscape;
  74           emit: '" value="';
  75           emit: v htmlEscape;
  76           emit: '" />'.
  77       ]
  78     ]
  79   ]
  80
  81   emitVars: aSkipName [
  82     self
  83       emitVar: 'package' skip: aSkipName;
  84       emitVar: 'class' skip: aSkipName;
  85       emitVar: 'method' skip: aSkipName;
  86       emitVar: 'srctext' skip: aSkipName;
  87       emitVar: 'sterror' skip: aSkipName.
  88   ]
  89
  90   selection: aName collection: aCollection active: aItem [
  91     | is |
  92     self emit: '<form accept-charset="utf-8" method="post" action="" class="column"><div>'.
  93     self emitVars: aName.
  94     self emit: '<select size="10" onchange="submit()" name="'; emit: aName htmlEscape; emit: '">'.
  95     aCollection ifNotNil: [
  96       aCollection do: [:item |
  97         is := item asString htmlEscape.
  98         self emit: '<option value="'; emit: is.
  99         aItem ifNotNil: [ aItem = item ifTrue: [ self emit: '" selected="selected' ]].
 100         self emit: '">'; emit: is; emit: '</option>'.
 101       ].
 102     ].
 103     self emit: '</select></div></form>'.
 104   ]
 105
 106   emitPackages [
 107     | pkgs |
 108     pkgs := List new.
 109     Package packages keysDo: [:obj | pkgs add: obj asString ].
 110     self selection: 'package' collection: (pkgs reverse) active: (req var: #package).
 111   ]
 112
 113   emitClasses [
 114     | pkg clist |
 115     (pkg := req var: #package) ifNotNil: [ pkg := Package find: pkg asSymbol ].
 116     clist := List new.
 117     pkg
 118       ifNil: [
 119         globals do: [:obj | (obj isKindOf: Class) ifTrue: [ obj isMeta ifFalse: [ clist add: obj asString ]]].
 120       ] ifNotNil: [
 121         pkg classes do: [:obj | (obj isKindOf: Class) ifTrue: [ obj isMeta ifFalse: [ clist add: obj asString ]]].
 122       ].
 123     self selection: 'class' collection: (clist reverse) active: (req var: #class).
 124   ]
 125
 126   emitMethods [
 127     | cls mlist |
 128     (cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]].
 129     mlist := List new.
 130     cls ifNotNil: [
 131       cls class methods do: [:mth | mlist add: '^' + (mth name asString) ].
 132       cls methods do: [:mth | mlist add: mth name asString ].
 133     ].
 134     self selection: 'method' collection: (mlist reverse) active: (req var: #method).
 135   ]
 136
 137   emitSource [
 138     | cls mth isMeta |
 139     self
 140       emit: '<form accept-charset="utf-8" method="post" action="" class="definition"><div>';
 141       emitVars: 'srctext';
 142       emit: '<input type="hidden" name="fromtext" value="tan" />';
 143       emit: '<textarea rows="auto" cols="auto" name="srctext" wrap="soft">'.
 144     (mth := req var: #srctext ifAbsent: ['']) = '' ifTrue: [
 145       ((cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]]) ifNotNil: [
 146         (mth := req var: #method) ifNotNil: [
 147           mth firstChar == $^ ifTrue: [ mth := mth from: 2. cls := cls class. isMeta := '^' ] ifFalse: [ isMeta := '' ].
 148           (mth := cls findMethodInAll: mth asSymbol ifAbsent: [ nil ]) ifNotNil: [
 149             self
 150               emit: isMeta;
 151               emit: mth text htmlEscape.
 152           ]
 153         ]
 154       ]
 155     ] ifFalse: [
 156       (req var: #fromtext) ifNil: [ mth := mth fromUrl ].
 157       self emit: mth htmlEscape
 158     ].
 159     self emit: '</textarea><br /><input value="Accept" name="mthaccept" type="submit" class="submit"></div></form>'.
 160   ]
 161
 162   emitError [
 163     | et |
 164     self
 165       emit: '<form accept-charset="utf-8" method="post" action="" class="definition"><div>';
 166       emitVars: 'sterror';
 167       emit: '<input type="hidden" name="fromerror" value="tan" />';
 168       emit: '<textarea rows="auto" cols="auto" name="sterror" wrap="soft" readonly="yes">'.
 169     (et := req var: #sterror) ifNotNil: [
 170       (req var: #fromerror) ifNil: [ et := et fromUrl ].
 171       self emit: et htmlEscape.
 172     ].
 173     self emit: '</textarea></div></form>'.
 174   ]
 175
 176   compileMethod [
 177     | err mth cls p |
 178     req var: #sterror put: ''; var: #fromerror put: true.
 179     (mth := (req var: #srctext ifAbsent: ['']) removeTrailingBlanks) = '' ifTrue: [
 180       req var: #sterror put: 'nothing to accept!'.
 181       ^self
 182     ].
 183     ((cls := req var: #class) ifNotNil: [ cls := globals at: (cls asSymbol) ifAbsent: [ nil ]]) ifNil: [
 184       req var: #sterror put: 'no class selected!'.
 185       ^self
 186     ].
 187     mth := mth reject: [ :c | c isCR ].
 188     "compile and add method"
 189     err := ''.
 190     p := LstCompiler new.
 191     p errorBlock: [ :msg :lineNum |
 192       err := err + 'ERROR near line ' + lineNum asString + ': ' + msg htmlEscape + '\n'.
 193       req var: #sterror put: err.
 194       ^self
 195     ].
 196     p warningBlock: [ :msg :lineNum |
 197       err := err + 'WARNING near line ' + lineNum asString + ': ' + msg htmlEscape + '\n'.
 198     ].
 199     (mth := (cls addMethod: mth withCompiler: p)) ifNotNil: [
 200       err := err + 'method succcesfully compiled.\n'
 201     ].
 202     req var: #sterror put: err.
 203   ]
 204
 205   emitCBR [
 206     self
 207       set2xx;
 208       emit: '<html><head><link rel="stylesheet" type="text/css" href="css/classbrowser.css" /></head><body>';
 209       emitPackages;
 210       emitClasses;
 211       emitMethods;
 212       emitSource.
 213     (req var: #mthaccept) ifNotNil: [ self compileMethod ].
 214     self
 215       emitError;
 216       emit: '</body></html>'.
 217   ]
 218
 219   emitBody [
 220     req file = 'cbr.html' ifTrue: [ ^self emitCBR ].
 221     ^super emitBody
 222   ]
 223 ]
 224
 225
 226 {
 227   HttpHandlerFiles initialize.
 228   HttpDispatcher addHandler: '/' handler: HttpHandlerMain.
 229   HttpDispatcher addHandler: '/js/' handler: HttpHandlerFiles.
 230   HttpDispatcher addHandler: '/css/' handler: HttpHandlerFiles.
 231   HttpDispatcher addHandler: '/q/' handler: HttpHandlerAhah.
 232   (HttpSheduler new) startOn: 6789.
 233 }