basis/furnace/auth/basic/basic.factor

   1 ! Copyright (c) 2007 Chris Double.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors kernel splitting base64 namespaces make strings\r
   4 http http.server.responses furnace.auth ;\r
   5 IN: furnace.auth.basic\r
   6 \r
   7 TUPLE: basic-auth-realm < realm ;\r
   8 \r
   9 : <basic-auth-realm> ( responder name -- realm )\r
  10     basic-auth-realm new-realm ;\r
  11 \r
  12 : parse-basic-auth ( header -- username/f password/f )\r
  13     dup [\r
  14         " " split1 swap "Basic" = [\r
  15             base64> >string ":" split1\r
  16         ] [ drop f f ] if\r
  17     ] [ drop f f ] if ;\r
  18 \r
  19 : <401> ( realm -- response )\r
  20     401 "Invalid username or password" <trivial-response>\r
  21     [ "Basic realm=\"" % swap % "\"" % ] "" make "WWW-Authenticate" set-header ;\r
  22 \r
  23 M: basic-auth-realm login-required* ( description capabilities realm -- response )\r
  24     2nip name>> <401> ;\r
  25 \r
  26 M: basic-auth-realm logged-in-username ( realm -- uid )\r
  27     drop\r
  28     request get "authorization" header parse-basic-auth\r
  29     dup [ over check-login swap and ] [ 2drop f ] if ;\r