path: root/grammar/SIPGrammar.st

"
 (C) 2011-2014 by Holger Hans Peter Freyther
 All Rights Reserved

 This program is free software: you can redistribute it and/or modify
 it under the terms of the GNU Affero General Public License as
 published by the Free Software Foundation, either version 3 of the
 License, or (at your option) any later version.

 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU Affero General Public License for more details.

 You should have received a copy of the GNU Affero General Public License
 along with this program.  If not, see <http://www.gnu.org/licenses/>.
"

PP.PPCompositeParser subclass: SIPGrammar [
    | Response StatusLine message_header
      CRLF SP HTAB HCOLON SWS LWS WSP COMMA SEMI SLASH COLON EQUAL
      LAQUOT RAQUOT LDQUOT RDQUOT DQUOTE STAR URI
      message_body SIPVersion StatusCode ReasonPhrase 
      extension_header header_name header_value 
      Request RequestLine Method extension_method
      RequestURI quoted_string token commonUriParser paramchar
      header
    |
    "http://sofia-sip.org/repos/sofia-sip/libsofia-sip-ua/sip/GRAMMAR"
    <category: 'OsmoSIP-Grammar'>
    <comment: 'I try to parse RFC3261'>

    start [
        <category: 'start'>
        ^ Request / Response
    ]

    CRLF [
        <category: 'misc'>
        ^ Character cr asParser, Character nl asParser
    ]

    SP [
        <category: 'misc'>
        ^ $ asParser
    ]

    URI [
        "TODO: URI should be parsed properly but yate seems to already
        violate the RFC"
        ^(#digit asParser / #word asParser) star
        "^absoluteURI / abs-path"
    ]

    Request [
        <category: 'request'>
        ^ RequestLine, message_header star, CRLF, message_body optional
    ]

    RequestLine [
        <category: 'request'>
        ^ Method, SP, RequestURI, SP, SIPVersion, CRLF
    ]

    RequestURI [
        <category: 'request'>
        "TODO: absoluteURI is not supported"
        ^ self SIPURI / self SIPSURI "/ self absoluteURI"
    ]

    SIPURI [
        <category: 'request'>
        ^ 'sip:' asParser , commonUriParser
    ]

    commonUriParser [
        ^self userinfo optional, self hostport, self uri_parameters,
        self headers optional.
    ]

    SIPSURI [
        <category: 'request'>
        ^ 'sips:' asParser , commonUriParser
    ]

    hostport [
        <category: 'generic'>
        ^ self host, ($: asParser, self port) optional
    ]

    host [
        <category: 'generic'>
        "TODO: too simplieified"
        ^ (#letter asParser / (PP.PPPredicateObjectParser chars: '0123456789.-' message: 'host')) plus flatten
    ]

    port [
        <category: 'generic'>
        ^ #digit asParser plus flatten
    ]

    uri_parameters [
        <category: 'generic'>
        ^ ($; asParser, self uri_parameter) star
    ]

    uri_parameter [
        <category: 'generic'>
        "TODO: simplified"
        ^ self other_param
    ]

    other_param [
        <category: 'generic'>
        ^ self pname, ($= asParser, self pvalue) optional
    ]

    pname [
        <category: 'generic'>
        ^paramchar
    ]

    pvalue [
        <category: 'generic'>
        ^paramchar
    ]

    paramchar [
        <category: 'generic'>
        ^ (self param_unreserved / self unreserved / self escaped) plus flatten
    ]

    param_unreserved [
        <category: 'generic'>
        ^PP.PPPredicateObjectParser chars: '[]/:&+$' message: 'param_unreserved'.
    ]

    headers [
        <category: 'generic'>
        ^ $? asParser, header, ($& asParser, header) star
    ]

    header [
        <category: 'generic'>
        ^self hname, $= asParser, self hvalue
    ]

    hname [
        <category: 'generic'>
        ^ (self hnv_unreserved / self unreserved / self escaped) plus flatten
    ]

    hvalue [
        <category: 'generic'>
        ^ (self hnv_unreserved / self unreserved / self escaped) star flatten
    ]

    hnv_unreserved [
        <category: 'generic'>
        ^PP.PPPredicateObjectParser chars: '[]/?:+$' message: 'hnv_unreserved' 
    ]

    userinfo [
        <category: 'generic'>
        "telephone-subscriber not defined"
        ^ ( self user "/ self telephone_subscriber"),
          ($: asParser, self password) optional, $@ asParser
    ]

    user [
        <category: 'generic'>
        ^ (self unreserved / self escaped / self user_unreserved) plus flatten
    ]

    user_unreserved [
        <category: 'generic'>
        ^PP.PPPredicateObjectParser chars: '&=+$,;?/' message: 'user_unreserved'.
    ]

    escaped [
        <category: 'generic'>
        "^ $% asParser, self HEXDIG, self HEXDIG"
        ^PP.PPPredicateObjectParser chars: '%0123456789abcdefABCDEF' message: 'escaped'.
    ]

    HEXDIG [
        <category: 'RFC5234'>
        ^PP.PPPredicateObjectParser chars: '0123456789ABCDEF' message: 'hexdig expected'.
    ]

    LHEX [
        ^PP.PPPredicateObjectParser chars: '0123456789abcdef' message: 'lhex expected'.
    ]

    unreserved [
        <category: 'generic'>
        ^ (#letter asParser / #digit asParser) / self mark
    ]

    reserved [
        <category: 'generic'>
        ^PP.PPPredicateObjectParser chars: ';/?:@&=+$,' message: 'reserved'.
    ]

    mark [
        ^PP.PPPredicateObjectParser chars: '-_.!~*''()' message: 'mark'.
    ]
   
    password [
        <category: 'request'>
        ^ ( self unreserved / self escaped / $& asParser /
            $= asParser / $+ asParser / $$ asParser / $, asParser) star
    ] 

    Method [
        <category: 'request'>
        ^ 'INVITE'   asParser /
          'ACK'      asParser /
          'OPTIONS'  asParser /
          'BYE'      asParser /
          'CANCEL'   asParser /
          'REGISTER' asParser /
          extension_method
    ]

    extension_method [
        ^token
    ]

    Response [
        <category: 'response'>
        ^ StatusLine, message_header star, CRLF, message_body optional
    ]

    StatusLine [
        <category: 'response'>
        ^ SIPVersion, SP, StatusCode, SP, ReasonPhrase, CRLF
    ]

    SIPVersion [
        <category: 'generic'>
        ^ 'SIP/2.0' asParser
    ]

    StatusCode [
        <category: 'response'>
        "Combined into one..."
        ^ (#digit asParser min: 3 max: 3) flatten
    ]

    ReasonPhrase [
        <category: 'response'>

        ^ (self reserved / self unreserved / self escaped /
           SP / HTAB / #letter asParser) star flatten
    ]

    message_header [
        "Simplified..."
        <category: 'generic'>

        ^ (self Via / self CSeq / self From /
           self To / self Contact / self WWWAuthenticate / self ProxyAuthenticate /
           self Authorization / self ProxyAuthorization / extension_header), CRLF
    ]

    message_body [
        ^ #any asParser plus flatten
    ]

    Via [
        <category: 'via'>
        ^ ( 'Via' asParser / 'v' asParser), HCOLON,
          self via_parm, (COMMA, self via_parm) star
    ]

    via_parm [
        <category: 'via'>
        ^ self sent_protocol, LWS, self sent_by, (SEMI, self via_params) star
    ]

    via_params [
        <category: 'via'>
        ^ self via_ttl / self via_maddr / self via_received /
          self via_branch / self response_port / self via_extension
    ]

    via_ttl [
        <category: 'via'>
        ^ 'ttl' asParser, EQUAL, self ttl
    ]

    via_maddr [
        <category: 'via'>
        ^ 'maadr' asParser, EQUAL, self host
    ]

    via_received [
        <category: 'via'>
        "TODO: IPv6 support is missing"
        ^ 'received' asParser, EQUAL, (self IPv4address)
    ]

    via_branch [
        <category: 'via'>
        ^ 'branch' asParser, EQUAL, token
    ]

    via_extension [
        <category: 'via'>
        ^ self generic_param
    ]

    response_port [
        <category: 'via'>
        ^'rport' asParser, (EQUAL, #digit asParser plus) optional
    ]

    ttl [
        <category: 'generic'>
        ^ #digit asParser min: 1 max: 3
    ]

    IPv4address [
        ^ (#digit asParser min: 1 max: 3), $. asParser,
          (#digit asParser min: 1 max: 3), $. asParser,
          (#digit asParser min: 1 max: 3), $. asParser,
          (#digit asParser min: 1 max: 3).
    ]

    CSeq [
        <category: 'cseq'>
        ^ 'CSeq' asParser, HCOLON, (#digit asParser plus flatten, LWS, self Method)
    ]

    generic_param [
        <category: 'generic'>
        ^ token, (EQUAL, self gen_value) optional
    ]

    gen_value [
        <category: 'generic'>
        ^token / self host / quoted_string
    ]

    quoted_string [
        <category: 'generic'>
        ^SWS, DQUOTE, (self qdtext / self quoted_pair) star flatten, DQUOTE
    ]

    qdtext [
        | str |
        <category: 'generic'>
        "TODO: UTF-8 text is not working properly..."
        str := WriteStream on: (String new).
        str nextPut: (Character value: 16r21).
        16r23 to: 16r5B do: [:each | str nextPut: (Character value: each)].
        16r5D to: 16r7E do: [:each | str nextPut: (Character value: each)].
        ^ LWS / (PP.PPPredicateObjectParser chars: str contents message: 'qdtext') "/ UTF8_NONASCII"
    ]

    quoted_pair [
        | str |
        <category: 'generic'>
        str := WriteStream on: (String new).
        str nextPut: (Character value: 16r21).
        16r00 to: 16r09 do: [:each | str nextPut: (Character value: each)].
        16r0B to: 16r0C do: [:each | str nextPut: (Character value: each)].
        16r5D to: 16r7E do: [:each | str nextPut: (Character value: each)].
        ^ '\' asParser, (PP.PPPredicateObjectParser chars: str contents message: 'quoted_pair')
    ]

    sent_protocol [
        <category: 'via'>
        ^ self protocol_name, SLASH, self protocol_version, SLASH, self transport
    ]

    sent_by [
        <category: 'via'>
        ^ self host, (COLON, self port) optional
    ]

    protocol_name [
        <category: 'via'>
        ^ 'SIP' asParser / token.
    ]

    protocol_version [
        <category: 'via'>
        ^token
    ]

    transport [
        <category: 'via'>
        ^ 'UDP' asParser / 'TCP' asParser / 'TLS' asParser /
          'SCTP' asParser / self other_transport
    ]

    other_transport [
        <category: 'via'>
        ^token
    ]

    From [
        <category: 'from'>
        ^ ('From' asParser / 'f' asParser), HCOLON, self from_spec
    ]

    from_spec [
        <category: 'from'>
        ^ (self name_addr / self addr_spec), (SEMI, self from_param) star
    ]

    from_param [
        <category: 'from'>
        ^ self tag_param / self generic_param
    ]

    To [
        <category: 'to'>
        ^ ('To' asParser / $t asParser), HCOLON, self to_spec
    ]

    to_spec [
        "I do not exist in the RFC but I make things more beautiful and
        symmetric with the From case"
        <category: 'to'>
        ^ (self name_addr / self addr_spec), (SEMI, self to_param) star
    ]

    to_param [
        <category: 'to'>
        ^ self tag_param / self generic_param
    ]

    tag_param [
        <category: 'to'>
        ^ 'tag' asParser, EQUAL, token
    ]

    name_addr [
        <category: 'to-from'>
        ^ self display_name optional, LAQUOT, self addr_spec, self RAQUOT
    ]

    display_name [
        <category: 'to-from'>
        ^ (quoted_string / (token, LWS) star) flatten
    ]

    addr_spec [
        <category: 'to-from'>
        "TODO: absoluteURI is not supported"
        ^ self SIPURI / self SIPSURI "/ self absoluteURI"
    ]

    Contact [
        <category: 'contact'>
        ^ ('Contact' asParser / 'm' asParser), HCOLON,
          (STAR / (self contact_param, (COMMA, self contact_param) star))
    ]

    Authorization [
        <category: 'WWW-Authenticate'>
        ^'Authorization' asParser, HCOLON, self credentials
    ]

    credentials [
        <category: 'WWW-Authenticate'>
        ^('Digest' asParser, LWS, self digest_response) / self other_response
    ]

    digest_response [
        <category: 'WWW-Authenticate'>
        ^self dig_resp, (COMMA, self dig_resp) star
    ]

    dig_resp [
        <category: 'WWW-Authenticate'>
        ^self username / self realm / self nonce / self digest_uri /
        self dresponse / self algorithm / self cnonce / self opaque /
        self message_qop / self nonce_count  / self auth_param
    ]

    username [
        <category: 'WWW-Authenticate'>
        ^'username' asParser, EQUAL, quoted_string
    ]

    digest_uri [
        <category: 'WWW-Authenticate'>
        ^'uri' asParser, EQUAL, LDQUOT, self digest_uri_value, RDQUOT
    ]

    digest_uri_value [
        <category: 'WWW-Authenticate'>
        ^RequestURI
    ]

    message_qop [
        <category: 'WWW-Authenticate'>
        ^'qop' asParser, EQUAL, self qop_value flatten
    ]

    cnonce [
        <category: 'WWW-Authenticate'>
        ^'cnonce' asParser, EQUAL, self nonce_value
    ]

    nonce_count [
        <category: 'WWW-Authenticate'>
        ^'nc' asParser, EQUAL, (self LHEX min: 8 max: 8) flatten
    ]

    dresponse [
        <category: 'WWW-Authenticate'>
        ^'response' asParser , EQUAL , self request_digest
    ]

    request_digest [
        <category: 'WWW-Authenticate'>
        ^LDQUOT, (self LHEX min: 32 max: 32) flatten, RDQUOT
    ]

    WWWAuthenticate [
        <category: 'WWW-Authenticate'>
        ^'WWW-Authenticate' asParser, HCOLON, self challenge
    ]

    challenge [
        <category: 'WWW-Authenticate'>
        ^('Digest' asParser trim, (digest_cln separatedBy: COMMA)) /
            self other_challenge
    ]

    digest_cln [
        <category: 'WWW-Authenticate'>
        ^self realm / self domain / self nonce / self opaque /
            self stale / self algorithm / self qop_options / self auth_param
    ]

    other_challenge [
        <category: 'WWW-Authenticate'>
        ^self auth_scheme trim, (auth_param separatedBy: COMMA)
    ]

    realm [
        <category: 'WWW-Authenticate'>
        ^'realm' asParser, EQUAL, self realm_value
    ]

    realm_value [
        <category: 'WWW-Authenticate'>
        ^quoted_string
    ]

    domain [
        <category: 'WWW-Authenticate'>
        ^'domain' asParser, EQUAL, LDQUOT, URI, (SP plus, URI) star, RDQUOT
    ]

    nonce [
        <category: 'WWW-Authenticate'>
        ^'nonce' asParser, EQUAL, self nonce_value
    ]

    nonce_value [
        <category: 'WWW-Authenticate'>
        ^quoted_string
    ]

    opaque [
        <category: 'WWW-Authenticate'>
        ^'opaque' asParser, EQUAL, quoted_string
    ]

    stale [
        <category: 'WWW-Authenticate'>
        ^'stale' asParser, EQUAL, ('true' asParser caseInsensitive / 'false' asParser caseInsensitive)
    ]

    algorithm [
        <category: 'WWW-Authenticate'>
        ^'algorithm' asParser, EQUAL, ('MD5' asParser / 'MD5-sess' asParser / token)
    ]

    qop_options [
        | qop_value |
        <category: 'WWW-Authenticate'>
        qop_value := self qop_value flatten.
        ^ 'qop' asParser, EQUAL, LDQUOT, qop_value, ($, asParser, qop_value) star, RDQUOT
    ]

    qop_value [
        <category: 'WWW-Authenticate'>
        ^'auth' asParser / 'auth-init' asParser / token
    ]

    auth_param [
        <category: 'WWW-Authenticate'>
        ^self auth_param_name, EQUAL, (token / quoted_string)
    ]

    auth_param_name [
        <category: 'WWW-Authenticate'>
        ^token
    ]

    other_response [
        <category: 'WWW-Authenticate'>
        ^self auth_scheme, LWS, self auth_param, (COMMA, self auth_param) plus
    ]

    auth_scheme [
        <category: 'WWW-Authenticate'>
        ^token
    ]

    ProxyAuthenticate [
        <category: 'Proxy-Authenticate'>
        ^'Proxy-Authenticate' asParser, HCOLON, self challenge
    ]

    ProxyAuthorization [
        <category: 'Proxy-Authenticate'>
        ^'Proxy-Authorization' asParser, HCOLON, self credentials
    ]

    contact_param [
        <category: 'contact'>
        ^ (self name_addr / self addr_spec), (SEMI, self contact_params) star
    ]

    contact_params [
        <category: 'contact'>
        ^ self c_p_q / self c_p_expires / self contact_extension
    ]

    c_p_q [
        <category: 'contact'>
        ^ $q asParser, EQUAL, self qvalue
    ]

    c_p_expires [
        <category: 'contact'>
        ^ 'expires' asParser, EQUAL, self delta_seconds
    ]

    contact_extension [
        <category: 'contact'>
        ^ self generic_param
    ]

    delta_seconds [
        <category: 'contact'>
        ^ #digit asParser plus
    ]

    extension_header [
        <category: 'generic'>
        ^ header_name, HCOLON, header_value
    ]

    qvalue [
        <category: 'generic'>
        ^ ($0 asParser, ($. asParser, #digit asParser max: 3) optional) /
          ($1 asParser, ($. asParser, $0 asParser max: 3) optional)
    ]

    token [
        <category: 'generic'>

        ^ (PP.PPPredicateObjectParser on: (PP.PPCharSetPredicate on:
                                [:char | char isAlphaNumeric or: [
                                    '-.!%*_+`''~' includes: char]]) message: 'token') plus flatten
    ]

    header_name [
        <category: 'generic'>
        "hmm 1*() should be optional but it must be star here"
        ^token
    ]

    header_value [
        <category: 'generic'>
        "TODO: TEXT-UTF8char / UTF8-CONT"
        ^ (#letter asParser / #digit asParser / #punctuation asParser / #blank asParser / LWS) star flatten
    ]

    HTAB [
        <category: 'generic'>
        ^ Character tab asParser
    ]

    HCOLON [
        <category: 'generic'>

        ^ (SP / HTAB) star, $: asParser trim
    ]

    WSP [
        <category: 'misc'>
        ^ #blank asParser
    ]

    LWS [
        <category: 'generic'>
        ^ (WSP star, CRLF) optional, WSP plus
    ]

    COMMA [
        <category: 'generic'>
        ^ $, asParser trim
    ]

    SEMI [
        <category: 'generic'>
        ^ $; asParser trim
    ]

    SLASH [
        <category: 'generic'>
        ^ $/ asParser trim
    ]

    COLON [
        <category: 'generic'>
        ^ $: asParser trim
    ]

    EQUAL [
        <category: 'generic'>
        ^ $= asParser trim
    ]

    SWS [
        <category: 'generic'>
        ^ LWS optional
    ]

    LAQUOT [
        <category: 'generic'>
        ^ SWS, $< asParser
    ]

    RAQUOT [
        <category: 'generic'>
        ^ $> asParser, SWS
    ]

    LDQUOT [
        <category: 'generic'>
        ^ SWS, DQUOTE
    ]

    RDQUOT [
        <category: 'generic'>
        ^ DQUOTE, SWS
    ]

    DQUOTE [
        <category: 'generic'>
        ^ $" asParser
    ]

    STAR [
        <category: 'generic'>
        ^$* asParser trim
    ]
]