{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-}
module Debian.Control.String
    ( -- * Types
      Control'(..)
    , Paragraph'(..)
    , Field'(..)
    , Control
    , Paragraph
    , Field
    , ControlParser
    , ControlFunctions(..)
    -- * Control File Parser
    , pControl
    -- * Helper Functions
    , mergeControls
    , fieldValue
    , removeField
    , prependFields
    , appendFields
    , renameField
    , modifyField
    , raiseFields
    ) where

import qualified Control.Exception as E
import Data.Char (toLower)
import Data.List (find)
import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, protectFieldText, asString),
                              Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment),
                              mergeControls, fieldValue, removeField, prependFields, appendFields,
                              renameField, modifyField, raiseFields, protectFieldText')
import System.IO (hGetContents)
import Text.ParserCombinators.Parsec (CharParser, parse, parseFromFile, sepEndBy, satisfy, oneOf, string, lookAhead, try, many, many1, (<|>), noneOf, char, eof)

type Field = Field' String
type Control = Control' String
type Paragraph = Paragraph' String

-- * ControlFunctions

instance ControlFunctions String where
    parseControlFromFile :: String -> IO (Either ParseError (Control' String))
parseControlFromFile String
filepath =
        Parser (Control' String)
-> String -> IO (Either ParseError (Control' String))
forall a. Parser a -> String -> IO (Either ParseError a)
parseFromFile Parser (Control' String)
pControl String
filepath
    parseControlFromHandle :: String -> Handle -> IO (Either ParseError (Control' String))
parseControlFromHandle String
sourceName Handle
handle =
        IO String -> IO (Either SomeException String)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (Handle -> IO String
hGetContents Handle
handle) IO (Either SomeException String)
-> (Either SomeException String
    -> IO (Either ParseError (Control' String)))
-> IO (Either ParseError (Control' String))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (SomeException -> IO (Either ParseError (Control' String)))
-> (String -> IO (Either ParseError (Control' String)))
-> Either SomeException String
-> IO (Either ParseError (Control' String))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (SomeException
e :: E.SomeException) -> String -> IO (Either ParseError (Control' String))
forall a. HasCallStack => String -> a
error (String
"parseControlFromHandle String: Failure parsing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sourceName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)) (Either ParseError (Control' String)
-> IO (Either ParseError (Control' String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ParseError (Control' String)
 -> IO (Either ParseError (Control' String)))
-> (String -> Either ParseError (Control' String))
-> String
-> IO (Either ParseError (Control' String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Either ParseError (Control' String)
forall a.
ControlFunctions a =>
String -> a -> Either ParseError (Control' a)
parseControl String
sourceName)
    parseControl :: String -> String -> Either ParseError (Control' String)
parseControl String
sourceName String
c =
        Parser (Control' String)
-> String -> String -> Either ParseError (Control' String)
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser (Control' String)
pControl String
sourceName String
c
    lookupP :: String -> Paragraph' String -> Maybe (Field' String)
lookupP String
fieldName (Paragraph [Field' String]
paragraph) =
        (Field' String -> Bool) -> [Field' String] -> Maybe (Field' String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> Field' String -> Bool
hasFieldName ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fieldName)) [Field' String]
paragraph
        where hasFieldName :: String -> Field' String -> Bool
hasFieldName String
name (Field (String
fieldName',String
_)) = String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fieldName'
              hasFieldName String
_ Field' String
_ = Bool
False
    stripWS :: String -> String
stripWS = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
strip (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
strip
        where strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String
" \t" :: [Char]))
    protectFieldText :: String -> String
protectFieldText = String -> String
forall a.
(StringLike a, ListLike a Char, ControlFunctions a) =>
a -> a
protectFieldText'
    asString :: String -> String
asString = String -> String
forall a. a -> a
id

-- * Control File Parser

type ControlParser a = CharParser () a

-- |A parser for debian control file. This parser handles control files
-- that end without a newline as well as ones that have several blank
-- lines at the end. It is very liberal and does not attempt validate
-- the fields in any way. All trailing, leading, and folded whitespace
-- is preserved in the field values. See 'stripWS'.
pControl :: ControlParser Control
pControl :: Parser (Control' String)
pControl =
    do ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
       ParsecT String () Identity (Paragraph' String)
-> ParsecT String () Identity String
-> ParsecT String () Identity [Paragraph' 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]
sepEndBy ParsecT String () Identity (Paragraph' String)
pParagraph ParsecT String () Identity String
pBlanks ParsecT String () Identity [Paragraph' String]
-> ([Paragraph' String] -> Parser (Control' String))
-> Parser (Control' String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Control' String -> Parser (Control' String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Control' String -> Parser (Control' String))
-> ([Paragraph' String] -> Control' String)
-> [Paragraph' String]
-> Parser (Control' String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Paragraph' String] -> Control' String
forall a. [Paragraph' a] -> Control' a
Control

pParagraph :: ControlParser Paragraph
pParagraph :: ParsecT String () Identity (Paragraph' String)
pParagraph = ParsecT String () Identity (Field' String)
-> ParsecT String () Identity [Field' String]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String () Identity (Field' String)
pComment ParsecT String () Identity (Field' String)
-> ParsecT String () Identity (Field' String)
-> ParsecT String () Identity (Field' String)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity (Field' String)
pField) ParsecT String () Identity [Field' String]
-> ([Field' String]
    -> ParsecT String () Identity (Paragraph' String))
-> ParsecT String () Identity (Paragraph' String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Paragraph' String -> ParsecT String () Identity (Paragraph' String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Paragraph' String
 -> ParsecT String () Identity (Paragraph' String))
-> ([Field' String] -> Paragraph' String)
-> [Field' String]
-> ParsecT String () Identity (Paragraph' String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field' String] -> Paragraph' String
forall a. [Field' a] -> Paragraph' a
Paragraph

-- |We are liberal in that we allow *any* field to have folded white
-- space, even though the specific restricts that to a few fields.
pField :: ControlParser Field
pField :: ParsecT String () Identity (Field' String)
pField =
    do Char
c1 <- String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"#\n"
       String
fieldName <-  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 (ParsecT String () Identity Char
 -> ParsecT String () Identity String)
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
":\n"
       Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
       String
fieldValue <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String () Identity Char
fcharfws
       (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n' ParsecT String () Identity Char
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT String () Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ParsecT String () Identity ()
-> ParsecT String () Identity () -> ParsecT String () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT String () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
       Field' String -> ParsecT String () Identity (Field' String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Field' String -> ParsecT String () Identity (Field' String))
-> Field' String -> ParsecT String () Identity (Field' String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Field' String
forall a. (a, a) -> Field' a
Field (Char
c1 Char -> String -> String
forall a. a -> [a] -> [a]
: String
fieldName, String
fieldValue)

pComment :: ControlParser Field
pComment :: ParsecT String () Identity (Field' String)
pComment =
    do Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#'
       String
text <- ParsecT String () Identity Char
-> ParsecT String () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
'\n')))
       Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
       Field' String -> ParsecT String () Identity (Field' String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Field' String -> ParsecT String () Identity (Field' String))
-> Field' String -> ParsecT String () Identity (Field' String)
forall a b. (a -> b) -> a -> b
$ String -> Field' String
forall a. a -> Field' a
Comment (String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
text String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")

fcharfws :: ControlParser Char
fcharfws :: ParsecT String () Identity Char
fcharfws = ParsecT String () Identity Char
fchar ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
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 Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n ") ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n') ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
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 Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n\t") ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n') ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
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 Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity Char
 -> ParsecT String () Identity Char)
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall a b. (a -> b) -> a -> b
$ ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (String -> ParsecT String () Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\n#") ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n')

fchar :: ControlParser Char
fchar :: ParsecT String () Identity Char
fchar = (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n')

_fws :: ControlParser String
_fws :: ParsecT String () Identity String
_fws =
    ParsecT String () Identity String
-> ParsecT String () Identity String
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT String () Identity String
 -> ParsecT String () Identity String)
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a b. (a -> b) -> a -> b
$ do Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
             String
ws <- 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 (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ')
             String
c <- 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 ((Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) Char
'\n')))
             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
$ Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: (String
ws String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c)

-- |We go with the assumption that 'blank lines' mean lines that
-- consist of entirely of zero or more whitespace characters.
pBlanks :: ControlParser String
pBlanks :: ParsecT String () Identity String
pBlanks = 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
oneOf String
" \n")