{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE OverloadedStrings #-}
{- |

This module exports the core of the Hails HTTP server. Specifically it
defines basic types, such as HTTP 'Request' and 'Response', used by
the Hails web server and untrusted Hails 'Application's. 

At a high level, a Hails 'Application', is a function from 'Request'
to 'Response' in the 'DC' monad. Every application response is
sanitized and sanity checked with the 'secureApplication'
'Middleware'. Moreover, every 'Request' is sanitized with 'sanitizeReq'
before handed over to authenticators.

Hails uses Wai, and as such we provide a function for converting
Hails 'Application's to Wai 'W.Applicatoin's: 'execHailsApplication'.

-}
module Hails.HttpServer (
  module Hails.HttpServer.Types
  -- ** Execute Hails application
  , execHailsApplication
  -- ** Middleware used by Hails
  , sanitizeReqMiddleware
  , browserLabelGuard
  , guardSensitiveResp 
  , sanitizeResp
  , catchAllExceptions
  -- * Network types
  , module Network.HTTP.Types
  ) where

import qualified Data.List as List
import qualified Data.Set as Set
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import           Data.Conduit
import           Data.Conduit.List hiding (head)
import           Data.Monoid

import           Control.Monad (liftM)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Error.Class


import           Network.HTTP.Types
import           Network.URI (isURI)
import qualified Network.Wai as W
import qualified Network.Wai.Application.Static as W
import           Network.Wai.Middleware.MethodOverridePost

import           LIO
import           LIO.TCB
import           LIO.DCLabel

import           Hails.HttpServer.Types

import           System.IO
import           Data.Time (getCurrentTime)

-- | Convert a WAI 'W.Request' to a Hails 'Request' by consuming the
-- body into a 'L.ByteString'. The 'requestTime' is set to the
-- current time at the time this action is executed (which is when
-- the app is invoked).
waiToHailsReq :: W.Request -> IO Request
waiToHailsReq req = do
  curTime <- liftIO getCurrentTime
  body <- fmap L.fromChunks $ W.requestBody req $$ consume
  return $ Request { requestMethod = W.requestMethod req
                   , httpVersion = W.httpVersion req
                   , rawPathInfo = W.rawPathInfo req
                   , rawQueryString = W.rawQueryString req
                   , requestHeaders = W.requestHeaders req
                   , isSecure = W.isSecure req
                   , remoteHost = W.remoteHost req
                   , serverName = sN
                   , pathInfo = W.pathInfo req
                   , queryString = W.queryString req
                   , requestBody = body 
                   , requestTime = curTime }
  where sN = case lookup "Host" $ W.requestHeaders req of
          Just h -> h
          _      -> error "requestToUri: missing Host header"

-- | Remove any unsafe headers, in this case only @X-Hails-User@.
sanitizeReqMiddleware :: W.Middleware
sanitizeReqMiddleware app req =  app $ req { W.requestHeaders = headers }
  where headers = List.filter ((/= "X-Hails-User") . fst) $ W.requestHeaders req

-- | Convert a Hails 'Response' to a WAI 'W.Response'
hailsToWaiResponse :: Response -> W.Response
hailsToWaiResponse (Response stat rhd body) = W.responseLBS stat rhd body

-- | Hails 'Middleware' that ensures the 'Response' from the
-- application is readable by the client's browser (as determined by the
-- result label of the app computation and the label of the browser). If
-- the response is not readable by the browser, the middleware sends a
-- 403 (unauthorized) response instead.
browserLabelGuard :: Middleware
browserLabelGuard hailsApp conf req = do
  response <- hailsApp conf req
  resultLabel <- getLabel
  return $ if resultLabel `canFlowTo` (browserLabel conf)
             then response
             else Response status403 [] ""

-- | Adds the header @Content-Security-Policy@ to the response, if the
-- label of the computation does not flow to the public label,
-- 'dcPublic'.  The @default-src@ directive is set to the secrecy
-- component of the response label (if it is a disjunction
-- of principals). Currently, @'self'@ is always added to the
-- whitelist. An example may be:
--
-- > Content-Security-Policy: default-src 'self' http://google.com:80 https://a.lvh.me:3000;
--
guardSensitiveResp :: Middleware
guardSensitiveResp app config req = do
  response <- (flip removeResponseHeader) csp `liftM` app config req
  resultLabel <- getLabel
  return $ if resultLabel `canFlowTo` dcPublic
    then response
    else addResponseHeader response $
          ( csp
          , "default-src " <> headerVal resultLabel <> ";")
      where csp = "Content-Security-Policy"
            headerVal l =
              let secrecy     = dcSecrecy l
                  secrecySet  = cToSet secrecy
                  uriList     = Set.filter (isURI . S8.unpack) $ 
                                Set.map principalName $ 
                                dToSet $ head $ Set.elems secrecySet
              in if secrecy == cFalse || Set.size secrecySet > 1
                   then "'self','unsafe-inline'" -- Be more flexible than 'none'
                   else S8.unwords $
                          "'self'":"'unsafe-inline'":(Set.toList uriList)

