extra/mongodb/mmm/mmm.factor

   1 USING: accessors fry io io.encodings.binary io.servers.connection
   2 io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
   3 namespaces prettyprint tools.walker calendar calendar.format
   4 json.writer mongodb.operations.private mongodb.operations ;
   5
   6 IN: mongodb.mmm
   7
   8 SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
   9
  10 GENERIC: dump-message ( message -- )
  11
  12 : check-options ( -- )
  13     mmm-port get [ 27040 mmm-port set ] unless
  14     mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
  15     mmm-server-port get [ 27017 mmm-server-port set ] unless
  16     mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
  17
  18 : read-msg-binary ( -- )
  19     read-int32
  20     [ write-int32 ] keep
  21     4 - read write ;
  22
  23 : read-request-header ( -- msg-stub )
  24     mdb-msg new
  25     read-int32 MSG-HEADER-SIZE - >>length
  26     read-int32 >>req-id
  27     read-int32 >>resp-id
  28     read-int32 >>opcode ;
  29
  30 : read-request ( -- msg-stub binary )
  31     binary [ read-msg-binary ] with-byte-writer
  32     [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
  33
  34 : dump-request ( msg-stub binary -- )
  35     [ mmm-dump-output get ] 2dip
  36     '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
  37
  38 : read-reply ( -- binary )
  39     binary [ read-msg-binary ] with-byte-writer ;
  40
  41 : forward-request-read-reply ( msg-stub binary -- binary )
  42     [ mmm-server get binary ] 2dip
  43     '[ _ opcode>> _ write flush
  44        OP_Query =
  45        [ read-reply ]
  46        [ f ] if ] with-client ;
  47
  48 : dump-reply ( binary -- )
  49     [ mmm-dump-output get ] dip
  50     '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
  51
  52 : message-prefix ( message -- prefix message )
  53     [ now timestamp>http-string ] dip
  54     [ class name>> ] keep
  55     [ "%s: %s" sprintf ] dip ; inline
  56
  57 M: mdb-query-msg dump-message ( message -- )
  58     message-prefix
  59     [ collection>> ] keep
  60     query>> >json
  61     "%s -> %s: %s \n" printf ;
  62
  63 M: mdb-insert-msg dump-message ( message -- )
  64     message-prefix
  65     [ collection>> ] keep
  66     objects>> >json
  67     "%s -> %s : %s \n" printf ;
  68
  69 M: mdb-reply-msg dump-message ( message -- )
  70     message-prefix
  71     [ cursor>> ] keep
  72     [ start#>> ] keep
  73     [ returned#>> ] keep
  74     objects>> >json
  75     "%s -> cursor: %d, start: %d, returned#: %d,  -> %s \n" printf ;
  76
  77 M: mdb-msg dump-message ( message -- )
  78     message-prefix drop "%s \n" printf ;
  79
  80 : forward-reply ( binary -- )
  81     write flush ;
  82
  83 : handle-mmm-connection ( -- )
  84     read-request
  85     [ dump-request ] 2keep
  86     forward-request-read-reply
  87     [ dump-reply ] keep
  88     forward-reply ;
  89
  90 : start-mmm-server ( -- )
  91     output-stream get mmm-dump-output set
  92     <threaded-server> [ mmm-t-srv set ] keep
  93     "127.0.0.1" mmm-port get <inet4> >>insecure
  94     binary >>encoding
  95     [ handle-mmm-connection ] >>handler
  96     start-server* ;
  97
  98 : run-mmm ( -- )
  99     check-options
 100     start-mmm-server ;
 101
 102 MAIN: run-mmm