Skip to content
This repository
tag: v790
Fetching contributors…

Cannot retrieve contributors at this time

file 151 lines (119 sloc) 6.73 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 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA 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 OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* Accept: see the interface file for docs. *)
open Printf
open HttpTools
open HttpServerTypes

(* depends *)
module List = BaseList

type el = string list * string list list * float option

type t = string option * char option * el list

let flre = Str.regexp "[ \t]*\\([0-9]+\\.[0-9]\\)+[ \t]*"
let get_fl str = if Str.string_match flre str 0 then float_of_string (Str.matched_group 1 str) else 0.0

let is_q = function ("q"::_::_) -> true | _ -> false
let get_q lst =
  match List.find_opt (function ("q"::_::_) -> true | _ -> false) lst with
  | Some (_::v::_) -> Some (get_fl v)
  | _ -> None
let mv_q (l1,l2) = let (l2q,l2a) = List.partition is_q l2 in (l1,l2a,get_q l2q)

let split_opt regexp_opt str = match regexp_opt with | Some regexp -> Str.split regexp str | None -> [str]
let pair_opt = function | Some (a,b) -> Some a, Some b | None -> None, None

let regexp1 = Str.regexp "[ \t]*,[ \t]*"
let regexp2 = Str.regexp "[ \t]*;[ \t]*"
let regexp3 ch_opt = Option.map (fun ch -> (ch, Str.regexp (Printf.sprintf "[ \t]*%c[ \t]*" ch))) ch_opt
let regexp3sl = regexp3 (Some '/')
let regexp3mi = regexp3 (Some '-')
let regexp4 = Str.regexp "[ \t]*=[ \t]*"

let make_el (regexp3_opt:(char * Str.regexp) option) (str:string) : el =
  let _, regexp_opt = pair_opt regexp3_opt in
  (function | s1::sl -> mv_q (split_opt regexp_opt s1, List.map (Str.split regexp4) sl)
            | [] -> ([],[],None))
    (Str.split regexp2 str)

let make_el_ch (ch_opt:char option) (str:string) : el =
  make_el (match ch_opt with Some ch -> Some (ch,Str.regexp (sprintf "[ \t]*%c[ \t]*" ch)) | None -> None) str

let make (regexp3_opt:(char * Str.regexp) option) (str:string) : t =
  let str, comment_opt = strcom str (String.length str) in
  let ch_opt, _ = pair_opt regexp3_opt in
  (comment_opt, ch_opt, List.map (make_el regexp3_opt) (Str.split regexp1 str))

let size ((_,_,phdr):t) = List.length phdr

let q_value ((_,_,q_opt):el) = Option.default 1.0 q_opt

let q_rank ((comment_opt,ch_opt,phdr):t) : t =
  let cmp (q1,_) (q2,_) = Pervasives.compare q2 q1 in
  (comment_opt,ch_opt,List.map snd (List.sort cmp (List.map (fun ph -> (q_value ph,ph)) phdr)))

let q_nth ((_,_,phdr):t) (n:int) : el option =
  try Some (List.nth phdr n)
  with Invalid_argument "List.nth" | Failure "nth" -> None

(* TODO: do we want "text" to match "text/*" ??? *)
(* or "text/html;level=1" to match "text/html" *)
let hmtch sl pl =
  try List.for_all2 (fun s p -> p = "*" || s = "*" || s = p) sl pl
  with Invalid_argument "List.for_all2" -> false

let q_max ((_,_,phdr):t) ((sl1,sl2,_):el) : float * el option =
  List.fold_left
    (fun (a,plmax) ((pl1,pl2,_) as pl) ->
       if hmtch sl1 pl1
          && try List.for_all2 hmtch sl2 pl2 with Invalid_argument "List.for_all2" -> false
       then let q = q_value pl in if q > a then (q,Some pl) else (a,plmax)
       else (a,plmax)) (0.0,None) phdr

let q_preferred (cphdr:t) (sls:el list) : el option =
  let maxs = List.map (q_max cphdr) sls in
  match List.fold_left (fun (q1,sl) (q2,mx) -> if q1 > q2 then (q1,sl) else (q2,mx)) (0.0,None) maxs with
  | (0.0,_) -> None (* <-- RFC says we return 406 Unacceptable for this. *)
  | (_,Some (sl1,sl2,q_opt)) -> Some (sl1,sl2,q_opt)
  | _ -> None (* We'll treat malformed q's as 0 and missing q's as 1, see RFC *)

let string_of_el (chstr:string) ((sl1,sl2,q_opt):el) : string =
  String.concat "; " ((String.concat chstr sl1)
                     ::(List.map (String.concat "=") sl2)
                     @(match q_opt with Some q -> ["q="^(sprintf "%2.1f" q)] | None -> []))

let to_string ((comment_opt,ch_opt,phdr):t) : string =
  let chstr = match ch_opt with Some ch -> String.make 1 ch | None -> "" in
  (String.concat ", " (List.map (string_of_el chstr) phdr))
  ^(match comment_opt with Some comment -> " "^comment | None -> "")

let to_string_opt (phdr_opt:t option) : string = Option.default "" (Option.map to_string phdr_opt)

let get_accept (req:HttpServerTypes.request) : t option =
  try
    match List.find_opt (function HttpServerCore_parse.Accept _ -> true | _ -> false)
                        req.HttpServerTypes.request_header with
    | Some (HttpServerCore_parse.Accept str) -> Some (make regexp3sl str)
    | _ -> None
  with _ -> None

let set_accept (req:HttpServerTypes.request) (phdr_opt:t option) : HttpServerTypes.request =
  HttpServer.replace_request_header (HttpServerCore_parse.Accept (to_string_opt phdr_opt)) req

let get_accept_charset (req:HttpServerTypes.request) : t option =
  try
    match List.find_opt (function HttpServerCore_parse.Accept_Charset _ -> true | _ -> false)
                        req.HttpServerTypes.request_header with
    | Some (HttpServerCore_parse.Accept_Charset str) -> Some (make None str)
    | _ -> None
  with _ -> None

let set_accept_charset (req:HttpServerTypes.request) (phdr_opt:t option) : HttpServerTypes.request =
  HttpServer.replace_request_header (HttpServerCore_parse.Accept_Charset (to_string_opt phdr_opt)) req

let get_accept_encoding (req:HttpServerTypes.request) : t option =
  try
    match List.find_opt (function HttpServerCore_parse.Accept_Encoding _ -> true | _ -> false)
                        req.HttpServerTypes.request_header with
    | Some (HttpServerCore_parse.Accept_Encoding str) -> Some (make None str)
    | _ -> None
  with _ -> None

let set_accept_encoding (req:HttpServerTypes.request) (phdr_opt:t option) : HttpServerTypes.request =
  HttpServer.replace_request_header (HttpServerCore_parse.Accept_Encoding (to_string_opt phdr_opt)) req

let get_accept_language (req:HttpServerTypes.request) : t option =
  try
    match List.find_opt (function HttpServerCore_parse.Accept_Language _ -> true | _ -> false)
                        req.HttpServerTypes.request_header with
    | Some (HttpServerCore_parse.Accept_Language str) -> Some (make regexp3mi str)
    | _ -> None
  with _ -> None

let set_accept_language (req:HttpServerTypes.request) (phdr_opt:t option) : HttpServerTypes.request =
  HttpServer.replace_request_header (HttpServerCore_parse.Accept_Language (to_string_opt phdr_opt)) req
Something went wrong with that request. Please try again.