Find file
Fetching contributors…
Cannot retrieve contributors at this time
249 lines (215 sloc) 8.82 KB
module type Http =
sig
type request
val http_method : request -> [ `Get | `Post | `Head ]
val url : request -> string
val header : request -> string -> string (* throws Not_found *)
val argument : request -> ?default:string -> string -> string (* throws Not_found *)
val arguments : request -> (string * string) list
type response
val respond : request -> Nethttp.http_status -> (string * string) list -> string -> response
exception Error of Nethttp.http_status * string
end
module type Db =
sig
module Http : Http
type consumer
val lookup_consumer : string -> consumer (* throws Not_found *)
val consumer_key : consumer -> string
val consumer_secret : consumer -> string
val consumer_rsa_key : consumer -> Cryptokit.RSA.key (* throws Not_found *)
type request_token
val make_request_token : consumer -> Http.request -> request_token
val lookup_request_token: string -> request_token (* throws Not_found *)
val request_token_check_consumer : request_token -> consumer -> bool
val request_token_token : request_token -> string
val request_token_secret : request_token -> string
val request_token_authorized : request_token -> bool
val authorize_request_token : request_token -> Http.request -> unit (* throws Failure *)
type access_token
val exchange_request_token : request_token -> access_token (* throws Failure *)
val lookup_access_token : string -> access_token (* throws Not_found *)
val access_token_check_consumer : access_token -> consumer -> bool
val access_token_token : access_token -> string
val access_token_secret : access_token -> string
end
module Make
(Http : Http)
(Db : Db with module Http = Http) =
struct
let bad_request msg = raise (Http.Error (`Bad_request, msg))
let unauthorized msg = raise (Http.Error (`Unauthorized, msg))
let with_oauth_params req f =
let arg =
try
let h = Http.header req "Authorization" in
let parts = Pcre.split ~pat:"\\s*,\\s*" h in
let args =
List.map
(fun p ->
match Pcre.extract ~pat:"(\\S*)\\s*=\\s*\"([^\"]*)\"" p with
| [| _; k; v |] -> k, Oauth_common.rfc3986_decode v
| _ -> raise Not_found) (* bad header, fall back to CGI args (?) *)
parts in
let arg ?default name =
try List.assoc name args
with Not_found as e ->
match default with
| Some d -> d
| _ -> raise e in
arg
with Not_found -> Http.argument req in
let required_arg name =
try arg name
with Not_found -> bad_request ("missing parameter " ^ name) in
let optional_arg name =
try Some (arg name)
with Not_found -> None in
let http_method = Http.http_method req in
let url = Http.url req in
let oauth_consumer_key = required_arg "oauth_consumer_key" in
let oauth_token = optional_arg "oauth_token" in
let oauth_signature_method = required_arg "oauth_signature_method" in
let oauth_signature = required_arg "oauth_signature" in
let oauth_timestamp = required_arg "oauth_timestamp" in
let oauth_nonce = required_arg "oauth_nonce" in
let oauth_version = arg ~default:"1.0" "oauth_version" in
if oauth_version <> "1.0" then bad_request ("unsupported version " ^ oauth_version);
let consumer =
try Db.lookup_consumer oauth_consumer_key
with Not_found -> unauthorized "invalid consumer key" in
let oauth_consumer_secret = Db.consumer_secret consumer in
let oauth_signature_method =
try
Oauth_common.signature_method_of_string
(fun () ->
try Db.consumer_rsa_key consumer
with Not_found -> unauthorized "no RSA key")
oauth_signature_method
with Not_found ->
bad_request ("unsupported signature method " ^ oauth_signature_method) in
let oauth_timestamp =
try float_of_string (oauth_timestamp ^ ".")
with Failure _ -> 0. in
f
~http_method ~url ~consumer
~oauth_consumer_key ~oauth_consumer_secret
~oauth_signature_method ~oauth_signature
~oauth_timestamp ~oauth_nonce ~oauth_version
?oauth_token
()
let fetch_request_token req =
let frt
~http_method ~url ~consumer
~oauth_consumer_key ~oauth_consumer_secret
~oauth_signature_method ~oauth_signature
~oauth_timestamp ~oauth_nonce ~oauth_version
?oauth_token
() =
if
Oauth_common.check_signature
~http_method ~url
~oauth_signature_method ~oauth_signature
~oauth_consumer_key ~oauth_consumer_secret
~oauth_timestamp ~oauth_nonce ~oauth_version
~params:(Http.arguments req)
()
then
let request_token = Db.make_request_token consumer req in
Http.respond req `Ok []
(Netencoding.Url.mk_url_encoded_parameters [
"oauth_token", Db.request_token_token request_token;
"oauth_token_secret", Db.request_token_secret request_token;
])
else unauthorized "invalid signature" in
try with_oauth_params req frt
with Http.Error (status, msg) -> Http.respond req status [] msg
let fetch_access_token req =
let frt
~http_method ~url ~consumer
~oauth_consumer_key ~oauth_consumer_secret
~oauth_signature_method ~oauth_signature
~oauth_timestamp ~oauth_nonce ~oauth_version
?oauth_token
() =
let request_token =
match oauth_token with
| None -> bad_request "missing parameter oauth_token"
| Some t ->
try Db.lookup_request_token t
with Not_found -> unauthorized "invalid request token" in
if not (Db.request_token_check_consumer request_token consumer)
then bad_request "consumer/request token mismatch";
let oauth_token = Db.request_token_token request_token in
let oauth_token_secret = Db.request_token_secret request_token in
if
Oauth_common.check_signature
~http_method ~url
~oauth_signature_method ~oauth_signature
~oauth_consumer_key ~oauth_consumer_secret
~oauth_token ~oauth_token_secret
~oauth_timestamp ~oauth_nonce ~oauth_version
~params:(Http.arguments req)
()
then
let access_token =
try Db.exchange_request_token request_token
with Failure msg -> unauthorized msg in
Http.respond req `Ok []
(Netencoding.Url.mk_url_encoded_parameters [
"oauth_token", Db.access_token_token access_token;
"oauth_token_secret", Db.access_token_secret access_token;
])
else unauthorized "invalid signature" in
try with_oauth_params req frt
with Http.Error (status, msg) -> Http.respond req status [] msg
let authorize_request_token req kget kpost =
try
let oauth_token =
try Http.argument req "oauth_token"
with Not_found -> bad_request "missing parameter oauth_token" in
let request_token =
try Db.lookup_request_token oauth_token
with Not_found -> unauthorized "invalid request token" in
if Db.request_token_authorized request_token
then bad_request "request token already authorized";
match Http.http_method req with
| `Get ->
kget oauth_token request_token req
| `Post ->
Db.authorize_request_token request_token req;
kpost oauth_token request_token req
| _ -> raise (Http.Error (`Method_not_allowed, ""))
with Http.Error (status, msg) -> Http.respond req status [] msg
let access_resource req k =
let frt
~http_method ~url ~consumer
~oauth_consumer_key ~oauth_consumer_secret
~oauth_signature_method ~oauth_signature
~oauth_timestamp ~oauth_nonce ~oauth_version
?oauth_token
() =
let access_token =
match oauth_token with
| None -> bad_request "missing parameter oauth_token"
| Some t ->
try Db.lookup_access_token t
with Not_found -> unauthorized "invalid access token" in
if not (Db.access_token_check_consumer access_token consumer)
then bad_request "consumer/access token mismatch";
let oauth_token = Db.access_token_token access_token in
let oauth_token_secret = Db.access_token_secret access_token in
if
Oauth_common.check_signature
~http_method ~url
~oauth_signature_method ~oauth_signature
~oauth_consumer_key ~oauth_consumer_secret
~oauth_token ~oauth_token_secret
~oauth_timestamp ~oauth_nonce ~oauth_version
~params:(Http.arguments req)
()
then k oauth_token access_token req
else unauthorized "invalid signature"in
try with_oauth_params req frt
with Http.Error (status, msg) -> Http.respond req status [] msg
end