Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 5cba00e9e6
Fetching contributors…

Cannot retrieve contributors at this time

file 132 lines (121 sloc) 4.528 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
(*
* (c) 2004-2010 Anastasia Gornostaeva. <ermine@ermine.pp.ru>
*)

open XMPP
open JID
open StanzaError
open Common
open Hooks

let get_host = function
  | EntityMe jid
  | EntityYou jid
  | EntityHost jid
  | EntityUser (_, jid) ->
      jid.domain
      
let process_error error env entity =
  match error.err_condition with
    | ERR_FEATURE_NOT_IMPLEMENTED -> (
        match entity with
          | EntityHost host ->
              Lang.get_msg env.env_lang "error_server_feature_not_implemented"
                [host.ldomain]
          | EntityMe _ ->
              Lang.get_msg env.env_lang
                "error_my_client_feature_not_implemented" []
          | EntityYou jid ->
              Lang.get_msg env.env_lang
                "error_your_client_feature_not_implemented" []
          | EntityUser (text, jid) ->
              Lang.get_msg env.env_lang "error_client_feature_not_implemented"
                [text]
      )
    | ERR_REMOTE_SERVER_TIMEOUT ->
        Lang.get_msg env.env_lang "error_remote_server_timeout" [get_host entity]
    | ERR_REMOTE_SERVER_NOT_FOUND ->
        Lang.get_msg env.env_lang "error_remote_server_not_found"
          [get_host entity]
    | ERR_SERVICE_UNAVAILABLE ->
        (match entity with
           | EntityHost host ->
               Lang.get_msg env.env_lang "error_server_service_unavailable"
                 [host.domain]
           | EntityYou _jid ->
               Lang.get_msg env.env_lang"error_your_service_unavailable" []
           | EntityMe jid ->
               Lang.get_msg env.env_lang "error_my_service_unavailable" []
           | EntityUser (text, jid) ->
               Lang.get_msg env.env_lang "error_client_service_unavailable"
                 [text]
        )
    | ERR_RECIPIENT_UNAVAILABLE ->
        Lang.get_msg env.env_lang "error_recipient_unavailable" []
    | ERR_NOT_ALLOWED ->
        Lang.get_msg env.env_lang "error_not_allowed" []
          
    | ERR_BAD_REQUEST
    | ERR_CONFLICT
    | ERR_FORBIDDEN
    | ERR_GONE
    | ERR_INTERNAL_SERVER_ERROR
    | ERR_ITEM_NOT_FOUND
    | ERR_JID_MALFORMED
    | ERR_NOT_ACCEPTABLE
    | ERR_NOT_AUTHORIZED
    | ERR_PAYMENT_REQUIRED
    | ERR_REDIRECT
    | ERR_REGISTRATION_REQUIRED
    | ERR_RESOURCE_CONSTRAINT
    | ERR_SUBSCRIPTION_REQUIRED
    | ERR_UNDEFINED_CONDITION
    | ERR_UNEXPECTED_REQUEST ->
        if error.err_text = "" then
          Lang.get_msg env.env_lang "error_any_error" []
        else
          error.err_text
    | UNKNOWN_CONDITION other ->
        other
            
            
let simple_query_entity ?me ?(error_exceptions=[]) success
    ~payload xmpp env kind jid_from text =
  let entity =
    try Some (env.env_get_entity text jid_from) with _ -> None in
    match entity with
      | None ->
          env.env_message xmpp kind jid_from
            (Lang.get_msg env.env_lang "invalid_entity" [])
      | Some e ->
          match e, me with
            | EntityMe _, Some f ->
                f xmpp env kind jid_from text
            | EntityMe jid, _
            | EntityYou jid, _
            | EntityUser (_, jid), _
            | EntityHost jid, _ ->
                let proc ev _jidfrom _jidto _lang () =
                  match ev with
                    | IQResult el ->
                        env.env_message xmpp kind jid_from
                          (success env text e el)
                    | IQError err -> (
                        if List.mem err.err_condition error_exceptions then
                          env.env_message xmpp kind jid_from
                            (success env text e None)
                        else
                          env.env_message xmpp kind jid_from
                            (process_error err env e)
                      )
                in
                  XMPP.make_iq_request xmpp ~jid_to:jid (IQGet payload) proc
        

let os = (let f = Unix.open_process_in "uname -sr" in
          let answer = input_line f in
            ignore (Unix.close_process_in f); answer)
  
let features xmpp =
  XMPP.register_iq_request_handler xmpp XEP_version.ns_version
    (fun ev _jid_from _jid_to _lang () ->
       match ev with
         | IQGet _el ->
             let el = XEP_version.encode {XEP_version.name = Version.name;
                                          XEP_version.version = Version.version;
                                          XEP_version.os = os} in
               IQResult (Some el)
         | IQSet _el ->
             raise BadRequest
    )
    
    
Something went wrong with that request. Please try again.