{-# LANGUAGE ScopedTypeVariables #-} module Main (main) where 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 import Data.Maybe import Data.Version import Control.Monad import LIO import LIO.DCLabel import Hails.HttpServer import Hails.HttpServer.Auth import Hails.Version import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger import System.Environment import System.Console.GetOpt hiding (Option) import qualified System.Console.GetOpt as GetOpt import System.IO (stderr, hPutStrLn) import System.FilePath import System.Directory import System.Exit import Language.Haskell.Interpreter import Language.Haskell.Interpreter.Extension about :: String -> String about prog = prog ++ " " ++ showVersion version ++ "\n\n" ++ concat [ "Simple tool for launching Hails apps. This tool can be used in\n" , "both development and production mode. It allows you configure the\n" , "environment your app runs in (e.g., the port number the Hails HTTP\n" , "server should listen on, the MongoDB server it should connect to,\n" , "etc.). In development mode (default), " , prog , " uses some default\n" , "settings (e.g., port 8080). In production, mode all configuration\n" , "settings must be specified. To simplify deployment, this tool\n" , "checks the program environment for configuration settings (e.g.,\n" , "variable PORT is used for the port number), but you can override\n" , "these with arguments. See \'" , prog , " --help\' for a list of \n" , "configuration settings and corresponding environment variables.\n\n" , prog , " dynamically loads your app requst handler. Hence, the\n" , "app name is the module name where your \'server\' function is\n" , "defined."] -- -- -- main :: IO () main = do args <- getArgs env <- getEnvironment opts <- do opts <- hailsOpts args env when (optAbout opts) $ printAbout opts' <- case optInFile opts of Nothing -> return opts Just file -> do envFromFile file env' <- getEnvironment print env' hailsOpts args env' cleanOpts opts' maybe (return ()) (optsToFile opts) $ optOutFile opts putStrLn $ "Working environment:\n\n" ++ optsToEnvStr opts 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 openid = openIdAuth $ T.pack . fromJust . optOpenID $ opts external = externalAuth hmac_key (fromJust $ optExternal $ opts) logMiddleware = if optDev opts then logStdoutDev else logStdout authMiddleware = case () of -- dev/production mode with persona: _ | isJust (optPersonaAud opts) -> persona -- dev/productoin mode with openid: _ | isJust (optOpenID opts) -> openid _ | isJust (optExternal opts) -> external -- dev mode: _ -> devBasicAuth dcApp <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts) app <- evalDC $ setClearance dcPublic >> dcApp runSettings (setPort port defaultSettings) $ logMiddleware $ execHailsApplication authMiddleware app -- | Given an application module name, load the main controller named -- @server@. loadApp :: Bool -- -XSafe ? -> Maybe FilePath -- -package-db -> String -- Application name -> IO (DC Application) loadApp safe mpkgDb appName = do case mpkgDb of Just pkgDb -> setEnv "GHC_PACKAGE_PATH" pkgDb Nothing -> return () eapp <- runInterpreter $ do loadModules [appName] when safe $ set [languageExtensions := [asExtension "Safe"]] 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 -> case err of WontCompile es -> do putStrLn (unlines $ map errMsg es) throwIO (userError "Compilation error") _ -> throwIO err Right app -> return app -- -- Parsing options -- -- | Type used to encode hails options data Options = Options { optName :: Maybe String -- ^ App name , optPort :: Maybe Int -- ^ App port number , optAbout :: Bool -- ^ About this program , optSafe :: Bool -- ^ Use @-XSafe@ , optForce :: Bool -- ^ Force unsafe in production , optDev :: Bool -- ^ Development/Production , optExternal :: Maybe String -- ^ External Auth URL , 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 , optCabalDev :: Maybe String -- ^ Cabal-dev directory , optOutFile :: Maybe String -- ^ Write configurate to file , optInFile :: Maybe String -- ^ Read configurate from file } deriving Show -- | Default options defaultOpts :: Options defaultOpts = Options { optName = Nothing , optPort = Nothing , optAbout = False , optSafe = True , optForce = False , optDev = True , optExternal = Nothing , optOpenID = Nothing , optHmacKey = Nothing , optPersonaAud = Nothing , optDBConf = Nothing , optPkgConf = Nothing , optCabalDev = Nothing , optMongoServer = Nothing , optOutFile = Nothing , optInFile = Nothing} -- | Default development options. These options can be used -- when in development mode, to avoid annoying the user. defaultDevOpts :: Options defaultDevOpts = Options { optName = Just "App" , optPort = Just 8080 , optAbout = False , optSafe = True , optForce = False , optDev = True , optExternal = Nothing , optOpenID = Nothing , optHmacKey = Just "hails-d34adb33f-key" , optPersonaAud = Nothing , optDBConf = Just "database.conf" , optPkgConf = Nothing , optCabalDev = Nothing , optMongoServer = Just "localhost" , optOutFile = Nothing , optInFile = Nothing} -- | Parser for options options :: [ OptDescr (Options -> Options) ] options = [ GetOpt.Option ['a'] ["app"] (ReqArg (\n o -> o { optName = Just n }) "APP_NAME") "Start application APP_NAME." , GetOpt.Option ['p'] ["port"] (ReqArg (\p o -> o { optPort = Just $ read p }) "PORT") "Run application on port PORT." , GetOpt.Option [] ["dev", "development"] (NoArg (\opts -> opts { optDev = True })) "Development mode, default (no authentication)." , GetOpt.Option [] ["prod", "production"] (NoArg (\opts -> opts { optDev = False })) "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." , GetOpt.Option [] ["force"] (NoArg (\opts -> opts { optForce = True })) "Use with --unsafe to force the -XSafe flag off in production mode." , GetOpt.Option [] ["package-conf"] (ReqArg (\n o -> o { optPkgConf = Just n }) "PACKAGE_CONF") "Use PACKAGE_CONF for as the app specific package-conf file." , GetOpt.Option ['s'] ["cabal-dev"] (ReqArg (\n o -> o { optCabalDev = Just n }) "CABAL_DEV_SANDBOX") "The location ofthe cabal-dev sandbox (e.g., ./cabal-dev)." , GetOpt.Option [] ["db-conf", "database-conf"] (ReqArg (\n o -> o { optDBConf = Just n }) "DATABASE_CONFIG_FILE") "Use DATABASE_CONFIG_FILE as the specific database.conf file." , GetOpt.Option [] ["db", "mongodb-server"] (ReqArg (\n o -> o { optMongoServer = Just n }) "HAILS_MONGODB_SERVER") "Use HAILS_MONGODB_SERVER as the URL to the MongoDB server." , GetOpt.Option [] ["out"] (ReqArg (\n o -> o { optOutFile = Just n }) "OUT_FILE") "Write options to environment file OUT_FILE." , GetOpt.Option [] ["in", "env", "environment"] (ReqArg (\n o -> o { optInFile = Just n }) "IN_FILE") "Load environment variables from file IN_FILE." , GetOpt.Option ['?'] ["about"] (NoArg (\opts -> opts { optAbout = True })) "About this program." ] -- | Do parse options hailsOpts :: [String] -> [(String, String)] -> IO Options hailsOpts args env = let opts = envOpts defaultOpts env in case getOpt Permute options args of (o,[], []) -> return $ foldl (flip id) opts o (_,_,errs) -> do prog <- getProgName hPutStrLn stderr $ concat errs ++ usageInfo (header prog) options exitFailure where header prog = "Usage: " ++ prog ++ " [OPTION...]" -- | Extracting options from the environment (prioritzed) over -- arguments envOpts :: Options -> [(String, String)] -> Options envOpts opts env = opts { optName = mFromEnvOrOpt "APP_NAME" optName , optPort = case readFromEnv "PORT" of p@(Just _) -> p _ -> optPort opts , optOpenID = mFromEnvOrOpt "OPENID_PROVIDER" optOpenID , optPersonaAud = mFromEnvOrOpt "PERSONA_AUDIENCE" optPersonaAud , optExternal = mFromEnvOrOpt "AUTH_URL" optPersonaAud , optHmacKey = mFromEnvOrOpt "HMAC_KEY" optHmacKey , optDBConf = mFromEnvOrOpt "DATABASE_CONFIG_FILE" optDBConf , optPkgConf = mFromEnvOrOpt "PACKAGE_CONF" optPkgConf , optCabalDev = mFromEnvOrOpt "CABAL_DEV_SANDBOX" optCabalDev , optMongoServer = mFromEnvOrOpt "HAILS_MONGODB_SERVER" optMongoServer } where fromEnv n = lookup n env readFromEnv n = lookup n env >>= mRead mRead :: Read a => String -> Maybe a mRead s = fst `liftM` (listToMaybe $ reads s) mFromEnvOrOpt evar f = case fromEnv evar of x@(Just _) -> x _ -> f opts cleanOpts :: Options -> IO Options cleanOpts opts = do when (optAbout opts) $ printAbout if optDev opts then cleanDevOpts opts else cleanProdOpts opts -- | Clean options and use default development options when -- non-existant. cleanDevOpts :: Options -> IO Options cleanDevOpts opts0 = do let opts1 = opts0 { optName = mergeMaybe optName , optPort = mergeMaybe optPort , optOpenID = mergeMaybe optOpenID , optPersonaAud = mergeMaybe optPersonaAud , optExternal = mergeMaybe optExternal , optHmacKey = mergeMaybe optHmacKey , optDBConf = mergeMaybe optDBConf , optMongoServer = mergeMaybe optMongoServer } case (optPkgConf opts1, optCabalDev opts1) of (Just _, Just _) -> do hPutStrLn stderr "Flag package-conf supplied, ignoring cabal-dev sandbox" return $ opts1 { optCabalDev = Nothing } (_, Just cd) -> do pkgConf <- findPackageConfInCabalDev cd return $ opts1 { optCabalDev = Nothing, optPkgConf = Just pkgConf } _ -> return opts1 where mergeMaybe f = f $ if isJust (f opts0) then opts0 else defaultDevOpts -- | Clean options and strictly check that all the necessary ones -- exist. cleanProdOpts :: Options -> IO Options cleanProdOpts opts0 = do checkIsJust [(optName ,"APP_NAME" )] checkIsJust [(optPort ,"PORT" )] checkIsJust [(optOpenID ,"OPENID_PROVIDER" ) {- or -} ,(optPersonaAud ,"PERSONA_AUDIENCE" ) {- or -} ,(optExternal ,"AUTH_URL")] 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 case (optPkgConf opts0, optCabalDev opts0) of (Just _, Just _) -> do hPutStrLn stderr "Both package-conf supplied and cabal-dev sandbox defined." exitFailure (_, Just cd) -> do pkgConf <- findPackageConfInCabalDev cd return $ opts0 { optCabalDev = Nothing, optPkgConf = Just pkgConf } _ -> return opts0 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 -- | Find the package-conf file in a cabal-dev directory (e.g., -- packages-7.4.2.conf) findPackageConfInCabalDev :: FilePath -> IO FilePath findPackageConfInCabalDev cdev = do fs <- getDirectoryContents cdev case filter f fs of [] -> do hPutStrLn stderr $ "Could not file package config file in " ++ show cdev exitFailure xs@(x:_) -> do let path = cdev x when (length xs > 1) $ hPutStrLn stderr $ "Using " ++ show path ++ " for the package config file" return path where f d = "packages-" `isPrefixOf` d && ".conf" `isSuffixOf` d -- | Print about message printAbout :: IO () printAbout = do prog <- getProgName putStrLn $ about prog exitSuccess -- | Write options to environment file optsToFile :: Options -> FilePath -> IO () optsToFile opts file = writeFile file (optsToEnvStr opts) >> exitSuccess -- | Options to envionment string optsToEnv :: Options -> [(String,String)] optsToEnv opts = map (\(k, mv) -> (k, fromJust mv)) $ filter (isJust . snd) $ [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" ,toLine optCabalDev "CABAL_DEV_SANDBOX" ] where toLine f var = (var, f opts) -- | Create environment list optsToEnvStr :: Options -> String optsToEnvStr opts = unlines $ map (\(k,v) -> k++"="++v) $ optsToEnv opts -- If an environment entry does not contain an @\'=\'@ character, -- the @key@ is the whole entry and the @value@ is the empty string. envFromFile :: FilePath -> IO () envFromFile file = do ls <- S8.lines `liftM` S8.readFile file forM_ ls $ \line -> let (key',val') = S8.span (/='=') line val = safeTail val' in case S8.words key' of [key] -> setEnv (S8.unpack key) (S8.unpack val) _ -> do hPutStrLn stderr $ "Invalid environment line: " ++ show (S8.unpack line) exitFailure where safeTail s = if S8.null s then s else S8.tail s