hails 0.11.0.0 → 0.11.1.0
raw patch · 9 files changed
+75/−77 lines, 9 filesdep +hintdep ~basedep ~textdep ~wai
Dependencies added: hint
Dependency ranges changed: base, text, wai
Files
- Hails/Data/Hson.hs +2/−2
- Hails/HttpClient.hs +3/−4
- Hails/HttpServer.hs +5/−3
- Hails/HttpServer/Auth.hs +12/−11
- Hails/HttpServer/Types.hs +5/−9
- Hails/Web/Controller.hs +12/−3
- Hails/Web/Router.hs +1/−1
- hails.cabal +8/−7
- hails.hs +27/−37
Hails/Data/Hson.hs view
@@ -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
Hails/HttpClient.hs view
@@ -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
Hails/HttpServer.hs view
@@ -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
Hails/HttpServer/Auth.hs view
@@ -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
Hails/HttpServer/Types.hs view
@@ -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
Hails/Web/Controller.hs view
@@ -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)]
Hails/Web/Router.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances #-} {- |
hails.cabal view
@@ -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
hails.hs view
@@ -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