content: {-# LANGUAGE Trustworthy #-}
  {-# LANGUAGE FlexibleInstances,
               MultiParamTypeClasses,
               FlexibleContexts #-}
  {- |
  
  Exports basic HTTP client functions inside the 'DC' Monad.
  Computations are allowed to communicate over HTTP as long as they can
  read and write to a labeled origin. An origin is associated with two
  labels. When writing, the origin has a label of the form
  @\< \"scheme:\/\/authority\", |True \>@, where @scheme@ is
  either \'http\' or \'https\', and @authority@ is the domain name or IP
  address used in the request and port number of the connection. In
  other words, the secrecy component contains the origin information,
  while the integrity component is the same as that of public data.
  When reading, the origin has a label of the form
  @\< |True, \"scheme:\/\/authority\" \>@.
  
  This means that 'DC' computations can export data if the current label
  is not higher than that of the labeled origin, and read data that is
  no more trustworthy than that of the origin.  Practically, this means
  that untrusted computation can export data so long as the they have
  not observed any data more sensitive than the label of the target
  domain. Reading (which also occurs on every request/write) further
  raises the current label to the join of the current label and origin.
                                              
  For example, suppose some piece of data, @myLoc@, has the label:
  
  > aliceLocL = dcLabel ("alice" /\ "http://maps.googleapis.com:80") dcTrue
  
  created as:
  
  > myLoc <- labelP alicePriv  aliceLocL "3101 24th Street, San Francisco, CA"
  
  
  Then, untrusted code (with initial label set to public) running on
  behalf of \"alice\" , may perform the following operation:
  
  > let mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false"
  > aliceLoc <- unlabelP alicePriv myLoc
  > resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc
  
  In this case the 'unlabelP' will raise the current label to the label:
  
  > < "http://maps.googleapis.com:80", |True >
  
  by exercising \"alice\"s privilges.  Directly, the 'simpleHttp'
  will be permitted. However, if
  
  > let mapBase = "http://maps.evilalternatives.org/geocode/json?sensor=false"
  
  an exception will be thrown since the current label does not flow to
  the label of @mapBase@.
  
  
  
  This module uses 'http-conduit' as the underlying client, we recommend
  looking at the "Network.HTTP.Conduit" documentation on how to
  construct 'C.Request's. Here, we highlight some important details:
  
  * The headers @Content-Length@ and @Host@ are automatically set, and
    should not be added to 'requestHeaders'.
  
  * By default, the functions in this package will /not/ throw
    exceptions for non-2xx status codes. If you would like to use the
    default http-conduit behavior, you should use 'checkStatus', e.g.:
  
  >  req <- parseUrl mapBase
  >  resp <- simpleGetHttp $ req { checkStatus = \s@(Status sci _) hs ->
  >            if 200 <= sci && sci < 300
  >                then Nothing
  >                else Just $ toException $ StatusCodeException s hs }
  
  -}
  
  module Hails.HttpClient (
      -- * Request type
      Request
    , method, secure, host, port, path, queryString
    , requestHeaders
    , requestBody, rawBody
    , redirectCount
    , checkStatus, decompress
    , module Network.HTTP.Types
      -- * Response type
    , Response(..)
      -- * Simple HTTP interface
    , parseUrl
    , applyBasicAuth
    , simpleHttp, simpleHttpP
    , simpleGetHttp, simpleGetHttpP
    , simpleHeadHttp, simpleHeadHttpP
    -- * Exceptions
    , HttpException(..)
    ) where
  
  import qualified Data.ByteString.Char8 as S8
  import           Data.Monoid
                                
  import           Control.Monad.Catch
  
  import qualified Network.HTTP.Conduit as C
  import           Network.HTTP.Conduit (
                       method, secure, host, port, path, queryString
                     , requestHeaders
                     , requestBody, rawBody
                     , redirectCount
                     , checkStatus, decompress
                     , proxy
                     , applyBasicAuth
                     , HttpException(..)
                     )
  import           Hails.HttpServer (Response(..))
  import           Network.HTTP.Types
  
  import           LIO
  import           LIO.TCB
  import           LIO.DCLabel
  
  
  -- | Reques type, wrapper for the conduit 'C.Request'.
  type Request = C.Request
  
  --
  -- Basic functions
  --
  
  -- | Perform a simple HTTP(S) request.
  simpleHttp :: Request  -- ^ Request
             -> DC Response
  simpleHttp = simpleHttpP noPrivs
  
  -- | Same as 'simpleHttp', but uses privileges.
  simpleHttpP :: PrivDesc DCLabel p
              => Priv p      -- ^ Privilege
              -> Request     -- ^ Request
              -> DC Response
  simpleHttpP p req' = do
    let req = req' { proxy = Nothing }
    guardWriteURLP p req
    resp <- ioTCB $ C.withManager $ C.httpLbs req
    return $ Response { respStatus  = C.responseStatus resp
                      , respHeaders = C.responseHeaders resp
                      , respBody    = C.responseBody resp
                      }
  
  -- 
  -- Simple HEAD/GET Wrappers
  --
  
  -- | Simple HTTP GET request.
  simpleGetHttpP :: DCPriv     -- ^ Privilege
                 -> String     -- ^ URL
                 -> DC Response
  simpleGetHttpP p url = do
    req <- parseUrl url
    simpleHttpP p req
  
  -- | Simple HTTP GET request.
  simpleGetHttp :: String -> DC Response
  simpleGetHttp = simpleGetHttpP mempty
  
  -- | Simple HTTP HEAD request.
  simpleHeadHttpP :: DCPriv     -- ^ Privilege
                  -> String     -- ^ URL
                  -> DC Response
  simpleHeadHttpP p url = do
    req <- parseUrl url
    simpleHttpP p $ req { method = methodHead }
  
  -- | Simple HTTP HEAD request.
  simpleHeadHttp :: String -> DC Response
  simpleHeadHttp = simpleHeadHttpP mempty
  
  
  --
  -- Misc
  --
  
  -- | Check that current label can flow to label of request.
  guardWriteURLP :: PrivDesc DCLabel p => Priv p -> Request -> DC ()
  guardWriteURLP p req = do
    let (lr, lw) = labelOfReq req
    guardAllocP p lr
    taintP p lw
  
  -- | Return the labels corresponding to the absolute URI of a request header.
  -- The created labels will have the scheme and authority (including port) in the
  -- secrecy componenet, and @|True@ in the integrity component for the
  -- read label (and the dual for write label). Specifically, the
  -- labels will have the form:
  --
  --  > (< scheme://authority, |True >,< |True, scheme://authority >)
  --
  --  For example, the read label of a request to \"http:\/\/gitstar.com/\" is:
  -- 
  --  > <  "http://gitstar.com:80" , |True>
  --
  --  while the read label of \"https:\/\/gitstar.com:444/\"
  --
  --  > <  "https://gitstar.com:444" , |True>
  --
  -- This should be used for only for single-connection requests, where the
  -- absolute URL makes senes.
  labelOfReq :: Request -> (DCLabel, DCLabel)
  labelOfReq req =
    let scheme = if secure req then (S8.pack "https://") else (S8.pack "http://")
        prin = principalBS $ S8.concat [scheme, host req, S8.pack ":", S8.pack $ show (port req)]
    in (prin %% True, True %% prin)
  
  -- | Convert a URL into a 'Request'.
  --
  -- This defaults some of the values in 'Request', such as setting
  -- method to GET and 'requestHeaders' to [].
  --
  parseUrl :: String -> DC Request
  parseUrl = C.parseUrl
  
  instance MonadThrow (LIO DCLabel) where
    throwM = throwLIO
  