auth_cas.ml 6.46 KB
Newer Older
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
(**************************************************************************)
(*                                BELENIOS                                *)
(*                                                                        *)
(*  Copyright © 2012-2014 Inria                                           *)
(*                                                                        *)
(*  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, with the additional   *)
(*  exemption that compiling, linking, and/or using OpenSSL is allowed.   *)
(*                                                                        *)
(*  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/>.                                       *)
(**************************************************************************)

open Web_signatures
open Web_common
open Auth_common

let next_lf str i =
  try Some (String.index_from str i '\n')
  with Not_found -> None

30 31 32 33 34
module type CONFIG = sig
  val server : string
end

module Make (C : CONFIG) (N : NAME) : AUTH_INSTANCE = struct
35 36

  let user_admin = false
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
  let user_type = N.name

  let cas_login = Eliom_service.external_service
    ~prefix:C.server
    ~path:["login"]
    ~get_params:Eliom_parameter.(string "service")
    ()

  let cas_logout = Eliom_service.external_service
    ~prefix:C.server
    ~path:["logout"]
    ~get_params:Eliom_parameter.(string "service")
    ()

  let cas_validate = Eliom_service.external_service
    ~prefix:C.server
    ~path:["validate"]
    ~get_params:Eliom_parameter.(string "service" ** string "ticket")
    ()

  let login_cas = Eliom_service.service
    ~path:["auth"; N.name]
    ~get_params:Eliom_parameter.(opt (string "ticket"))
    ()

  let service = Eliom_service.preapply login_cas None

  module Register (S : CONT_SERVICE) (T : TEMPLATES) = struct

    let () = Eliom_registration.Redirection.register
      ~service:login_cas
68 69 70 71 72
      (fun ticket () ->
        match ticket with
        | Some x ->
          let me =
            let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
73
            rewrite_prefix uri
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
          in
          let validation =
            let service = Eliom_service.preapply cas_validate (me, x) in
            Eliom_uri.make_string_uri ~absolute:true ~service ()
          in
          lwt reply = Ocsigen_http_client.get_url validation in
          (match reply.Ocsigen_http_frame.frame_content with
            | Some stream ->
              lwt info = Ocsigen_stream.(string_of_stream 1000 (get stream)) in
              Ocsigen_stream.finalize stream `Success >>
              (match next_lf info 0 with
                | Some i ->
                  (match String.sub info 0 i with
                    | "yes" ->
                      (match next_lf info (i+1) with
                        | Some j ->
                          let user_name = String.sub info (i+1) (j-i-1) in
                          let user_user = {user_type; user_name} in
                          let module L : CONT_SERVICE = struct
                            let cont () =
94
                              lwt service = S.cont () in
95
                              let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
96
                              let uri = rewrite_prefix uri in
97
                              security_log (fun () ->
98 99
                                Printf.sprintf "%s logged out, redirecting to CAS [%s]"
                                  (string_of_user user_user) C.server
100 101 102 103 104
                              ) >> Lwt.return (Eliom_service.preapply cas_logout uri)
                          end in
                          let user_logout = (module L : CONT_SERVICE) in
                          Eliom_reference.set user
                            (Some {user_admin; user_user; user_logout}) >>
105
                          S.cont ()
106 107 108 109 110 111 112 113 114 115 116
                        | None -> fail_http 502
                      )
                    | "no" -> fail_http 401
                    | _ -> fail_http 502
                  )
                | None -> fail_http 502
              )
            | None -> fail_http 502
          )
        | None ->
          let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
117
          let uri = rewrite_prefix uri in
118 119 120 121 122 123
          Lwt.return (Eliom_service.preapply cas_login uri)
      )

  end

end
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 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169

type instance = {
  mutable name : string option;
  mutable server : string option;
}

let init () =
  let instances = ref [] in
  let current_instance = ref None in
  let push_current loc =
    match !current_instance with
    | None -> ()
    | Some {name = Some name; server = Some server} ->
      let module C : CONFIG = struct
        let server = server
      end in
      instances := (name, (module C : CONFIG)) :: !instances;
      current_instance := None
    | _ -> failwith ("unexpected case in auth-cas/" ^ loc)
  in
  let spec =
    let open Ocsigen_extensions.Configuration in
    [
      let init () =
        push_current "init";
        current_instance := Some {name = None; server = None}
      and attributes = [
        attribute ~name:"name" ~obligatory:true (fun s ->
          match !current_instance with
          | Some ({name = None; _} as i) -> i.name <- Some s
          | _ -> failwith "unexpected case in auth-cas/name"
        );
        attribute ~name:"server" ~obligatory:true (fun s ->
          match !current_instance with
          | Some ({server = None; _} as i) -> i.server <- Some s
          | _ -> failwith "unexpected case in auth-cas/server"
        );
      ] in element ~name:"auth-cas" ~init ~attributes ();
    ]
  and exec ~instantiate =
    push_current "exec";
    List.iter (fun (name, config) ->
      let module X = Make ((val config : CONFIG)) in
      instantiate name (module X : AUTH_SERVICE)
    ) !instances
  in Auth_common.register_auth_system ~spec ~exec