content: {-# 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 
  