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

pParagraph :: ControlParser Paragraph
pParagraph :: ParsecT [Char] () Identity (Paragraph' [Char])
pParagraph = ParsecT [Char] () Identity (Field' [Char])
-> ParsecT [Char] () Identity [Field' [Char]]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] () Identity (Field' [Char])
pComment ParsecT [Char] () Identity (Field' [Char])
-> ParsecT [Char] () Identity (Field' [Char])
-> ParsecT [Char] () Identity (Field' [Char])
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] () Identity (Field' [Char])
pField) ParsecT [Char] () Identity [Field' [Char]]
-> ([Field' [Char]]
    -> ParsecT [Char] () Identity (Paragraph' [Char]))
-> ParsecT [Char] () Identity (Paragraph' [Char])
forall a b.
ParsecT [Char] () Identity a
-> (a -> ParsecT [Char] () Identity b)
-> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Paragraph' [Char] -> ParsecT [Char] () Identity (Paragraph' [Char])
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Paragraph' [Char]
 -> ParsecT [Char] () Identity (Paragraph' [Char]))
-> ([Field' [Char]] -> Paragraph' [Char])
-> [Field' [Char]]
-> ParsecT [Char] () Identity (Paragraph' [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Field' [Char]] -> Paragraph' [Char]
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 [Char] () Identity (Field' [Char])
pField =
    do Char
c1 <- [Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"#\n"
       [Char]
fieldName <-  ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Char] () Identity Char
 -> ParsecT [Char] () Identity [Char])
-> ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
":\n"
       Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':'
       [Char]
fieldValue <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT [Char] () Identity Char
fcharfws
       (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n' ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity () -> ParsecT [Char] () Identity ()
forall a b.
ParsecT [Char] () Identity a
-> ParsecT [Char] () Identity b -> ParsecT [Char] () Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParsecT [Char] () Identity ()
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ParsecT [Char] () Identity ()
-> ParsecT [Char] () Identity () -> ParsecT [Char] () Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
       Field' [Char] -> ParsecT [Char] () Identity (Field' [Char])
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Field' [Char] -> ParsecT [Char] () Identity (Field' [Char]))
-> Field' [Char] -> ParsecT [Char] () Identity (Field' [Char])
forall a b. (a -> b) -> a -> b
$ ([Char], [Char]) -> Field' [Char]
forall a. (a, a) -> Field' a
Field (Char
c1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
fieldName, [Char]
fieldValue)

pComment :: ControlParser Field
pComment :: ParsecT [Char] () Identity (Field' [Char])
pComment =
    do Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'#'
       [Char]
text <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> Bool) -> ParsecT [Char] () 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 [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
       Field' [Char] -> ParsecT [Char] () Identity (Field' [Char])
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Field' [Char] -> ParsecT [Char] () Identity (Field' [Char]))
-> Field' [Char] -> ParsecT [Char] () Identity (Field' [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> Field' [Char]
forall a. a -> Field' a
Comment ([Char]
"#" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
text [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n")

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

fchar :: ControlParser Char
fchar :: ParsecT [Char] () Identity Char
fchar = (Char -> Bool) -> ParsecT [Char] () 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 [Char] () Identity [Char]
_fws =
    ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try (ParsecT [Char] () Identity [Char]
 -> ParsecT [Char] () Identity [Char])
-> ParsecT [Char] () Identity [Char]
-> ParsecT [Char] () Identity [Char]
forall a b. (a -> b) -> a -> b
$ do Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\n'
             [Char]
ws <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Char -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' ')
             [Char]
c <- ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT [Char] () 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 [Char] () Identity [Char]
forall a. a -> ParsecT [Char] () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> ParsecT [Char] () Identity [Char])
-> [Char] -> ParsecT [Char] () Identity [Char]
forall a b. (a -> b) -> a -> b
$ Char
'\n' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: ([Char]
ws [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 [Char] () Identity [Char]
pBlanks = ParsecT [Char] () Identity Char
-> ParsecT [Char] () Identity [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> ParsecT [Char] () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" \n")