diff --git a/Hails/Database.hs b/Hails/Database.hs --- a/Hails/Database.hs +++ b/Hails/Database.hs @@ -54,6 +54,7 @@ module Hails.Database ( -- * Hails database monad DBAction, MonadDB(..) + , withDBContext , withPolicyModule , getDatabase, getDatabaseP -- ** Exception thrown by failed database actions @@ -70,7 +71,7 @@ , PolicyError(..) -- ** Documents , module Hails.Data.Hson - , LabeledHsonDocument + , LabeledHsonDocument -- * Database queries -- ** Write (insert/save) , InsertLike(..) diff --git a/Hails/Database/Core.hs b/Hails/Database/Core.hs --- a/Hails/Database/Core.hs +++ b/Hails/Database/Core.hs @@ -19,9 +19,10 @@ , DatabaseName , Database, databaseName, databaseLabel, databaseCollections -- * Labeled documents - , LabeledHsonDocument + , LabeledHsonDocument -- * Hails DB monad , DBAction, DBActionState + , withDBContext , MonadDB(..) , runDBAction, evalDBAction , getDatabase, getDatabaseP @@ -35,6 +36,7 @@ import LIO import LIO.DCLabel +import LIO.Error import Hails.Data.Hson import Hails.Database.TCB @@ -61,6 +63,13 @@ evalDBAction :: DBAction a -> DBActionState -> DC a evalDBAction a s = fst `liftM` runDBAction a s + +-- | Execute a database action with a "stack" context. +withDBContext :: String -> DBAction a -> DBAction a +withDBContext ctx (DBActionTCB act) = + DBActionTCB . StateT $ \s -> + withContext ctx $ runStateT act s + -- | Get the underlying database. Must be able to read from the -- database as enforced by applying 'taint' to the database label. -- This is required because the database label protects the @@ -72,7 +81,7 @@ -- | Same as 'getDatabase', but uses privileges when raising the -- current label. getDatabaseP :: DCPriv -> DBAction Database -getDatabaseP p = do +getDatabaseP p = withDBContext "getDatabaseP" $ do db <- dbActionDB `liftM` getActionStateTCB liftLIO $ taintP p (databaseLabel db) return db diff --git a/Hails/Database/Query.hs b/Hails/Database/Query.hs --- a/Hails/Database/Query.hs +++ b/Hails/Database/Query.hs @@ -16,7 +16,7 @@ not the database. The later is a result of allowing policy modules to express a labeling policy as a function of a document -- hence we cannot determine at compile time if a field is used in a policy and -thus must be included in the projection. +thus must be included in the projection. -} @@ -126,7 +126,7 @@ -- MongoDB default. , hint :: [FieldName] -- ^ Force mongoDB to use this index, default @[]@, - -- no hint. + -- no hint. -- Non-'SearchableField's ignored. } @@ -171,7 +171,7 @@ , limit = 0 , sort = [] , batchSize = 0 - , hint = [] + , hint = [] } -- -- Write @@ -190,11 +190,11 @@ -- collection in the database, and thus must be able to read the -- database collection map as verified by applying 'taint' to the -- collections label. - -- + -- -- When inserting an unlabeled document, all policies must be -- succesfully applied using 'applyCollectionPolicyP' and the document -- must be \"well-typed\" (see 'applyCollectionPolicyP'). - -- + -- -- When inserting an already-labeled document, the labels on fields -- and the document itself are compared against the policy-generated -- labels. Note that this approach allows an untrusted piece of code @@ -228,7 +228,7 @@ -- | Update a document according to its @_id@ value. The IFC requirements -- subsume those of 'insert'. Specifically, in addition to being able -- to apply all the policies and requiring that the current label flow - -- to the label of the collection and database, @save@ requires that + -- to the label of the collection and database, @save@ requires that -- the current label flow to the label of the existing database -- record (i.e, the existing document can be overwritten). save :: CollectionName @@ -249,7 +249,7 @@ -> DBAction () instance InsertLike HsonDocument where - insertP priv cName doc = do + insertP priv cName doc = withDBContext "insertP" $ withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection, -- apply policies: @@ -259,7 +259,7 @@ _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc) where _id i = let HsonValue (BsonObjId i') = dataBsonValueToHsonValueTCB i in i' - saveP priv cName doc = do + saveP priv cName doc = withDBContext "saveP" $do withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection, -- apply policies: @@ -311,7 +311,7 @@ maybe (return ()) (liftLIO . guardWriteP' ld . labelOf) mdoc -- Okay, save document: saveIt ldoc - where guardWriteP' lnew lold = + where guardWriteP' lnew lold = unless (canFlowToP priv lnew lold) $ labelErrorP "New document label doesn't flow to the old" priv [lnew, lold] saveIt (LabeledTCB _ doc) = @@ -363,10 +363,10 @@ throwLIO PolicyViolation -- Perform action on policy-labeled document: act $ LabeledTCB ltcb docTCB - where compareDoc d1' d2' = + where compareDoc d1' d2' = let d1 = sortDoc d1' d2 = sortDoc d2' - in map fieldName d1 == map fieldName d2 + in map fieldName d1 == map fieldName d2 && (and $ zipWith compareField d1 d2) compareField (HsonField n1 (HsonValue v1)) (HsonField n2 (HsonValue v2)) = @@ -401,7 +401,7 @@ -- | Same as 'find', but uses privileges when reading from the -- collection and database. findP :: DCPriv -> Query -> DBAction Cursor -findP priv query = do +findP priv query = withDBContext "findP" $ do let cName = selectionCollection . selection $ query dbLabel <- (databaseLabel . dbActionDB) `liftM` getActionStateTCB withCollection priv False cName $ \col -> do @@ -441,7 +441,7 @@ -- | Same as 'next', but usess privileges when raising the current label. nextP :: DCPriv -> Cursor -> DBAction (Maybe LabeledHsonDocument) -nextP p cur = do +nextP p cur = withDBContext "nextP" $ do -- Raise current label, can read from DB+collection: liftLIO $ taintP p $ curLabel cur -- Read the document: @@ -466,7 +466,7 @@ -- | Same as 'findOne', but uses privileges when performing label -- comparisons. findOneP :: DCPriv -> Query -> DBAction (Maybe LabeledHsonDocument) -findOneP p q = findP p q >>= nextP p +findOneP p q = withDBContext "findOneP" $ findP p q >>= nextP p -- -- Delete @@ -481,7 +481,7 @@ -- | Same as 'delete', but uses privileges. deleteP :: DCPriv -> Selection -> DBAction () -deleteP p sel = do +deleteP p sel = withDBContext "deleteP" $ do let qry = select (selectionSelector sel) (selectionCollection sel) cur <- findP p qry forAll cur $ \(LabeledTCB l ld) -> do @@ -495,12 +495,12 @@ where forAll cur act = do mldoc <- nextP p cur maybe (return ()) (\ld -> act ld >> forAll cur act) mldoc - + -- -- Helpers --- +-- -- | Convert a query to queries used by "Database.Mongo" queryToMongoQueryTCB :: Query -> Mongo.Query @@ -538,20 +538,21 @@ -> CollectionName -> (Collection -> DBAction a) -> DBAction a -withCollection priv isWrite cName act = do - db <- getDatabaseP priv - col <- liftLIO $ do - -- If this is a write: check that we can write to database: - when isWrite $ guardWriteP priv (databaseLabel db) - -- Check that we can read collection names associated with DB: - cs <- unlabelP priv $ databaseCollections db - -- Lookup collection name in the collection set associated with DB: - col0 <- maybe (throwLIO UnknownCollection) return $ getCol cs - -- If this is a write: check that we can write to collection: - when isWrite $ guardWriteP priv (colLabel col0) - return col0 - -- Execute action on collection: - act col +withCollection priv isWrite cName act = + withDBContext ("withCollection:" ++ Text.unpack cName) $ do + db <- getDatabaseP priv + col <- liftLIO $ do + -- If this is a write: check that we can write to database: + when isWrite $ guardWriteP priv (databaseLabel db) + -- Check that we can read collection names associated with DB: + cs <- unlabelP priv $ databaseCollections db + -- Lookup collection name in the collection set associated with DB: + col0 <- maybe (throwLIO UnknownCollection) return $ getCol cs + -- If this is a write: check that we can write to collection: + when isWrite $ guardWriteP priv (colLabel col0) + return col0 + -- Execute action on collection: + act col where getCol = listToMaybe . Set.toList . Set.filter ((==cName) . colName) -- @@ -592,7 +593,7 @@ -> Collection -- ^ Collection and policies -> HsonDocument -- ^ Document to apply policies to -> m (LabeledHsonDocument) -applyCollectionPolicyP p col doc0 = liftLIO $ do +applyCollectionPolicyP p col doc0 = liftLIO $ withContext "applyCollectionPolicyP" $ do let doc1 = List.nubBy (\f1 f2 -> fieldName f1 == fieldName f2) doc0 typeCheckDocument fieldPolicies doc1 c <- getClearance @@ -625,7 +626,7 @@ -- policy labeled, and all searchable/policy-labeled fields named in -- the collection policy are present in the document (except for @_id@). typeCheckDocument :: Map FieldName FieldPolicy -> HsonDocument -> DC () -typeCheckDocument ps doc = do +typeCheckDocument ps doc = withContext "typeCheckDocument" $ do -- Check that every policy-named value exists and is well-typed void $ T.for psList $ \(k,v) -> do case look k doc of diff --git a/Hails/Database/TCB.hs b/Hails/Database/TCB.hs --- a/Hails/Database/TCB.hs +++ b/Hails/Database/TCB.hs @@ -276,11 +276,7 @@ let pipe = dbActionPipe s mode = dbActionMode s db = databaseName . dbActionDB $ s - liftLIO $ ioTCB $ do - res <- Mongo.access pipe mode db act - case res of - Left err -> throwIO $ ExecFailure err - Right v -> return v + liftLIO $ ioTCB $ Mongo.access pipe mode db act -- diff --git a/Hails/HttpServer.hs b/Hails/HttpServer.hs --- a/Hails/HttpServer.hs +++ b/Hails/HttpServer.hs @@ -130,9 +130,9 @@ Set.map principalName $ dToSet $ head $ Set.elems secrecySet in if secrecy == cFalse || Set.size secrecySet > 1 - then "\'none\'" -- false/conjunction + then "'self','unsafe-inline'" -- Be more flexible than 'none' else S8.unwords $ - "\'self\'":"\'unsafe-inline\'":(Set.toList uriList) + "'self'":"'unsafe-inline'":(Set.toList uriList) -- | Remove anything from the response that could cause inadvertant -- declasification. Currently this only removes the @Set-Cookie@ diff --git a/Hails/PolicyModule.hs b/Hails/PolicyModule.hs --- a/Hails/PolicyModule.hs +++ b/Hails/PolicyModule.hs @@ -30,7 +30,7 @@ module Hails.PolicyModule ( -- * Creating policy modules PolicyModule(..) - , PMAction + , PMAction, withPMContext, withPMClearanceP -- ** Database and collection-set -- $db , labelDatabaseP @@ -46,7 +46,7 @@ , searchableFields -- * Using policy module databases -- $withPM - , withPolicyModule + , withPolicyModule -- * Internal , TypeName , policyModuleTypeName @@ -71,6 +71,7 @@ import LIO import LIO.TCB import LIO.DCLabel +import LIO.Error import Hails.Data.Hson import Hails.Database.Core import Hails.Database.TCB @@ -113,10 +114,10 @@ -- > import LIO.DCLabel -- > import Data.Typeable -- > import Hails.PolicyModule --- > +-- > -- > -- | Handle to policy module, not exporting @MyPolicyModuleTCB@ -- > data MyPolicyModule = MyPolicyModuleTCB DCPriv deriving Typeable --- > +-- > -- > instance PolicyModule MyPolicyModule where -- > initPolicyModule priv = do -- > -- Get the policy module principal: @@ -165,7 +166,7 @@ class Typeable pm => PolicyModule pm where -- | Entry point for policy module. Before executing the entry function, -- the current clearance is \"raised\" to the greatest lower bound of the - -- current clearance and the label @\<\"Policy module principal\", |True\>@, + -- current clearance and the label @\<\"Policy module principal\", |True\>@, -- as to allow the policy module to read data labeled with its principal. initPolicyModule :: DCPriv -> PMAction pm @@ -210,14 +211,14 @@ -- | Same as 'setDatabaseLabel', but uses privileges when performing -- label comparisons. If a policy module wishes to allow other policy --- modules or apps to access the underlying databse it must use +-- modules or apps to access the underlying databse it must use -- @setDatabaseLabelP@ to \"downgrade\" the database label, which by -- default only allows the policy module itself to access any of the -- contents (including collection-set). setDatabaseLabelP :: DCPriv -- ^ Set of privileges -> DCLabel -- ^ New database label -> PMAction () -setDatabaseLabelP p l = liftDB $ do +setDatabaseLabelP p l = withPMContext "setDatabaseLabelP" $ liftDB $ do liftLIO $ guardAllocP p l db <- dbActionDB `liftM` getActionStateTCB liftLIO $ guardWriteP p (databaseLabel db) @@ -242,7 +243,7 @@ setCollectionSetLabelP :: DCPriv -- ^ Set of privileges -> DCLabel -- ^ New collections label -> PMAction () -setCollectionSetLabelP p l = liftDB $ do +setCollectionSetLabelP p l = withPMContext "setCollectionSetLabelP " $liftDB $ do liftLIO $ guardAllocP p l db <- dbActionDB `liftM` getActionStateTCB liftLIO $ guardWriteP p (databaseLabel db) @@ -257,7 +258,7 @@ -> DCLabel -- ^ Database label -> DCLabel -- ^ Collections label -> PMAction () -labelDatabaseP p ldb lcol = do +labelDatabaseP p ldb lcol = withPMContext "labelDatabaseP" $ do setDatabaseLabelP p ldb setCollectionSetLabelP p lcol @@ -270,7 +271,7 @@ As noted above a database consists of a set of collections. Each Hails collection is a MongoDB collection with a set of labels and policies. The main database \"work units\" are 'HsDocument's, which are stored -and retrieved from collections (see "Hails.Database"). +and retrieved from collections (see "Hails.Database"). Each collection has: @@ -312,7 +313,7 @@ -- collection-set protected by the database label. The guard 'taint' is -- used to guarantee this and raise the current label (to the -- join of the current label and database label) appropriately. --- +-- -- 3. The computation must be able to modify the database collection-set. -- The guard 'guardWrite' is used to guarantee that the current label -- is essentially equal to the collection-set label. @@ -334,7 +335,7 @@ -> DCLabel -- ^ Collection clearance -> CollectionPolicy -- ^ Collection policy -> PMAction () -createCollectionP p n l c pol = liftDB $ do +createCollectionP p n l c pol = withPMContext "createCollectionP" $ liftDB $ do db <- dbActionDB `liftM` getActionStateTCB liftLIO $ do taintP p $ databaseLabel db @@ -390,7 +391,7 @@ -- to a policy module. The format of a line is as follows -- -- > (":.", "") --- +-- -- Example of valid line is: -- -- > ("my-policy-0.1.2.3:My.Policy.MyPolicyModule", "my_db") @@ -422,45 +423,52 @@ -- passed in additional privileges by encapsulating them in @pm@ (see -- 'PolicyModule'). withPolicyModule :: forall a pm. PolicyModule pm => (pm -> DBAction a) -> DC a -withPolicyModule act = do +withPolicyModule act = withContext "withPolicyModule" $ do case Map.lookup tn availablePolicyModules of - Nothing -> throwLIO UnknownPolicyModule + Nothing -> throwLIO UnknownPolicyModule Just (pmOwner, dbName) -> do env <- ioTCB $ getEnvironment let hostName = fromMaybe "localhost" $ List.lookup "HAILS_MONGODB_SERVER" env mode = maybe master parseMode $ List.lookup "HAILS_MONGODB_MODE" env - pipe <- ioTCB $ Mongo.runIOE $ Mongo.connect (Mongo.host hostName) + pipe <- ioTCB $ Mongo.connect (Mongo.host hostName) let priv = PrivTCB (toCNF pmOwner) s0 = makeDBActionStateTCB priv dbName pipe mode -- Execute policy module entry function with raised clearance: - (policy, s1) <- withClearanceP' priv $ runDBAction (pmAct priv) s0 + (policy, s1) <- withPMClearanceP priv $ runDBAction (pmAct priv) s0 let s2 = s1 { dbActionDB = dbActionDB s1 } res <- evalDBAction (act policy) s2 ioTCB $ Mongo.close pipe return res where tn = policyModuleTypeName (undefined :: pm) pmAct priv = unPMActionTCB $ initPolicyModule priv :: DBAction pm - withClearanceP' priv io = do - c <- getClearance - let lpriv = (priv %% priv) `lub` c - -- XXX: does this actually work? Used to be bracketP - bracket - -- Raise clearance: - (setClearanceP priv lpriv) - -- Lower clearance: - (const $ do c' <- getClearance - setClearanceP priv (downgradeP priv c' `lub` c)) - -- Execute policy module entry point, in between: - (const io) +withPMClearanceP :: DCPriv -> DC a -> DC a +withPMClearanceP priv io = do + c <- getClearance + let lpriv = (priv %% priv) `lub` c + -- XXX: does this actually work? Used to be bracketP + bracket + -- Raise clearance: + (setClearanceP priv lpriv) + -- Lower clearance: + (const $ do c' <- getClearance + setClearanceP priv (downgradeP priv c' `lub` c)) + -- Execute policy module entry point, in between: + (const io) + + +-- | Execute a database action with a "stack" context. +withPMContext :: String -> PMAction a -> PMAction a +withPMContext ctx (PMActionTCB act) = PMActionTCB $ withDBContext ctx act + -- | Get the name of a policy module. policyModuleTypeName :: PolicyModule pm => pm -> TypeName policyModuleTypeName x = tyConPackage tp ++ ":" ++ tyConModule tp ++ "." ++ tyConName tp where tp = typeRepTyCon $ typeOf x - + -- -- Parser for getLastError -- @@ -477,7 +485,7 @@ -- > fsync | journal | writes= -- -- separated by \',\', and @N@ is an integer. --- Example: +-- Example: -- -- > HAILS_MONGODB_MODE = "slaveOk" -- > HAILS_MONGODB_MODE = "confirmWrites: writes=3, journal" @@ -489,7 +497,7 @@ parseMode xs = case parse wParser "" xs of Right le -> ConfirmWrites le Left _ -> master - where wParser = do _ <- string "confirmWrites" + where wParser = do _ <- string "confirmWrites" spaces _ <- char ':' spaces @@ -499,7 +507,7 @@ gle_opts = do opt_first <- gle_opt opt_rest <- gle_opts' return $ opt_first ++ opt_rest - where gle_opt = gle_opt_fsync <|> gle_opt_journal <|> gle_opt_write + where gle_opt = gle_opt_fsync <|> gle_opt_journal <|> gle_opt_write gle_opts' :: Stream s m Char => ParsecT s u m GetLastError gle_opts' = (spaces >> char ',' >> spaces >> gle_opts) <|> (return []) diff --git a/Hails/PolicyModule/DSL.hs b/Hails/PolicyModule/DSL.hs --- a/Hails/PolicyModule/DSL.hs +++ b/Hails/PolicyModule/DSL.hs @@ -98,6 +98,7 @@ import Data.Typeable import qualified Data.Map as Map import qualified Data.Text as T +import Control.Applicative import Control.Monad hiding (forM) import Control.Monad.Trans import Control.Monad.Trans.Reader hiding (ask) @@ -173,7 +174,7 @@ -- | Database expression composition monad newtype DBExpM a = DBExpM (ErrorT String (State DBExpS) a) - deriving (Monad, MonadState DBExpS) + deriving (Monad, MonadState DBExpS, Functor, Applicative) instance Role Readers DBExpS DBExpM where _ ==> c = DBExpM $ do @@ -249,7 +250,7 @@ -- | Access expression composition monad newtype ColAccExpM a = ColAccExpM (ErrorT String (StateT ColAccExpS (Reader CollectionName)) a) - deriving (Monad, MonadState ColAccExpS, MonadReader CollectionName) + deriving (Monad, MonadState ColAccExpS, MonadReader CollectionName, Functor, Applicative) instance Role Readers ColAccExpS ColAccExpM where _ ==> c = ColAccExpM $ do @@ -287,7 +288,7 @@ -- | Database expression composition monad newtype ColClrExpM a = ColClrExpM (ErrorT String (StateT ColClrExpS (Reader CollectionName)) a) - deriving (Monad, MonadState ColClrExpS, MonadReader CollectionName) + deriving (Monad, MonadState ColClrExpS, MonadReader CollectionName, Functor, Applicative) instance Role Readers ColClrExpS ColClrExpM where _ ==> c = ColClrExpM $ do @@ -329,7 +330,7 @@ -- | Document expression composition monad newtype ColDocExpM a = ColDocExpM (ErrorT String (StateT ColDocExpS (Reader CollectionName)) a) - deriving (Monad, MonadState ColDocExpS, MonadReader CollectionName) + deriving (Monad, MonadState ColDocExpS, MonadReader CollectionName, Functor, Applicative) instance Role Readers ColDocExpS ColDocExpM where _ ==> c = ColDocExpM $ do @@ -373,7 +374,7 @@ -- | Labeled field expression composition monad. newtype ColLabFieldExpM a = ColLabFieldExpM (ErrorT String (StateT ColLabFieldExpS (Reader (FieldName, CollectionName))) a) - deriving (Monad, MonadState ColLabFieldExpS, MonadReader (FieldName, CollectionName)) + deriving (Monad, MonadState ColLabFieldExpS, MonadReader (FieldName, CollectionName), Functor, Applicative) instance Role Readers ColLabFieldExpS ColLabFieldExpM where _ ==> c = ColLabFieldExpM $ do @@ -396,7 +397,7 @@ -- | Field expression composition monad. newtype ColFieldExpM a = ColFieldExpM (ErrorT String (StateT (Maybe ColFieldExp) (Reader (FieldName, CollectionName))) a) - deriving (Monad, MonadState (Maybe ColFieldExp), MonadReader (FieldName, CollectionName)) + deriving (Monad, MonadState (Maybe ColFieldExp), MonadReader (FieldName, CollectionName), Functor, Applicative) -- | Set the underlying field to be a searchable key. -- @@ -480,7 +481,7 @@ -- | Database expression composition monad newtype ColExpM a = ColExpM (ErrorT String (StateT ColExpS (Reader CollectionName)) a) - deriving (Monad, MonadState ColExpS, MonadReader CollectionName) + deriving (Monad, MonadState ColExpS, MonadReader CollectionName, Functor, Applicative) -------------------------------------------------------------- @@ -500,7 +501,7 @@ -- | Policy expression composition monad newtype PolicyExpM a = PolicyExpM (ErrorT String (State PolicyExpS) a) - deriving (Monad, MonadState PolicyExpS) + deriving (Monad, MonadState PolicyExpS, Functor, Applicative) -------------------------------------------------------------- diff --git a/Hails/PolicyModule/Groups.hs b/Hails/PolicyModule/Groups.hs --- a/Hails/PolicyModule/Groups.hs +++ b/Hails/PolicyModule/Groups.hs @@ -50,7 +50,7 @@ -> DCLabeled a -- ^ Label -> DBAction (DCLabeled a) -labelRewrite pm lx = do +labelRewrite pm lx = withDBContext "labelRewrite" $ do -- Make sure that 'groupsInstanceEndorse' is not bottom _ <- liftLIO $ evaluate (groupsInstanceEndorse :: unused_pm) pmPriv <- getPMPriv @@ -62,7 +62,7 @@ -- Apply map to all principals in the label let lnew = (expandPrincipals pMap s) %% (expandPrincipals pMap i) -- Relabel labeled value - liftLIO $ relabelLabeledP pmPriv lnew lx + liftLIO $ withPMClearanceP pmPriv $ relabelLabeledP pmPriv lnew lx where getPMPriv = do pmPriv <- dbActionPriv `liftM` getActionStateTCB -- Make sure that the underlying policy module diff --git a/Hails/PolicyModule/TCB.hs b/Hails/PolicyModule/TCB.hs --- a/Hails/PolicyModule/TCB.hs +++ b/Hails/PolicyModule/TCB.hs @@ -1,7 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - TypeFamilies #-} + MultiParamTypeClasses #-} {- | diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,17 +1,21 @@ -This program is free software; you can redistribute it and/or -modify it under the terms of the GNU General Public License as -published by the Free Software Foundation; either version 2, or (at -your option) any later version. +The MIT License (MIT) -This program is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -General Public License for more details. +Copyright (c) 2011-2014 Hails team n -You can obtain copies of permitted licenses from these URLs: +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: - http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt - http://www.gnu.org/licenses/gpl-3.0.txt +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. -or by writing to the Free Software Foundation, Inc., 59 Temple Place, -Suite 330, Boston, MA 02111-1307 USA +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/hails.cabal b/hails.cabal --- a/hails.cabal +++ b/hails.cabal @@ -1,7 +1,7 @@ Name: hails -Version: 0.11.1.2 +Version: 0.11.1.3 build-type: Simple -License: GPL-2 +License: MIT License-File: LICENSE Author: Hails team Maintainer: Hails team @@ -102,12 +102,13 @@ ,bson ,mongoDB ,network + ,network-uri ,http-conduit >= 2.1.0 ,conduit ,conduit-extra ,resourcet ,exceptions - ,wai >= 2.1 + ,wai >= 2.1 && < 3.0 ,wai-app-static ,wai-extra ,http-types @@ -165,12 +166,13 @@ ,bson ,mongoDB ,network + ,network-uri ,http-conduit >= 2.1.0 ,conduit ,conduit-extra ,resourcet ,exceptions - ,wai >= 2.1 + ,wai >= 2.1 && < 3.0 ,wai-extra ,wai-app-static ,warp diff --git a/hails.hs b/hails.hs --- a/hails.hs +++ b/hails.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 +import Prelude import qualified Data.Text as T import Data.List (isPrefixOf, isSuffixOf) import qualified Data.List as List @@ -21,7 +22,6 @@ import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger -import System.Posix.Env (setEnv) import System.Environment import System.Console.GetOpt hiding (Option) import qualified System.Console.GetOpt as GetOpt @@ -77,7 +77,7 @@ cleanOpts opts' maybe (return ()) (optsToFile opts) $ optOutFile opts putStrLn $ "Working environment:\n\n" ++ optsToEnvStr opts - forM_ (optsToEnv opts) $ \(k,v) -> setEnv k v True + forM_ (optsToEnv opts) $ \(k,v) -> setEnv k v let port = fromJust $ optPort opts hmac_key = L8.pack . fromJust $ optHmacKey opts persona = personaAuth hmac_key $ T.pack . fromJust . optPersonaAud $ opts @@ -107,20 +107,24 @@ -> IO (DC Application) loadApp safe mpkgDb appName = do case mpkgDb of - Just pkgDb -> setEnv "GHC_PACKAGE_PATH" pkgDb True + Just pkgDb -> setEnv "GHC_PACKAGE_PATH" pkgDb Nothing -> return () eapp <- runInterpreter $ do + loadModules [appName] when safe $ set [languageExtensions := [asExtension "Safe"]] - loadModules [appName] - setImports ["Prelude", "LIO", "LIO.DCLabel", "Hails.HttpServer", appName] + setTopLevelModules [appName] + setImports ["Prelude", "LIO", "LIO.DCLabel", "Hails.HttpServer"] 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 + Left err -> case err of + WontCompile es -> do putStrLn (unlines $ map errMsg es) + throwIO (userError "Compilation error") + _ -> throwIO err Right app -> return app -- @@ -397,7 +401,7 @@ let (key',val') = S8.span (/='=') line val = safeTail val' in case S8.words key' of - [key] -> setEnv (S8.unpack key) (S8.unpack val) True + [key] -> setEnv (S8.unpack key) (S8.unpack val) _ -> do hPutStrLn stderr $ "Invalid environment line: " ++ show (S8.unpack line) exitFailure