module Hails.HttpServer.Auth
( requireLoginMiddleware
, personaAuth
, openIdAuth
, externalAuth
, devBasicAuth
) where
import Control.Monad.IO.Class (liftIO)
import Blaze.ByteString.Builder (toByteString)
import Control.Monad
import Control.Monad.Trans.Resource
import Data.Time.Clock
import Data.ByteString.Base64
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Maybe (fromMaybe, isJust, fromJust)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Conduit as C
import qualified Data.Conduit.List as C
import Data.Digest.Pure.SHA
import Network.HTTP.Conduit (withManager)
import Network.HTTP.Types
import Network.Wai
import Web.Authenticate.BrowserId
import Web.Authenticate.OpenId
import Web.Cookie
devBasicAuth :: Middleware
devBasicAuth app0 req0 = do
let resp = responseLBS status401
[( "WWW-Authenticate", "Basic realm=\"Hails development.\"")] ""
let req = case getBasicAuthUser req0 of
Nothing -> req0
Just user -> req0 { requestHeaders = ("X-Hails-User", user)
: requestHeaders req0 }
requireLoginMiddleware (return resp) app0 req
personaAuth :: L8.ByteString -> Text -> Middleware
personaAuth key audience app0 req0 = do
case () of
_ | doLogin -> do
assertion <- S8.concat `liftM` (requestBody req0 C.$$ C.consume)
muser <- withManager $ checkAssertion audience (T.decodeUtf8 $ assertion)
case muser of
Nothing -> return $ responseLBS status401 [] ""
Just usr -> let hmac = T.pack $ showDigest $ hmacSha1 key
(L8.fromStrict . T.encodeUtf8 $ usr)
in return $ responseLBS status200
[ ("Set-Cookie", setCookie "_hails_user" usr)
, ("Set-Cookie", setCookie "_hails_user_hmac" hmac)]
""
_ | doLogout -> return $ responseLBS status200
[ ("Set-Cookie", delCookie "_hails_user")
, ("Set-Cookie", delCookie "_hails_user_hmac")]
""
_ ->
let mauth = do cookies <- parseCookies `liftM`
(lookup "Cookie" $ requestHeaders req0)
usr <- lookup "_hails_user" cookies
hmac0 <- lookup "_hails_user_hmac" cookies
let hmac1 = showDigest $ hmacSha1 key $ L8.fromStrict usr
return (usr, hmac0 == S8.pack hmac1)
req = case mauth of
Just (usr, True) -> req0 { requestHeaders =
("X-Hails-User", usr)
:(requestHeaders req0) }
_ -> req0
in requireLoginMiddleware (return $ respRedir req) app0 req
where doLogin = isJust $ lookup "X-Hails-Persona-Login" $ requestHeaders req0
doLogout = isJust $ lookup "X-Hails-Persona-Logout" $ requestHeaders req0
setCookie n v = toByteString . renderSetCookie $ def {
setCookieName = n
, setCookiePath = Just "/"
, setCookieValue = T.encodeUtf8 v }
delCookie n = toByteString . renderSetCookie $ def {
setCookieName = n
, setCookiePath = Just "/"
, setCookieValue = "deleted"
, setCookieExpires = Just $ UTCTime (toEnum 0) 0 }
respRedir req =
let cookie = toByteString . renderSetCookie $ def
{ setCookieName = "redirect_to"
, setCookiePath = Just "/"
, setCookieValue = rawPathInfo req }
in responseLBS status302
[ ("Set-Cookie", cookie)
, ("Location", (T.encodeUtf8 audience) `S8.append` "/login") ] ""
openIdAuth :: T.Text
-> Middleware
openIdAuth openIdUrl app0 req0 = do
case pathInfo req0 of
"_hails":"logout":_ -> do
let cookie = toByteString . renderSetCookie $ def
{ setCookieName = "hails_session"
, setCookiePath = Just "/"
, setCookieValue = "deleted"
, setCookieExpires = Just $ UTCTime (toEnum 0) 0}
let redirectTo = fromMaybe "/" $ lookup "Referer" $ requestHeaders req0
return $ responseLBS status302 [ ("Set-Cookie", cookie)
, ("Location", redirectTo)] ""
"_hails":"login":_ -> do
let qry = map (\(n,v) -> (n, fromJust v)) $ filter (isJust . snd) $
parseQueryText $ rawQueryString req0
oidResp <- withManager $ authenticateClaimed qry
liftIO $ print $ oirParams oidResp
let cookie = toByteString . renderSetCookie $ def
{ setCookieName = "hails_session"
, setCookiePath = Just "/"
, setCookieValue = S8.pack . T.unpack . identifier . oirOpLocal $ oidResp }
let redirectTo = fromMaybe "/" $ do
rawCookies <- lookup "Cookie" $ requestHeaders req0
lookup "redirect_to" $ parseCookies rawCookies
return $ responseLBS status200 ([ ("Set-Cookie", cookie)
, ("Location", redirectTo)])
(L8.pack $ show qry)
_ -> do
let req = fromMaybe req0 $ do
rawCookies <- lookup "Cookie" $ requestHeaders req0
user <- lookup "hails_session" $ parseCookies rawCookies
return $ req0 { requestHeaders =
("X-Hails-User", user):(requestHeaders req0)
}
let redirectResp = do
let returnUrl = T.pack . S8.unpack $ requestToUri req "/_hails/login"
url <- withManager $ getForwardUrl openIdUrl returnUrl Nothing
[ ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ax.required", "email")]
let cookie = toByteString . renderSetCookie $ def
{ setCookieName = "redirect_to"
, setCookiePath = Just "/_hails/"
, setCookieValue = rawPathInfo req }
return $ responseLBS status302 [ ("Location", (S8.pack . T.unpack $ url))
, ("Set-Cookie", cookie)] ""
requireLoginMiddleware redirectResp app0 req
requireLoginMiddleware :: ResourceT IO Response -> Middleware
requireLoginMiddleware loginResp app0 req = do
appResp <- app0 req
if hasLogin appResp && notLoggedIn
then loginResp
else return appResp
where hasLogin r = "X-Hails-Login" `isIn` responseHeaders r
notLoggedIn = not $ "X-Hails-User" `isIn` requestHeaders req
isIn n xs = isJust $ lookup n xs
responseHeaders :: Response -> ResponseHeaders
responseHeaders (ResponseFile _ hdrs _ _) = hdrs
responseHeaders (ResponseBuilder _ hdrs _) = hdrs
responseHeaders (ResponseSource _ hdrs _) = hdrs
getBasicAuthUser :: Request -> Maybe S8.ByteString
getBasicAuthUser req = do
authStr <- lookup hAuthorization $ requestHeaders req
unless ("Basic" `S8.isPrefixOf` authStr) $ fail "Not basic auth."
let up = fmap (S8.split ':') $ decode $ S8.drop 6 authStr
case up of
Right (user:_:[]) -> return user
_ -> fail "Malformed basic auth header."
requestToUri :: Request -> S8.ByteString -> S8.ByteString
requestToUri req path = S8.concat $
[ "http"
, if isSecure req then "s://" else "://"
, serverName req
, if serverPort req `notElem` [80, 443] then portBS else ""
, path ]
where portBS = S8.pack $ ":" ++ show (serverPort req)
externalAuth :: L8.ByteString -> String -> Middleware
externalAuth key url app req = do
let mreqAuth = do
cookieHeaders <- lookup hCookie $ requestHeaders req
let cookies = parseCookies cookieHeaders
mac0 <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user_hmac" cookies
user <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user" cookies
let mac1 = showDigest $ hmacSha1 key (lazyfy user)
if S8.unpack mac0 == mac1
then Just $ req { requestHeaders = ("X-Hails-User", user)
: requestHeaders req }
else Nothing
req0 = maybe req id mreqAuth
requireLoginMiddleware redirectResp app req0
where redirectResp = return $ responseLBS status302
[(hLocation, S8.pack url)] ""
lazyfy = L8.fromChunks . (:[])