hails 0.9.2.0 → 0.9.2.1

raw patch · 7 files changed

+175/−20 lines, 7 filesdep +SHAdep ~bytestringdep ~failurePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: SHA

Dependency ranges changed: bytestring, failure

API changes (from Hackage documentation)

Files

• Hails/Database.hs +2/−0
• Hails/Database/Query.hs +33/−0
• Hails/HttpServer.hs +8/−0
• Hails/HttpServer/Auth.hs +78/−1
• Hails/Web/Controller.hs +1/−1
• hails.cabal +6/−4
• hails.hs +47/−14

@@ -90,6 +90,8 @@   , Limit   , BatchSize   , Order(..)+  -- ** Delete+  , delete, deleteP   ) where  import Hails.Data.Hson

@@ -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

@@ -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

@@ -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 

@@ -12,7 +12,7 @@ -}  module Hails.Web.Controller-  ( Controller+  ( Controller, ControllerState(..)   , request   , requestHeader    , body

@@ -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

@@ -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"