content: {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE OverloadedStrings #-}
  {- |
  
  This module exports generic definitions for Wai-authentication pipelines
  in Hails.  'requireLoginMiddleware' looks for the @X-Hails-Login@
  header from an 'Application' \'s 'Response' and, if present, responds to
  the user with an authentication request instead of the 'Application'
  response (e.g., a redirect to a login page or an HTTP response with
  status 401). 
  
  Additionally, this module exports authentication 'Middleware's for basic HTTP
  authentication, 'devBasicAuth', (useful in development environments)
  and federated (OpenID) authentication, 'openIdAuth'. In general,
  authentication 'Middleware's are expected to set the @X-Hails-User@
  header on the request if it is from an authenticated user.
  
  -}
  module Hails.HttpServer.Auth
    ( requireLoginMiddleware
    -- * Production
    -- ** Persona (BrowserID)
    , personaAuth
    -- ** OpenID
    , openIdAuth
    -- ** Authenticate with external app
    , externalAuth
    -- * Development: basic authentication
    , devBasicAuth
    ) where
  
  import           Control.Monad.IO.Class (liftIO)
  import           Blaze.ByteString.Builder (toByteString)
  import           Control.Monad
  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           Network.Socket
  import           Web.Authenticate.BrowserId
  import           Web.Authenticate.OpenId
  import           Web.Cookie
  
  
  -- | Basic HTTP authentication middleware for development. Accepts any username
  -- and password.
  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
  
  -- | Authentica user with Mozilla's persona.
  -- If the @X-Hails-Persona-Login@ header is set, this intercepts the
  -- request and verifies the supplied identity assertion, supplied in the
  -- request body.
  --
  -- If the authentication is successful, set the @_hails_user@ and
  -- @_hails_user_hmac@ cookies to identify the user. The former
  -- contains the user email address, the latter contains the MAC that is
  -- used for verifications in later requests.
  --
  -- If the @X-Hails-Persona-Logout@ header is set, this intercepts the
  -- request and deletes the aforementioned cookies.
  -- 
  -- If the app wishes the user to authenticate (by setting @X-Hails-Login@)
  -- this redirects to @audience/login@ -- where the app can call
  -- @navigator.request()@.
  --
  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") ] ""
  
  -- | Perform OpenID authentication.
  openIdAuth :: T.Text -- ^ OpenID Provider 
             -> 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
  
  -- | Executes the app and if the app 'Response' has header
  -- @X-Hails-Login@ and the user is not logged in, respond with an
  -- authentication response (Basic Auth, redirect, etc.)
  requireLoginMiddleware :: 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
  
  --
  -- Helpers
  --
  
  -- | Helper method for implementing basic authentication. Given a
  -- 'Request' returns the usernamepair from the basic authentication
  -- header if present.
  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."
  
  -- | Given a request and path, extract the scheme,
  -- hostname and port from the request and createand a URI
  -- @scheme://hostname[:port]/path@.
  requestToUri :: Request -> S8.ByteString -> S8.ByteString
  requestToUri req path = S8.concat $
    [ "http"
    , if isSecure req then "s://" else "://"
    , serverName
    , if serverPort `notElem` [80, 443] then portBS else ""
    , path ]
    where portBS = S8.pack $ ":" ++ show serverPort
          serverName = case lookup "Host" $ requestHeaders req of
            Just h -> h
            _      -> error "requestToUri: missing Host header"
          serverPort = case remoteHost req of
            SockAddrInet no _ -> no
            SockAddrInet6 no _ _ _ -> no
            _ -> error "requestToUri: invalid socket type"
  
  
  -- Cookie authentication
  --
  
  -- | Use an external authentication service that sets cookies.
  -- The cookie names are @_hails_user@, whose contents contains the
  -- @user-name@, and @_hails_user_hmac@, whose contents contains
  -- @HMAC-SHA1(user-name)@. This function simply checks that the cookie
  -- exists and the MAC'd user name is correct. If this is the case, it
  -- returns a request with the cookie removed and @x-hails-user@ header
  -- set. Otherwies the original request is returned.
  -- The login service retuns a redirect (to the provided url).
  -- Additionally, cookie @_hails_refer$ is set to the current
  -- URL (@scheme://domain:port/path@).
  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 . (:[])
  
  