data-embed-0.1.0.0: embedtool.hs

-- | Main module for @embedtool@, a command line interface to @data-embed@.
module Main where
import Control.Monad
import Data.Embed.File
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO

data Overwrite = Append | Replace | DontOverwrite
  deriving Show

data Option
  = Write                  -- Write a bundle to an executable
  | Erase                  -- Erase an existing bundle
  | Check                  -- Check if a file contains a bundle or not
  | List                   -- List all files in a bundle
  | PrintHelp              -- Print help message and exit
  | PrintUsage             -- Print usage message and exit
  | SetOverwrite Overwrite -- Set overwrite mode
  | SetStrip Int           -- Set the number of leading directories to strip
                           -- from file names added to bundle
    deriving Show

optspec :: [OptDescr Option]
optspec =
  [ Option "w" ["write"]     (NoArg Write) $
    "Write a bundle to a file. Do nothing if the file already has a bundle."
  , Option "r" ["replace"]   (NoArg (SetOverwrite Replace)) $
    "When writing a bundle to a file, overwrite any previously existing " ++
    "bundle."
  , Option "a" ["append"]    (NoArg (SetOverwrite Append)) $
    "When writing a bundle to a file, leave the old one in place but " ++
    "append the new one at the end of the file."
  , Option "p" ["strip"]     (ReqArg (SetStrip . read) "NUM") $
    "Strip up to NUM leading directories from file names added to bundle.\n" ++
    "`embedtool -p1 -w outfile dir/infile' will add `dir/infile' to the " ++
    "bundle with the name `infile'."
  , Option "ed" ["erase"]    (NoArg Erase) $
    "Erase previously created bundles from any of the given files."
  , Option "l" ["list"]      (NoArg List) $
    "List all files in the given bundle."
  , Option "c" ["check"]     (NoArg Check) $
    "Check whether the given file contains a bundle or not."
  , Option "?h" ["help"]     (NoArg PrintHelp) $
    "Print this message and exit."
  ]

helpHeader :: String
helpHeader = concat
  [ "embedtool creates, modifies and inspects file bundles for use with the "
  , "`data-bundle' library. It accepts the following options:"
  ]

main :: IO ()
main = do
  args <- getArgs
  case getOpt Permute optspec args of
    (opts, nonopts, []) -> runAct (getAction opts) (writeOpts opts) nonopts
    (_, _, errs)        -> mapM_ (hPutStr stderr) errs >> exitFailure

-- | Extract write options from the given list of options.
writeOpts :: [Option] -> (Overwrite, Int)
writeOpts = foldl writeOpt (DontOverwrite, 0)
  where
    writeOpt (_, s)   (SetOverwrite ovr) = (ovr, s)
    writeOpt (ovr, _) (SetStrip s)       = (ovr, s)
    writeOpt acc      _                     = acc

-- | Get the action to perform from the given list of options.
getAction :: [Option] -> Option
getAction = foldl getAct PrintUsage
  where
    getAct acc (SetOverwrite _) = acc
    getAct acc (SetStrip _)     = acc
    getAct _   act              = act

runAct :: Option -> (Overwrite, Int) -> [String] -> IO ()
runAct Write (ovr, s) fs = do
  case fs of
    (outf : infs) | not (null infs) -> do
      alreadyHasBundle <- hasBundle outf
      when alreadyHasBundle $ do
        case ovr of
          DontOverwrite -> do
            hPutStrLn stderr $ "file `" ++ outf ++ "' already has a " ++
                               "bundle; aborting"
            exitFailure
          Replace ->
            eraseBundle outf
          _ ->
            return ()
      appendBundle outf (map (FilePath s) infs)
    _ -> do
      hPutStrLn stderr $ "need an output file and at least one input file " ++
                         "to create a bundle"
      hPutStrLn stderr $ "try `embedtool -w outfile infile1 [infile2 ...]'"
      exitFailure
runAct Erase _ outfs = do
  when (null outfs) $ do
    hPutStrLn stderr $ "need at least one file to erase bundle from"
    hPutStrLn stderr $ "try `embedtool -e file1 [file2 ...]'"
    exitFailure
  mapM_ eraseBundle outfs
runAct Check _ infs = do
  case infs of
    [inf] -> do
      ok <- hasBundle inf
      putStrLn $ if ok then "yes" else "no"
    _ -> do
      hPutStrLn stderr $ "need exactly one file to check for bundles"
      hPutStrLn stderr $ "try `embedtool -c file'"
      exitFailure
runAct List _ infs = do
  case infs of
    [inf] -> do
      res <- withBundle inf (mapM_ putStrLn . listBundleFiles)
      case res of
        Right _ -> return ()
        Left e  -> do
          hPutStrLn stderr $ "failed to read bundle: " ++ e
          exitFailure
    _ -> do
      hPutStrLn stderr $ "need exactly one file to list files from"
      hPutStrLn stderr $ "try `embedtool -l file'"
      exitFailure
runAct PrintHelp _ _ = do
  putStr $ usageInfo helpHeader optspec
runAct PrintUsage _ _ = do
  putStrLn "usage: embedtool OPTIONS FILE [FILES]"
  putStrLn "try `embedtool --help' for more information"
  exitFailure
runAct opt _ _ = do
  error $ "BUG: option `" ++ show opt ++ "' is not an action!"