multiplicity-0.1.0: src/main.hs

-- Copyright: 2009 Dino Morelli
-- License: BSD3 (see LICENSE)
-- Author: Dino Morelli <dino@ui3.info>

{-# LANGUAGE FlexibleContexts #-}

import Control.Monad.Error
import Control.Monad.Reader
import Data.List ( intercalate, isPrefixOf )
import Data.Map hiding ( map, null )
import Fez.Data.Conf ( ConfMap, parseToMap )
import Prelude hiding ( lookup )
import System.Environment ( getArgs )
import System.Exit ( ExitCode (..), exitWith )
import System.IO ( BufferMode (..), hSetBuffering, stdout )
import System.Process ( runCommand, waitForProcess )
import Text.Printf

import Multiplicity.Common ( ecTerminated )
import Multiplicity.Docs ( usage, sampleConfig )


-- Data type to hold environment for Reader monad
data Env = Env
   { config :: ConfMap
   , rawArgs :: [String]
   }


{- Custom monad stack for this application:
   ErrorT wrapped around Reader
-}

type Mult a = ErrorT String (Reader Env) a

runMult :: ErrorT e (Reader r) a -> r -> Either e a
runMult ev env = runReader (runErrorT ev) env


-- Type to carry results of parseArgs action
type ParseResult = (String, String)


{- Lookup in the config (which is a Map String String) as an
   (ErrorT String) action with meaningful error message.
-}
lookupE :: (MonadError String m) => String -> ConfMap -> m String
lookupE key mp = maybe (throwError $ "Key " ++ key ++ " not found")
   return $ lookup key mp


{- parseArgs transforms the config file plus passed args into the proper
   list of args for duplicity. Not as easy as it sounds, these arg
   lists are dependent on the duplicity action to be taken

   The real work of this program is all in here.
-}

parseArgs :: String -> Mult ParseResult

parseArgs "full"                  = parseType1
parseArgs "incremental"           = parseType1
parseArgs "incr"                  = parseType1
   -- duplicity accepts this abbreviation
parseArgs ""                      = parseType1

parseArgs "restore"               = parseType2
parseArgs "verify"                = parseType2

parseArgs "collection-status"     = parseType3
parseArgs "list-current-files"    = parseType3
parseArgs "cleanup"               = parseType3
parseArgs "remove-older-than"     = parseType3
parseArgs "remove-all-but-n-full" = parseType3

-- Anything else is crazy and unexpected, throw an error
parseArgs action = throwError $ "Unknown action: " ++ action


parseType1 :: Mult ParseResult
parseType1 = do
   args <- liftM (intercalate " ") $ asks rawArgs
   conf <- asks config

   pw <- lookupE "passphrase" conf
   cs <- lookupE "common-args" conf
   filters <- lookupE "filters" conf
   srcDir <- lookupE "src-dir" conf
   targetUrl <- lookupE "target-url" conf

   return ( pw
      , printf "%s %s %s %s %s" cs args filters srcDir targetUrl )


parseType2 :: Mult ParseResult
parseType2 = do
   arglist <- asks rawArgs
   conf <- asks config

   pw <- lookupE "passphrase" conf
   cs <- lookupE "common-args" conf
   srcUrl <- lookupE "target-url" conf
   let args = intercalate " " $ init arglist
   let targetDir = last arglist

   return ( pw
      , printf "%s %s %s %s" cs args srcUrl targetDir )


parseType3 :: Mult ParseResult
parseType3 = do
   args <- liftM (intercalate " ") $ asks rawArgs
   conf <- asks config

   pw <- lookupE "passphrase" conf
   cs <- lookupE "common-args" conf
   targetUrl <- lookupE "target-url" conf

   return ( pw
      , printf "%s %s %s" args cs targetUrl )


{- These two functions are the handlers for failure and success of 
   parseArgs
-}

endBadly :: String -> IO ExitCode
endBadly err = do
   putStrLn err
   return ecTerminated


invokeDuplicity :: String -> ParseResult -> IO ExitCode
invokeDuplicity action (pw, args) = do
   let displayCommand = buildCmdString "**HIDDEN**" action args 
   let realCommand = buildCmdString pw action args

   hSetBuffering stdout NoBuffering

   printf "\nCommand used to invoke duplicity:\n%s\n\n"
      (displayCommand :: String)

   waitForProcess =<< runCommand realCommand

   where
      buildCmdString = printf "PASSPHRASE=\"%s\" duplicity %s %s"


{- Make sense of the varied shapes of command-line we accept,
   parse it into conf path, action and duplicity arg list.
   Or fail with Nothing
-}
parseCommandLine :: [String] -> Maybe (String, String, [String])
parseCommandLine (confPath:[])
   | "--" `isPrefixOf` confPath = Nothing
parseCommandLine (confPath:[]) = Just (confPath, "", [])
parseCommandLine (confPath:everythingElse)
   | beginsWithSwitch everythingElse =
      Just (confPath, "", everythingElse)
   where
      beginsWithSwitch (first:_) = "--" `isPrefixOf` first
      beginsWithSwitch _         = False
parseCommandLine (confPath:action:switches) =
   Just (confPath, action, switches)
parseCommandLine _ = Nothing


main :: IO ()
main = do
   allArgs <- getArgs

   -- Special case where user asked for sample config
   when ("--sample-config" `elem` allArgs) sampleConfig

   case (parseCommandLine allArgs) of
      Nothing -> usage
      Just (confPath, action, rest) -> do
         conf <- liftM parseToMap $ readFile confPath

         -- Transform those raw args into complete args, or figure 
         -- out why we can't.
         let parseResult = runMult (parseArgs action) (Env conf rest)

         exitWith =<< either endBadly (invokeDuplicity action) parseResult