update hails to new versions

Author: Deian Stefan

Hails/Database/TCB.hs

@@ -276,11 +276,7 @@ execMongoActionTCB act = do
   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
 
 
 --

Hails/PolicyModule.hs

@@ -431,7 +431,7 @@ withPolicyModule act = do
                                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:

hails.cabal

@@ -1,5 +1,5 @@
 Name:           hails
-Version:        0.11.1.2
+Version:        0.11.1.3
 build-type:     Simple
 License:        GPL-2
 License-File:   LICENSE
@@ -102,12 +102,13 @@ Library
    ,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 @@ Executable hails
    ,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

hails.hs

@@ -5,6 +5,7 @@ import           Control.Exception
 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           Hails.Version
 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 @@ main = do
              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 @@ loadApp :: Bool             -- -XSafe ?
         -> 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 @@ envFromFile file = do
     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