diff --git a/Hails/Data/Hson.hs b/Hails/Data/Hson.hs --- a/Hails/Data/Hson.hs +++ b/Hails/Data/Hson.hs @@ -104,7 +104,7 @@ import Data.Functor.Identity (runIdentity) import qualified Data.Bson as Bson -import Data.Conduit (runResourceT, ($$)) +import Data.Conduit (($$)) import Data.Conduit.Binary (sourceLbs) import LIO @@ -325,7 +325,7 @@ labeledRequestToHson lreq = liftLIO $ do let (LabeledTCB origLabel req) = lreq btype = fromMaybe UrlEncoded $ getRequestBodyType req - (ps, fs) <- liftLIO . ioTCB $ runResourceT $ + (ps, fs) <- liftLIO . ioTCB $ sourceLbs (requestBody req) $$ sinkRequestBody lbsBackEnd btype let psDoc = map convertPS ps fsDoc = map convertFS fs diff --git a/Hails/HttpClient.hs b/Hails/HttpClient.hs --- a/Hails/HttpClient.hs +++ b/Hails/HttpClient.hs @@ -95,7 +95,6 @@ ) where import qualified Data.ByteString.Char8 as S8 -import qualified Data.Conduit as C import Data.Monoid import Control.Failure @@ -108,7 +107,7 @@ , requestBody, rawBody , redirectCount , checkStatus, decompress - , proxy, socksProxy + , proxy , applyBasicAuth , HttpException(..) ) @@ -121,7 +120,7 @@ -- | Reques type, wrapper for the conduit 'C.Request'. -type Request = C.Request (C.ResourceT IO) +type Request = C.Request -- -- Basic functions @@ -138,7 +137,7 @@ -> Request -- ^ Request -> DC Response simpleHttpP p req' = do - let req = req' { proxy = Nothing, socksProxy = Nothing } + let req = req' { proxy = Nothing } guardWriteURLP p req resp <- ioTCB $ C.withManager $ C.httpLbs req return $ Response { respStatus = C.responseStatus resp diff --git a/Hails/HttpServer.hs b/Hails/HttpServer.hs --- a/Hails/HttpServer.hs +++ b/Hails/HttpServer.hs @@ -62,7 +62,7 @@ -- 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 -> ResourceT IO Request +waiToHailsReq :: W.Request -> IO Request waiToHailsReq req = do curTime <- liftIO getCurrentTime body <- fmap L.fromChunks $ W.requestBody req $$ consume @@ -70,15 +70,17 @@ , httpVersion = W.httpVersion req , rawPathInfo = W.rawPathInfo req , rawQueryString = W.rawQueryString req - , serverName = W.serverName req - , serverPort = W.serverPort 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 diff --git a/Hails/HttpServer/Auth.hs b/Hails/HttpServer/Auth.hs --- a/Hails/HttpServer/Auth.hs +++ b/Hails/HttpServer/Auth.hs @@ -32,7 +32,6 @@ 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) @@ -47,6 +46,7 @@ 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 @@ -186,7 +186,7 @@ -- | 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 :: ResourceT IO Response -> Middleware +requireLoginMiddleware :: IO Response -> Middleware requireLoginMiddleware loginResp app0 req = do appResp <- app0 req if hasLogin appResp && notLoggedIn @@ -196,12 +196,6 @@ notLoggedIn = not $ "X-Hails-User" `isIn` requestHeaders req isIn n xs = isJust $ lookup n xs --- | Get the hreaders from a response. -responseHeaders :: Response -> ResponseHeaders -responseHeaders (ResponseFile _ hdrs _ _) = hdrs -responseHeaders (ResponseBuilder _ hdrs _) = hdrs -responseHeaders (ResponseSource _ hdrs _) = hdrs - -- -- Helpers -- @@ -225,10 +219,17 @@ requestToUri req path = S8.concat $ [ "http" , if isSecure req then "s://" else "://" - , serverName req - , if serverPort req `notElem` [80, 443] then portBS else "" + , serverName + , if serverPort `notElem` [80, 443] then portBS else "" , path ] - where portBS = S8.pack $ ":" ++ show (serverPort req) + 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 diff --git a/Hails/HttpServer/Types.hs b/Hails/HttpServer/Types.hs --- a/Hails/HttpServer/Types.hs +++ b/Hails/HttpServer/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} module Hails.HttpServer.Types ( -- * Requests Request(..) @@ -16,6 +16,7 @@ import qualified Data.List as List import Data.Text (Text) +import Data.Typeable import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L @@ -48,11 +49,6 @@ -- Backends are free to provide alternative values as necessary. This value -- should not be used to construct URLs. , serverName :: S.ByteString - -- | The listening port that the server received this request on. It is - -- possible for a server to listen on a non-numeric port (i.e., Unix named - -- socket), in which case this value will be arbitrary. Like 'serverName', - -- this value should not be used in URL construction. - , serverPort :: Int -- | The request headers. , requestHeaders :: RequestHeaders -- | Was this request made over an SSL connection? @@ -68,7 +64,7 @@ , requestBody :: L.ByteString -- | Time request was received. , requestTime :: UTCTime - } deriving Show + } deriving (Show, Typeable) -- | Get the request body type (copied from @wai-extra@). getRequestBodyType :: Request -> Maybe RequestBodyType @@ -115,7 +111,7 @@ , respHeaders :: ResponseHeaders -- | Response body , respBody :: L.ByteString - } deriving Show + } deriving (Show, Typeable) -- | Add/replace a 'Header' to the 'Response' addResponseHeader :: Response -> Header -> Response @@ -140,7 +136,7 @@ , requestLabel :: DCLabel -- | A privilege minted for the app. , appPrivilege :: DCPriv - } deriving Show + } deriving (Show, Typeable) -- | Base Hails type implemented by untrusted applications. type Application = RequestConfig -> DCLabeled Request -> DC Response diff --git a/Hails/Web/Controller.hs b/Hails/Web/Controller.hs --- a/Hails/Web/Controller.hs +++ b/Hails/Web/Controller.hs @@ -14,6 +14,8 @@ module Hails.Web.Controller ( Controller, ControllerState(..) , request + , requestConfig + , appPriv , requestHeader , body , queryParam @@ -37,7 +39,8 @@ data ControllerState = ControllerState { csRequest :: DCLabeled Request - , csPathParams :: Query } + , csPathParams :: Query + , csReqConfig :: RequestConfig } -- | A controller is simply a reader monad atop 'DC' with the 'Labeled' -- 'Request' as the environment. @@ -47,12 +50,18 @@ liftLIO = lift instance Routeable (Controller Response) where - runRoute controller _ eq _ req = fmap Just $ - runReaderT controller $ ControllerState req eq + runRoute controller _ eq conf req = fmap Just $ + runReaderT controller $ ControllerState req eq conf -- | Get the underlying request. request :: Controller (DCLabeled Request) request = fmap csRequest ask + +requestConfig :: Controller RequestConfig +requestConfig = fmap csReqConfig ask + +appPriv :: Controller DCPriv +appPriv = fmap appPrivilege requestConfig -- | Get the underlying request. pathParams :: Controller [(S8.ByteString, Maybe S8.ByteString)] diff --git a/Hails/Web/Router.hs b/Hails/Web/Router.hs --- a/Hails/Web/Router.hs +++ b/Hails/Web/Router.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances #-} {- | diff --git a/hails.cabal b/hails.cabal --- a/hails.cabal +++ b/hails.cabal @@ -1,5 +1,5 @@ Name: hails -Version: 0.11.0.0 +Version: 0.11.1.0 build-type: Simple License: GPL-2 License-File: LICENSE @@ -83,17 +83,17 @@ Source-repository head Type: git - Location: ssh://git@github.com.com/scslab/hails.git + Location: git://github.com/scslab/hails.git Library Build-Depends: - base >= 4.5 && < 5.0 + base < 6 ,transformers ,mtl ,containers ,bytestring - ,text >= 0.11.3.0 + ,text ,parsec ,binary ,time @@ -105,7 +105,7 @@ ,conduit ,resourcet ,http-conduit - ,wai + ,wai >= 2.1 ,wai-app-static ,wai-extra ,http-types @@ -149,7 +149,7 @@ Main-is: hails.hs ghc-options: -package ghc -Wall -fno-warn-orphans Build-Depends: - base >= 4.5 && < 5.0 + base < 6 ,transformers ,mtl ,containers @@ -166,7 +166,7 @@ ,conduit ,resourcet ,http-conduit - ,wai + ,wai >= 2.1 ,wai-extra ,wai-app-static ,warp @@ -179,6 +179,7 @@ ,unix ,ghc-paths ,SHA + ,hint ,hails test-suite tests diff --git a/hails.hs b/hails.hs --- a/hails.hs +++ b/hails.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where +import Control.Exception import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 @@ -11,6 +12,8 @@ import Data.Version import Control.Monad +import LIO +import LIO.DCLabel import Hails.HttpServer import Hails.HttpServer.Auth import Hails.Version @@ -28,11 +31,8 @@ import System.Exit -import GHC -import GHC.Paths -import DynFlags -import Unsafe.Coerce - +import Language.Haskell.Interpreter +import Language.Haskell.Interpreter.Extension about :: String -> String @@ -93,8 +93,9 @@ _ | isJust (optExternal opts) -> external -- dev mode: _ -> devBasicAuth - app <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts) - runSettings (defaultSettings { settingsPort = port }) $ + dcApp <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts) + app <- evalDC $ setClearance dcPublic >> dcApp + runSettings (setPort port defaultSettings) $ logMiddleware $ execHailsApplication authMiddleware app @@ -103,35 +104,24 @@ loadApp :: Bool -- -XSafe ? -> Maybe FilePath -- -package-db -> String -- Application name - -> IO Application -loadApp safe mpkgDb appName = runGhc (Just libdir) $ do - dflags0 <- getSessionDynFlags - let dflags1 = if safe - then dopt_set (dflags0 { safeHaskell = Sf_Safe }) - Opt_PackageTrust - else dflags0 - dflags2 = case mpkgDb of -#if MIN_VERSION_base(4,6,0) - Just pkgDb -> - dflags1 { extraPkgConfs = (PkgConfFile pkgDb:)} -#else - Just pkgConf -> - dopt_unset (dflags1 { extraPkgConfs = - pkgConf : extraPkgConfs dflags1 }) - Opt_ReadUserPackageConf -#endif - _ -> dflags1 - void $ setSessionDynFlags dflags2 - target <- guessTarget appName Nothing - addTarget target - r <- load LoadAllTargets - case r of - Failed -> fail "Compilation failed." - Succeeded -> do - setContext [IIDecl $ simpleImportDecl (mkModuleName appName)] - value <- compileExpr (appName ++ ".server") - return . unsafeCoerce $ value - + -> IO (DC Application) +loadApp safe mpkgDb appName = do + case mpkgDb of + Just pkgDb -> setEnv "GHC_PACKAGE_PATH" pkgDb True + Nothing -> return () + eapp <- runInterpreter $ do + when safe $ + set [languageExtensions := [asExtension "Safe"]] + loadModules [appName] + setImports ["Prelude", "LIO", "LIO.DCLabel", "Hails.HttpServer", appName] + entryFunType <- typeOf "server" + if entryFunType == "DC Application" then + interpret "server" (undefined :: DC Application) + else + interpret "return server" (undefined :: DC Application) + case eapp of + Left err -> throwIO err + Right app -> return app -- -- Parsing options