module Hails.HttpServer.Auth
( requireLoginMiddleware
, openIdAuth
, 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 qualified Data.Text as T
import Data.Maybe (fromMaybe, isJust, fromJust)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import Network.HTTP.Conduit (withManager)
import Network.HTTP.Types
import Network.Wai
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
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)