-- | Remove anything from the response that could cause inadvertant
-- declasification. Currently this only removes the @Set-Cookie@
-- header.
sanitizeResp :: Middleware
sanitizeResp hailsApp conf req = do
  response <- hailsApp conf req
  return $ foldr (\h r -> removeResponseHeader r h) response unsafeHeaders
   where unsafeHeaders = ["Set-Cookie"]

  

-- | Returns a secure Hails app such that the result 'Response' is guaranteed
-- to be safe to transmit to the client's browser. The definition is
-- straight forward from other middleware:
--
-- > secureApplication = 'browserLabelGuard'  -- Return 403, if user should not read
-- >                   . 'sanitizeResp'       -- Remove Cookies/CSP
-- >                   . 'guardSensitiveResp' -- Add CSP if not public
secureApplication :: Middleware
secureApplication = browserLabelGuard  -- Return 403, if user should not read
                  . sanitizeResp       -- Remove Cookies and X-Hails-Sensitive
                  . guardSensitiveResp -- Add CSP if not public

-- | Catch all exceptions thrown by middleware and return 500.
catchAllExceptions :: W.Middleware
catchAllExceptions app req = app req `catchError` (const $ return resp500)
    where resp500 = W.responseLBS status500 [] "App threw an exception"

--
-- Executing Hails applications
--

-- | Execute an application, safely filtering unsafe request headers,
-- overriding method posts,  catching all exceptions, and sanitizing
-- responses.
execHailsApplication :: W.Middleware -> Application -> W.Application
execHailsApplication authMiddleware app =
    catchAllExceptions
  . sanitizeReqMiddleware
  . methodOverridePost
  . authMiddleware
  $ \req -> hailsApplicationToWai app req

-- | Safely wraps a Hails 'Application' in a Wai 'W.Application' that can
-- be run by an application server. The application is executed with the
-- 'secureApplication' 'Middleware'. The function returns status 500 if
-- the Hails application throws an exception and the label of the
-- exception flows to the browser label (see 'browserLabelGuard'); if the
-- label does not flow, it responds with a 403.
--
-- All applications serve static content from a @\"static\"@ directory.
--
-- Note: this function assumes that the request has already been sanitized.
-- In most cases, you want to use 'execHailsApplication'.
hailsApplicationToWai :: Application -> W.Application
hailsApplicationToWai app0 req0 | isStatic req0 =
  -- Is static request, serve files:
  W.staticApp (W.defaultWebAppSettings "./") req0
                                | otherwise = do
  -- Not static request, serve dynamic content:
  -- Convert request to Hails request
  hailsRequest <- waiToHailsReq req0
  -- Extract browser/request configuration
  let conf = getRequestConf hailsRequest
  (result, dcState) <- liftIO $ tryDCDef conf $ do
    let lreq = LabeledTCB (requestLabel conf) hailsRequest
    app conf lreq
  case result of
    Right response -> return $ hailsToWaiResponse response
    Left err -> do
      liftIO $ hPutStrLn stderr $ "App threw exception: " ++ show err
      return $
        if lioLabel dcState `canFlowTo` (browserLabel conf) then
          resp500
          else resp403
    where app = secureApplication app0
          isStatic req = case W.pathInfo req of
                           ("static":_) -> True
                           _            -> False
          resp403 = W.responseLBS status403 [] "" 
          resp500 = W.responseLBS status500 [] ""
          tryDCDef conf act = tryDC $ do
            putLIOStateTCB $ LIOState { lioLabel = dcPublic
                                     , lioClearance = browserLabel conf}
            act


--
-- Helper
--

-- | Get the browser label (secrecy of the user), request label (integrity of
-- the user), and application privilege (minted with the app's cannonical name)
getRequestConf :: Request -> RequestConfig
getRequestConf req =
  let headers = requestHeaders req
      muserName = principalBS `fmap` lookup "x-hails-user" headers
      appName  = "@" `S8.append` (S8.takeWhile (/= '.') $ serverName req)
      appPriv = PrivTCB $ toCNF $ principalBS appName
  in RequestConfig
      { browserLabel = maybe dcPublic (\userName -> userName %% True) muserName
      , requestLabel = maybe dcPublic (\userName -> True %% userName) muserName
      , appPrivilege = appPriv }