-- Copyright (C) 2005 Benedikt Schmidt
--
-- This program 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 2, or (at your option)
-- any later version.
--
-- This program 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 this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

-- |
-- Module      : Darcs.Util.CommandLine
-- Copyright   : 2005 Benedikt Schmidt
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable
--
-- |A parser for commandlines, returns an arg list and expands
-- format strings given in a translation table. Additionally
-- the commandline can end with "%<" specifying that the command
-- expects input on stdin.
--
-- See Darcs.Test.Misc.CommandLine for tests.

module Darcs.Util.CommandLine
    ( parseCmd
    , addUrlencoded
    ) where

import Darcs.Prelude

import Control.Arrow ( (***) )
import Data.Char ( ord, intToDigit, toUpper )
import Data.List ( find )
import Text.ParserCombinators.Parsec

-- | assoc list mapping characters to strings
-- eg (c,s) means that %c is replaced by s
type FTable = [(Char,String)]

commandline :: FTable -> Parser ([String], Bool)
commandline :: FTable -> Parser ([String], Bool)
commandline FTable
ftable = Parser ([String], Bool) -> Parser ([String], Bool)
forall a. Parser a -> Parser a
consumeAll (Parser ([String], Bool) -> Parser ([String], Bool))
-> Parser ([String], Bool) -> Parser ([String], Bool)
forall a b. (a -> b) -> a -> b
$ do
    [String]
l <- ParsecT String () Identity String
-> ParsecT String () Identity ()
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepEndBy1 (FTable -> ParsecT String () Identity String
arg FTable
ftable) (ParsecT String () Identity () -> ParsecT String () Identity ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String () Identity ()
separator)
    Bool
redir <- Parser Bool
formatRedir
    ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
    ([String], Bool) -> Parser ([String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([String]
l,Bool
redir)

arg :: FTable -> Parser String
arg :: FTable -> ParsecT String () Identity String
arg FTable
ftable = FTable -> ParsecT String () Identity String
quotedArg FTable
ftable ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> FTable -> ParsecT String () Identity String
unquotedArg FTable
ftable

unquotedArg :: FTable -> Parser String
unquotedArg :: FTable -> ParsecT String () Identity String
unquotedArg FTable
ftable = ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (FTable -> ParsecT String () Identity String
format FTable
ftable) ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
" \t\"%")

quotedArg :: FTable -> Parser String
quotedArg :: FTable -> ParsecT String () Identity String
quotedArg FTable
ftable = ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
quoteChar ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
quoteChar (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ FTable -> ParsecT String () Identity String
quoteContent FTable
ftable
  where
    quoteChar :: ParsecT String u Identity Char
quoteChar = Char -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"'

quoteContent :: FTable -> Parser String
quoteContent :: FTable -> ParsecT String () Identity String
quoteContent FTable
ftable = do String
s1 <- ParsecT String () Identity String
escape
                               ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (FTable -> ParsecT String () Identity String
format FTable
ftable)
                               ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"\"\\%")
                         String
s2 <- FTable -> ParsecT String () Identity String
quoteContent FTable
ftable
                         String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ParsecT String () Identity String)
-> String -> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s2
                     ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

formatRedir :: Parser Bool
formatRedir :: Parser Bool
formatRedir = (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"%<" ParsecT String () Identity String -> Parser Bool -> Parser Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
              Parser Bool -> Parser Bool -> Parser Bool
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Bool -> Parser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

format :: FTable -> Parser String
format :: FTable -> ParsecT String () Identity String
format FTable
ftable = do Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'%'
                   Char
c <- String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf (((Char, String) -> Char) -> FTable -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, String) -> Char
forall a b. (a, b) -> a
fst FTable
ftable)
                   String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ParsecT String () Identity String)
-> String -> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ FTable -> Char -> String
expandFormat FTable
ftable Char
c

escape :: Parser String
escape :: ParsecT String () Identity String
escape = do Char
_ <- Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\'
            Char
c <- ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
            String -> ParsecT String () Identity String
forall (m :: * -> *) a. Monad m => a -> m a
return [Char
c]

consumeAll :: Parser a -> Parser a
consumeAll :: Parser a -> Parser a
consumeAll Parser a
p = do a
r <- Parser a
p
                  ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
                  a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

separator :: Parser ()
separator :: ParsecT String () Identity ()
separator = ParsecT String () Identity Char -> ParsecT String () Identity ()
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m ()
skipMany1 ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space

expandFormat :: FTable -> Char -> String
expandFormat :: FTable -> Char -> String
expandFormat FTable
ftable Char
c = case ((Char, String) -> Bool) -> FTable -> Maybe (Char, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
c) (Char -> Bool)
-> ((Char, String) -> Char) -> (Char, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, String) -> Char
forall a b. (a, b) -> a
fst) FTable
ftable of
                            Just (Char
_,String
s) -> String
s
                            Maybe (Char, String)
Nothing -> String -> String
forall a. HasCallStack => String -> a
error String
"impossible"

-- | parse a commandline returning a list of strings
-- (intended to be used as argv) and a bool value which
-- specifies if the command expects input on stdin
-- format specifiers with a mapping in ftable are accepted
-- and replaced by the given strings. E.g. if the ftable is
-- [('s',"Some subject")], then "%s" is replaced by "Some subject"
parseCmd :: FTable -> String -> Either ParseError ([String],Bool)
parseCmd :: FTable -> String -> Either ParseError ([String], Bool)
parseCmd FTable
ftable = Parser ([String], Bool)
-> String -> String -> Either ParseError ([String], Bool)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (FTable -> Parser ([String], Bool)
commandline FTable
ftable) String
""

urlEncode :: String -> String
urlEncode :: String -> String
urlEncode = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeC
    where escapeC :: Char -> String
escapeC Char
x = if Char -> Bool
allowed Char
x then [Char
x] else Char
'%' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
intToHex (Char -> Int
ord Char
x)
          intToHex :: Int -> String
intToHex Int
i = (Int -> Char) -> [Int] -> String
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
intToDigit [Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
16, Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
16]
          allowed :: Char -> Bool
allowed Char
x = Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
allowedChars
          allowedChars :: String
allowedChars = [Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!'()*-.~"

-- | for every mapping (c,s), add a mapping with uppercase c
-- and the urlencoded string s
addUrlencoded :: FTable -> FTable
addUrlencoded :: FTable -> FTable
addUrlencoded FTable
ftable = FTable
ftable FTable -> FTable -> FTable
forall a. [a] -> [a] -> [a]
++ ((Char, String) -> (Char, String)) -> FTable -> FTable
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char
toUpper (Char -> Char)
-> (String -> String) -> (Char, String) -> (Char, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** String -> String
urlEncode) FTable
ftable