hails 0.11.1.2 → 0.11.1.3

raw patch · 12 files changed

+137/−112 lines, 12 filesdep +network-uridep ~waiPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: network-uri

Dependency ranges changed: wai

API changes (from Hackage documentation)

Files

• Hails/Database.hs +2/−1
• Hails/Database/Core.hs +11/−2
• Hails/Database/Query.hs +34/−33
• Hails/Database/TCB.hs +1/−5
• Hails/HttpServer.hs +2/−2
• Hails/PolicyModule.hs +41/−33
• Hails/PolicyModule/DSL.hs +9/−8
• Hails/PolicyModule/Groups.hs +2/−2
• Hails/PolicyModule/TCB.hs +1/−2
• LICENSE +17/−13
• hails.cabal +6/−4
• hails.hs +11/−7

@@ -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(..)

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

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

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

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

@@ -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 -- -- > ("<Policy module package>:<Fully qualified module>.<Policy module type>", "<Policy module database name>")--- +-- -- 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=<N> -- -- 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 []) 

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

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

@@ -1,7 +1,6 @@ {-# LANGUAGE Unsafe #-} {-# LANGUAGE GeneralizedNewtypeDeriving,-             MultiParamTypeClasses,-             TypeFamilies #-}+             MultiParamTypeClasses #-}  {- | 

@@ -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 <hails@scs.stanford.edu> -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.

@@ -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 <hails at scs dot stanford dot edu>@@ -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

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