bein-0.1: Bein/BeinCtl.hs

-- This file is part of Bein.
--
-- Bein 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 3 of the License, or
-- (at your option) any later version.
--    
-- Bein 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.
--
-- You should have received a copy of the GNU General Public License
-- along with Bein.  If not, see <http://www.gnu.org/licenses/>.


module Main where

import Data.Maybe (fromJust)
import System.FilePath
import System.Exit ( exitSuccess, exitFailure )
import System.IO ( hPutStrLn, stderr )
import System.Directory
import System.Console.GetOpt
import Database.HDBC
import Database.HDBC.PostgreSQL
import System.Environment (getArgs, getProgName)
import Bein.ShellScripting
import System.Posix.Files
import Bein.Configuration

data State = State { sqlDir :: Maybe FilePath,
                     outputFile :: Maybe FilePath,
                     verbose :: Bool } deriving (Eq,Show,Read)

defaultState :: State
defaultState = State { sqlDir = Nothing,
                       outputFile = Nothing,
                       verbose = False }

main :: IO ()
main = do (cmd,st) <- getState
          cmd st
            
getState :: IO (State -> IO (), State)
getState = do
  args <- getArgs
  case getOpt RequireOrder options args of
    (actions, [commandTxt], []) -> do opts <- foldl (>>=) (return defaultState) actions
                                      let command = parseCmd commandTxt
                                      case () of
                                        _ | (commandTxt `elem` ["init","cold-init","reload","deep-reload"]) && sqlDir opts == Nothing ->
                                          printHelpAndDie (Just "Must give an SQL source directory to init database.")
                                        _ | (commandTxt == "dump" && outputFile opts == Nothing) ->
                                          printHelpAndDie (Just "Must give a file to dump database to with -o option.")
                                        _ -> return (command,opts)
    (_, _, []) -> printHelpAndDie (Just "beinctl takes exactly one command.")
    (_, _, errs) -> printHelpAndDie (Just $ concat errs)

options :: [OptDescr (State -> IO State)]
options = [
  Option "h" ["help"]
         (NoArg (\_ -> printHelpAndDie Nothing))
         "Show help",
  Option "v" ["verbose"]
         (NoArg (\opt -> return opt { verbose = True }))
         "Be verbose.",
  Option "o" ["output"]
         (ReqArg (\arg opt -> return opt { outputFile = Just arg }) "OUTPUTFILE")
         "File to dump database to.",
  Option "d" ["sqldir"]
         (ReqArg (\arg opt -> do b <- doesDirectoryExist arg
                                 if b then return opt { sqlDir = Just arg }
                                   else printHelpAndDie (Just $ "Invalid directory: " ++ arg)) "SQLDIRECTORY")
         "Directory containing SQL source."
  ]

printHelpAndDie :: Maybe String -> IO a
printHelpAndDie msg = do
    case msg of
      Nothing -> help >> exitSuccess
      Just m -> hPutStrLn stderr m >> help >> exitFailure
    where help = do 
            programName <- getProgName
            hPutStrLn stderr (usageInfo (programName ++ " [-hvd] command") options)
            printCommands

parseCmd :: String -> (State -> IO ())
parseCmd "cold-init" = coldInitialize
parseCmd "init" = initialize
parseCmd "teardown" = teardown
parseCmd "full-teardown" = fullTeardown
parseCmd "dump" = dump
parseCmd "reload" = reload
parseCmd "deep-reload" = deepReload
parseCmd "show-config" = showConfig
parseCmd cmd = \_ -> printHelpAndDie (Just ("Unknown command: " ++ cmd))

printCommands :: IO ()
printCommands = do
  mapM_ putStrLn 
    ["  where command is one of:",
     "    init            - create Bein database ready for loading",
     "    cold-init       - create Bein database from scratch, including users",
     "    teardown        - delete the Bein database",
     "    full-teardown   - delete the Bein database and all users, leaving system pristine",
     "    dump            - dump data in the database to tar archive file", 
     "    reload          - same as teardown followed by init",
     "    deep-reload     - same as full-teardown followed by cold-init",
     "    show-config     - print the system configuration from the database"]
    
coldInitialize :: State -> IO ()
coldInitialize st = do
  nologin <- takeFirstM fileExist ["/sbin/nologin", "/usr/sbin/nologin"]
  systemM_ $ "useradd --system -M --user-group --shell " ++ nologin ++ " bein"
  systemM_ $ "sudo -u postgres createuser --no-superuser --login bein --no-createdb --no-createrole --no-superuser"
  initialize st
  
initialize :: State -> IO ()
initialize State { sqlDir = Nothing } = 
  printHelpAndDie (Just "Cannot initialize database without SQL directory.  Set -d option.")
initialize State { sqlDir = Just d, verbose = v } = do
  let inPath p = joinPath [d,p]
      unlessVerbose p = if v then "" else p
  systemM $ "sudo -u postgres createdb --owner bein bein"
  systemM $ "sudo -u postgres createlang plpgsql bein"
  systemM $ "sudo -u postgres createlang plpythonu bein"
  systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "core_tables.sql"
  systemM $ "sudo -u postgres psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file "++ inPath "untrusted_functions.sql"
  systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "triggers.sql"
  systemM $ "sudo -u bein psql " ++ unlessVerbose "--quiet" ++ " --dbname bein --file " ++ inPath "utility_functions.sql"

fullTeardown :: State -> IO ()
fullTeardown st = do
  teardown st
  systemM_ $ "userdel bein"
  systemM_ $ "groupdel bein"
  systemM_ $ "sudo -u postgres dropuser bein"

teardown :: State -> IO ()
teardown _ = do
  systemM_ $ "sudo -u postgres dropdb bein"

dump :: State -> IO ()
dump st = do
  systemM_ $ "sudo -u bein pg_dump --format=t -f " ++ fromJust (outputFile st) ++ " bein"

reload :: State -> IO ()
reload st = teardown st >> initialize st

deepReload :: State -> IO ()
deepReload st = fullTeardown st >> coldInitialize st

dbCommand :: (Connection -> IO a) -> IO ()
dbCommand cmd = do conn <- connectPostgreSQL "dbname=bein"
                   _ <- cmd conn
                   commit conn

showConfig :: State -> IO ()
showConfig _ = dbCommand (\conn -> readConfiguration conn >>= putStrLn . show)

takeFirstM :: Monad m => (a -> m Bool) -> [a] -> m a
takeFirstM _ [] = fail $ "Nothing in list succeeds."
takeFirstM f (c:cs) = f c >>= \r ->
  if r then return c else takeFirstM f cs