diff --git a/Hails/Database.hs b/Hails/Database.hs --- a/Hails/Database.hs +++ b/Hails/Database.hs @@ -90,6 +90,8 @@ , Limit , BatchSize , Order(..) + -- ** Delete + , delete, deleteP ) where import Hails.Data.Hson diff --git a/Hails/Database/Query.hs b/Hails/Database/Query.hs --- a/Hails/Database/Query.hs +++ b/Hails/Database/Query.hs @@ -4,6 +4,7 @@ DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, + OverloadedStrings, TypeSynonymInstances #-} {- | @@ -38,6 +39,8 @@ , find, findP , next, nextP , findOne, findOneP + -- * Delete + , deleteP, delete -- * Query failures , DBError(..) -- * Applying policies @@ -464,6 +467,36 @@ -- comparisons. findOneP :: DCPriv -> Query -> DBAction (Maybe LabeledHsonDocument) findOneP p q = findP p q >>= nextP p + +-- +-- Delete +-- + +-- | Delete documents according to the selection. +-- It must be that the current computation can overwrite the +-- existing documents. That is, the current label must flow +-- to the label of each document that matches the selection. +delete :: Selection -> DBAction () +delete = deleteP noPriv + +-- | Same as 'delete', but uses privileges. +deleteP :: DCPriv -> Selection -> DBAction () +deleteP p sel = do + let qry = select (selectionSelector sel) (selectionCollection sel) + cur <- findP p qry + forAll cur $ \ld -> do + -- Can write to the document? + guardWriteP p (labelOf ld) + -- Delete only _this_ document, avoid TOCTTOU + let doc' = hsonDocToDataBsonDocTCB $ ["_id"] `include` (unlabelTCB ld) + -- Remove this document + execMongoActionTCB $ Mongo.deleteOne $ + Mongo.select doc' (selectionCollection sel) + where forAll cur act = do + mldoc <- nextP p cur + maybe (return ()) (\ld -> act ld >> forAll cur act) mldoc + + -- -- Helpers diff --git a/Hails/HttpServer.hs b/Hails/HttpServer.hs --- a/Hails/HttpServer.hs +++ b/Hails/HttpServer.hs @@ -28,6 +28,7 @@ , browserLabelGuard , guardSensitiveResp , sanitizeResp + , catchAllExceptions -- * Network types , module Network.HTTP.Types ) where @@ -39,6 +40,7 @@ import Data.Conduit.List import Control.Monad.IO.Class (liftIO) +import Control.Monad.Error.Class import Control.Exception (fromException) @@ -147,6 +149,12 @@ secureApplication = browserLabelGuard -- Return 403, if user should not read . guardSensitiveResp -- Add X-Hails-Sensitive if not public . sanitizeResp -- Remove Cookies + +-- | Catch all exceptions thrown by middleware and return 500. +catchAllExceptions :: W.Middleware +catchAllExceptions app req = do + app req `catchError` (const $ return resp500) + where resp500 = W.responseLBS status500 [] "App threw an exception" -- -- Executing Hails applications diff --git a/Hails/HttpServer/Auth.hs b/Hails/HttpServer/Auth.hs --- a/Hails/HttpServer/Auth.hs +++ b/Hails/HttpServer/Auth.hs @@ -18,24 +18,34 @@ -} module Hails.HttpServer.Auth ( requireLoginMiddleware - -- * Production: OpenID + -- * Production + -- ** Persona (BrowserID) + , personaAuth + -- ** OpenID , openIdAuth -- * Development: basic authentication , devBasicAuth ) where + 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) 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 Web.Authenticate.BrowserId import Web.Authenticate.OpenId import Web.Cookie @@ -52,6 +62,73 @@ : 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 diff --git a/Hails/Web/Controller.hs b/Hails/Web/Controller.hs --- a/Hails/Web/Controller.hs +++ b/Hails/Web/Controller.hs @@ -12,7 +12,7 @@ -} module Hails.Web.Controller - ( Controller + ( Controller, ControllerState(..) , request , requestHeader , body diff --git a/hails.cabal b/hails.cabal --- a/hails.cabal +++ b/hails.cabal @@ -1,5 +1,5 @@ Name: hails -Version: 0.9.2.0 +Version: 0.9.2.1 build-type: Simple License: GPL-2 License-File: LICENSE @@ -83,7 +83,7 @@ Source-repository head Type: git - Location: ssh://anonymous@gitstar.com/scs/lio.git + Location: ssh://anonymous@gitstar.com/scs/hails.git Library @@ -92,7 +92,7 @@ ,transformers >= 0.2.2 ,mtl >= 2.0 ,containers >= 0.4.2 - ,bytestring >= 0.9 + ,bytestring >= 0.10 ,text >= 0.11 ,parsec >= 3.1.2 ,binary >= 0.5 @@ -112,7 +112,8 @@ ,authenticate >= 1.3 ,cookie >= 0.4 ,blaze-builder >= 0.3.1 - ,failure >= 0.2.0.1 && < 0.3 + ,failure >= 0.2.0.1 + ,SHA >= 1.5.0.0 GHC-options: -Wall -fno-warn-orphans @@ -177,6 +178,7 @@ ,filepath >= 1.3 ,unix >= 2.5.1 ,ghc-paths >= 0.1.0.8 + ,SHA >= 1.5.0.0 ,hails test-suite tests diff --git a/hails.hs b/hails.hs --- a/hails.hs +++ b/hails.hs @@ -2,9 +2,11 @@ module Main (main) where import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.Text as T import Data.List (isPrefixOf, isSuffixOf) +import qualified Data.List as List import Data.Maybe import Data.Version import Control.Monad @@ -78,13 +80,20 @@ putStrLn $ "Working environment:\n\n" ++ optsToEnvStr opts forM_ (optsToEnv opts) $ \(k,v) -> setEnv k v True let port = fromJust $ optPort opts - provider = T.pack . fromJust . optOpenID $ opts - f = if optDev opts - then logStdoutDev . devHailsApplication - else logStdout . (openIdAuth provider) . hailsApplicationToWai + hmac_key = L8.pack . fromJust $ optHmacKey opts + persona = personaAuth hmac_key $ T.pack . fromJust . optPersonaAud $ opts + openid = openIdAuth $ T.pack . fromJust . optOpenID $ opts + prodHailsApplication = if (isJust $ optPersonaAud opts) + then persona else openid + f = case () of + _ | optDev opts && + (isJust (optPersonaAud opts) || isJust (optOpenID opts) ) -> + logStdoutDev . prodHailsApplication . hailsApplicationToWai + _ | optDev opts -> logStdoutDev . devHailsApplication + _ -> logStdout . prodHailsApplication . hailsApplicationToWai app <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts) runSettings (defaultSettings { settingsPort = port }) - (methodOverridePost $ f app) + (catchAllExceptions $ methodOverridePost $ f app) -- | Given an application module name, load the main controller named @@ -135,6 +144,8 @@ , optForce :: Bool -- ^ Force unsafe in production , optDev :: Bool -- ^ Development/Production , optOpenID :: Maybe String -- ^ OpenID provider + , optHmacKey :: Maybe String -- ^ HMAC cookie key + , optPersonaAud :: Maybe String -- ^ Persona audience , optDBConf :: Maybe String -- ^ Filepath of databases conf file , optPkgConf :: Maybe String -- ^ Filepath of package-conf , optMongoServer :: Maybe String -- ^ MongoDB server URL @@ -152,6 +163,8 @@ , optForce = False , optDev = True , optOpenID = Nothing + , optHmacKey = Nothing + , optPersonaAud = Nothing , optDBConf = Nothing , optPkgConf = Nothing , optCabalDev = Nothing @@ -168,7 +181,9 @@ , optSafe = True , optForce = False , optDev = True - , optOpenID = Just "http://localhost" + , optOpenID = Nothing + , optHmacKey = Just "hails-d34adb33f-key" + , optPersonaAud = Nothing , optDBConf = Just "database.conf" , optPkgConf = Nothing , optCabalDev = Nothing @@ -191,10 +206,16 @@ "Development mode, default (no authentication)." , GetOpt.Option [] ["prod", "production"] (NoArg (\opts -> opts { optDev = False })) - "Production mode (OpenID authentication). Must set OPENID_PROVIDER." + "Production mode (Persona/OpenID authentication). Must set OPENID_PROVIDER or PERSONA_AUDIENCE." , GetOpt.Option [] ["openid-provider"] (ReqArg (\u o -> o { optOpenID = Just u }) "OPENID_PROVIDER") "Set OPENID_PROVIDER as the OpenID provider." + , GetOpt.Option [] ["persona-audience"] + (ReqArg (\u o -> o { optPersonaAud = Just u }) "PERSONA_AUDIENCE") + "Set PERSONA_AUDIENCE as the persona audience (webserver sheme://host:prot)." + , GetOpt.Option [] ["hmac-key"] + (ReqArg (\u o -> o { optHmacKey = Just u }) "HMAC_KEY") + "Set HMAC_KEY as the MAC key for cookies." , GetOpt.Option [] ["unsafe"] (NoArg (\opts -> opts { optSafe = False })) "Turn the -XSafe flag off." @@ -246,6 +267,8 @@ p@(Just _) -> p _ -> optPort opts , optOpenID = mFromEnvOrOpt "OPENID_PROVIDER" optOpenID + , optPersonaAud = mFromEnvOrOpt "PERSONA_AUDIENCE" optPersonaAud + , optHmacKey = mFromEnvOrOpt "HMAC_KEY" optHmacKey , optDBConf = mFromEnvOrOpt "DATABASE_CONFIG_FILE" optDBConf , optPkgConf = mFromEnvOrOpt "PACKAGE_CONF" optPkgConf , optCabalDev = mFromEnvOrOpt "CABAL_DEV_SANDBOX" optCabalDev @@ -273,6 +296,8 @@ let opts1 = opts0 { optName = mergeMaybe optName , optPort = mergeMaybe optPort , optOpenID = mergeMaybe optOpenID + , optPersonaAud = mergeMaybe optPersonaAud + , optHmacKey = mergeMaybe optHmacKey , optDBConf = mergeMaybe optDBConf , optMongoServer = mergeMaybe optMongoServer } case (optPkgConf opts1, optCabalDev opts1) of @@ -291,11 +316,16 @@ -- exist. cleanProdOpts :: Options -> IO Options cleanProdOpts opts0 = do - checkIsJust optName "APP_NAME" - checkIsJust optPort "PORT" - checkIsJust optOpenID "OPENID_PROVIDER" - checkIsJust optDBConf "DATABASE_CONFIG_FILE" - checkIsJust optMongoServer "HAILS_MONGODB_SERVER" + checkIsJust [(optName ,"APP_NAME" )] + checkIsJust [(optPort ,"PORT" )] + checkIsJust [(optOpenID ,"OPENID_PROVIDER" ) {- or -} + ,(optPersonaAud ,"PERSONA_AUDIENCE" )] + when (isJust $ optPersonaAud opts0) $ checkIsJust [(optHmacKey ,"HMAC_KEY")] + checkIsJust [(optDBConf ,"DATABASE_CONFIG_FILE")] + checkIsJust [(optMongoServer ,"HAILS_MONGODB_SERVER")] + when ((isJust $ optPersonaAud opts0) && (isJust $ optOpenID opts0)) $ do + hPutStrLn stderr "Both OpenID and Persona are set." + exitFailure unless (optSafe opts0 || optForce opts0) $ do hPutStrLn stderr "Production code must be Safe, use --force to override" exitFailure @@ -307,8 +337,9 @@ pkgConf <- findPackageConfInCabalDev cd return $ opts0 { optCabalDev = Nothing, optPkgConf = Just pkgConf } _ -> return opts0 - where checkIsJust f msg = - when (isNothing $ f opts0) $ do + where checkIsJust fs = + unless (any (\f -> isJust $ (fst f) opts0) fs) $ do + let msg = List.intercalate " or " $ map snd fs hPutStrLn stderr $ "Production mode is strict, missing " ++ msg exitFailure @@ -347,6 +378,8 @@ [toLine optName "APP_NAME" ,("PORT", show `liftM` optPort opts) ,toLine optOpenID "OPENID_PROVIDER" + ,toLine optPersonaAud "PERSONA_AUDIENCE" + ,toLine optHmacKey "HMAC_KEY" ,toLine optDBConf "DATABASE_CONFIG_FILE" ,toLine optMongoServer "HAILS_MONGODB_SERVER" ,toLine optPkgConf "PACKAGE_CONF"