auth_cas.ml 5.39 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
  let self =
    Eliom_uri.make_string_uri ~absolute:true ~service () |> rewrite_prefix

65 66 67 68
  let on_success_ref = Eliom_reference.eref
    ~scope:Eliom_common.default_session_scope
    (fun ~user_name ~user_logout -> Lwt.return ())

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

116 117 118
  let handler ~on_success () =
    Eliom_reference.set on_success_ref on_success >>
    Eliom_registration.Redirection.send service
119

120
end
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
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)