1 (** URL paths, in both directions. 2 3 One {!t} value describes a page, and the same value both generates a link 4 ({!path_of}) and is recovered from an incoming request ({!dispatch}). 5 Keeping the two directions in one module is what stops generated links and 6 served routes from drifting apart. *) 7 8 type t = 9 | Root 10 | Project_dir of string 11 | Repo of string 12 | Commits of string 13 | Commits_branch of string * string 14 | Commit of string * string 15 | Files of string 16 | File of string * string 17 | File_at of string * string 18 | Raw_file of string * string 19 | Raw_at of string * string 20 21 (* Path arguments in [File_at] and [Raw_at] carry repository file names, which 22 may contain characters that are not safe in a URL. [path_of] percent-encodes 23 each segment and [dispatch] decodes them, so the round trip preserves any 24 name. Repository names and object ids are emitted as-is: the former are 25 constrained by [Resolvers.is_valid_repo_name], the latter are hexadecimal. *) 26 27 let encode_segment segment = 28 let buffer = Buffer.create (String.length segment) in 29 String.iter 30 (fun char -> 31 match char with 32 | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '-' | '.' | '_' | '~' -> 33 Buffer.add_char buffer char 34 | _ -> 35 Buffer.add_string buffer (Printf.sprintf "%%%02X" (Char.code char))) 36 segment; 37 Buffer.contents buffer 38 39 let encode_path path = 40 String.split_on_char '/' path |> List.map encode_segment |> String.concat "/" 41 42 let hex_digit_value = function 43 | '0' .. '9' as digit -> Some (Char.code digit - Char.code '0') 44 | 'a' .. 'f' as digit -> Some (Char.code digit - Char.code 'a' + 10) 45 | 'A' .. 'F' as digit -> Some (Char.code digit - Char.code 'A' + 10) 46 | _ -> None 47 48 (* A '%' that is not followed by two hexadecimal digits is kept literally 49 rather than rejected: the segment then simply names no existing file. *) 50 let decode_segment segment = 51 let length = String.length segment in 52 let buffer = Buffer.create length in 53 let rec go index = 54 if index >= length then () 55 else if segment.[index] = '%' && index + 2 < length then ( 56 match 57 (hex_digit_value segment.[index + 1], hex_digit_value segment.[index + 2]) 58 with 59 | Some high, Some low -> 60 Buffer.add_char buffer (Char.chr ((high * 16) + low)); 61 go (index + 3) 62 | _ -> 63 Buffer.add_char buffer '%'; 64 go (index + 1)) 65 else ( 66 Buffer.add_char buffer segment.[index]; 67 go (index + 1)) 68 in 69 go 0; 70 Buffer.contents buffer 71 72 let decode_path segments = 73 List.map decode_segment segments |> String.concat "/" 74 75 (* Generate URL paths for routes *) 76 let path_of = function 77 | Root -> "/" 78 | Project_dir dir -> "/" ^ dir ^ "/" 79 | Repo repo -> "/" ^ repo ^ "/summary/" 80 | Commits repo -> "/" ^ repo ^ "/commits/" 81 | Commits_branch (repo, branch) -> "/" ^ repo ^ "/commits/" ^ branch 82 | Commit (repo, hash) -> "/" ^ repo ^ "/commit/" ^ hash 83 | Files repo -> "/" ^ repo ^ "/files/" 84 | File (repo, hash) -> "/" ^ repo ^ "/file/" ^ hash 85 | File_at (repo, path) -> "/" ^ repo ^ "/file/" ^ encode_path path 86 | Raw_file (repo, hash) -> "/" ^ repo ^ "/raw/" ^ hash 87 | Raw_at (repo, path) -> "/" ^ repo ^ "/raw/" ^ encode_path path 88 89 let known_actions = [ "summary"; "commits"; "commit"; "files"; "file"; "raw" ] 90 91 (* The store hashes objects with SHA-1, whose hexadecimal form is 40 92 characters. A single segment of that shape is an object id; anything else 93 under file/ or raw/ is a path. *) 94 let is_hex_hash candidate = 95 String.length candidate = 40 96 && String.for_all 97 (function '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false) 98 candidate 99 100 (* The split point is the first segment naming a known action; everything 101 before it is the repository or directory path. Anything after the action 102 that the route shapes above do not account for is rejected rather than 103 ignored, so every accepted path is one [path_of] can regenerate. *) 104 let dispatch path = 105 let segments = 106 String.split_on_char '/' path |> List.filter (fun s -> s <> "") 107 in 108 let rec find_split repo_acc = function 109 | [] -> ( 110 (* No action segment: the root, or a repository/directory path whose 111 page is the implicit summary. Only the filesystem can tell a 112 repository from a directory of repositories, so dispatch reports 113 [Project_dir] and the handler resolves which one it is. *) 114 match String.concat "/" (List.rev repo_acc) with 115 | "" -> Some Root 116 | repo -> Some (Project_dir repo)) 117 | seg :: rest when List.mem seg known_actions -> ( 118 let repo = String.concat "/" (List.rev repo_acc) in 119 if repo = "" then None 120 else 121 match (seg, rest) with 122 | "summary", [] -> Some (Repo repo) 123 | "commits", [] -> Some (Commits repo) 124 | "commits", [ branch ] -> Some (Commits_branch (repo, branch)) 125 | "commit", [ hash ] -> Some (Commit (repo, hash)) 126 | "files", [] -> Some (Files repo) 127 | "file", [ hash ] when is_hex_hash hash -> Some (File (repo, hash)) 128 | "file", (_ :: _ as path) -> Some (File_at (repo, decode_path path)) 129 | "raw", [ hash ] when is_hex_hash hash -> 130 Some (Raw_file (repo, hash)) 131 | "raw", (_ :: _ as path) -> Some (Raw_at (repo, decode_path path)) 132 | _ -> None) 133 | seg :: rest -> find_split (seg :: repo_acc) rest 134 in 135 find_split [] segments 136