auth_cas.ml 5.55 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
(**************************************************************************)
(*                                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

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

29 30
type config = { server : string }

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

35
module Make (C : CONFIG) (N : NAME) (S : CONT_SERVICE) (T : TEMPLATES) : AUTH_INSTANCE = struct
36

37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
  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
56
    ~path:N.path
57 58 59 60 61
    ~get_params:Eliom_parameter.(opt (string "ticket"))
    ()

  let service = Eliom_service.preapply login_cas None

62 63 64 65
  let on_success_ref = Eliom_reference.eref
    ~scope:Eliom_common.default_session_scope
    (fun ~user_name ~user_logout -> Lwt.return ())

66 67 68 69 70 71
  let () = Eliom_registration.Redirection.register
    ~service:login_cas
    (fun ticket () ->
      match ticket with
      | Some x ->
        let me =
72
          let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96
          rewrite_prefix uri
        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 module L : CONT_SERVICE = struct
                          let cont () =
                            lwt service = S.cont () in
                            let uri = Eliom_uri.make_string_uri ~absolute:true ~service () in
                            let uri = rewrite_prefix uri in
                            security_log (fun () ->
97 98
                              Printf.sprintf "%s:%s logged out, redirecting to CAS [%s]"
                                N.name user_name C.server
99 100 101
                            ) >> Lwt.return (Eliom_service.preapply cas_logout uri)
                        end in
                        let user_logout = (module L : CONT_SERVICE) in
102 103
                        lwt on_success = Eliom_reference.get on_success_ref in
                        on_success ~user_name ~user_logout >>
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
                        S.cont ()
                      | 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
        let uri = rewrite_prefix uri in
        Lwt.return (Eliom_service.preapply cas_login uri)
    )
119

120 121 122
  let handler ~on_success () =
    Eliom_reference.set on_success_ref on_success >>
    Eliom_registration.Redirection.send service
123

124
end
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
let name = "cas"

let parse_config ~instance ~attributes =
  match attributes with
  | ["server", server] -> {server}
  | _ ->
    Printf.ksprintf failwith
      "invalid configuration for instance %s of auth/%s"
      instance name

let make {server} =
  let module C = struct let server = server end in
  (module Make (C) : AUTH_SERVICE)

type c = config

module A : AUTH_SYSTEM = struct
  type config = c
  let name = name
  let parse_config = parse_config
  let make = make
end

let () = Auth_common.register_auth_system (module A : AUTH_SYSTEM)