{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
module Debian.Control.ByteString
    ( Control'(..)
    , Paragraph'(..)
    , Field'(..)
    , Control
    , Paragraph
    , Field
    , ControlFunctions(..)
    -- * Helper Functions
    , mergeControls
    , fieldValue
    , removeField
    , prependFields
    , appendFields
    , renameField
    , modifyField
    , raiseFields
    ) where

-- Standard GHC modules

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (Alternative(..))
import qualified Control.Exception as E
import "mtl" Control.Monad.State

import Data.Char(toLower, isSpace)
import Data.List
import Control.Monad (MonadPlus(..), ap, liftM, unless)

import Text.ParserCombinators.Parsec.Error
import Text.ParserCombinators.Parsec.Pos

-- Third Party Modules

import qualified Data.ByteString.Char8 as C

import Debian.Control.Common hiding (protectFieldText')

-- Local Modules

-- import ByteStreamParser

-- * Types
{-
newtype Control = Control [Paragraph]
newtype Paragraph = Paragraph [Field]
newtype Field = Field (C.ByteString, C.ByteString)
-}

type Control = Control' C.ByteString
type Paragraph = Paragraph' C.ByteString
type Field = Field'  C.ByteString
-- * Control Parser

type ControlParser a = Parser C.ByteString a

pKey :: ControlParser C.ByteString
pKey :: ControlParser ByteString
pKey = forall st. Parser st ByteString -> Parser st ByteString
notEmpty forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ControlParser ByteString
pTakeWhile (\Char
c -> (Char
c forall a. Eq a => a -> a -> Bool
/= Char
':') Bool -> Bool -> Bool
&& (Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n'))

pValue :: ControlParser C.ByteString
pValue :: ControlParser ByteString
pValue = forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
    let newlines :: [Int]
newlines = Char -> ByteString -> [Int]
C.elemIndices Char
'\n' ByteString
bs
        rest :: [Int]
rest = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Int -> Bool
continuedAfter [Int]
newlines forall a. [a] -> [a] -> [a]
++ [ByteString -> Int
C.length ByteString
bs]
        continuedAfter :: Int -> Bool
continuedAfter Int
i = ByteString
bs ByteString -> Int -> Maybe Char
`safeIndex` (Int
iforall a. Num a => a -> a -> a
+Int
1) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just String
" \t#"
        (ByteString
text, ByteString
bs') = Int -> ByteString -> (ByteString, ByteString)
C.splitAt (forall a. [a] -> a
head [Int]
rest) ByteString
bs
    in forall a. a -> Result a
Ok (ByteString
text, ByteString
bs')

pField :: ControlParser Field
pField :: ControlParser Field
pField =
    do ByteString
k <- ControlParser ByteString
pKey
       Char
_ <- Char -> Parser ByteString Char
pChar Char
':'
       ByteString
v <- ControlParser ByteString
pValue
--       pChar '\n'
       (Char -> Parser ByteString Char
pChar Char
'\n' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString ()
pEOF
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. (a, a) -> Field' a
Field (ByteString
k,ByteString
v))

pComment :: ControlParser Field
pComment :: ControlParser Field
pComment = forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
    let newlines :: [Int]
newlines = Char -> ByteString -> [Int]
C.elemIndices Char
'\n' ByteString
bs
        linestarts :: [Int]
linestarts = Int
0 forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+Int
1) [Int]
newlines
        rest :: [Int]
rest = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Int -> Bool
commentAt [Int]
linestarts forall a. [a] -> [a] -> [a]
++ [ByteString -> Int
C.length ByteString
bs]
        commentAt :: Int -> Bool
commentAt Int
i = ByteString
bs ByteString -> Int -> Maybe Char
`safeIndex` Int
i forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Char
'#'
        (ByteString
text, ByteString
bs') = Int -> ByteString -> (ByteString, ByteString)
C.splitAt (forall a. [a] -> a
head [Int]
rest) ByteString
bs
    in if ByteString -> Bool
C.null ByteString
text
       then forall a. Result a
Empty
       else forall a. a -> Result a
Ok (forall a. a -> Field' a
Comment ByteString
text, ByteString
bs')

pParagraph :: ControlParser Paragraph
pParagraph :: ControlParser Paragraph
pParagraph =
    do [Field]
f <- forall st a. Parser st a -> Parser st [a]
pMany1 (ControlParser Field
pComment forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ControlParser Field
pField)
       forall st a. Parser st a -> Parser st ()
pSkipMany (Char -> Parser ByteString Char
pChar Char
'\n')
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Field' a] -> Paragraph' a
Paragraph [Field]
f)

pControl :: ControlParser Control
pControl :: ControlParser Control
pControl =
    do forall st a. Parser st a -> Parser st ()
pSkipMany (Char -> Parser ByteString Char
pChar Char
'\n')
       [Paragraph]
c <- forall st a. Parser st a -> Parser st [a]
pMany ControlParser Paragraph
pParagraph
       forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Paragraph' a] -> Control' a
Control [Paragraph]
c)


-- parseControlFromFile :: FilePath -> IO (Either String Control)

instance ControlFunctions C.ByteString where
    parseControlFromFile :: String -> IO (Either ParseError Control)
parseControlFromFile String
fp =
        do ByteString
c <- String -> IO ByteString
C.readFile String
fp
           case forall state a. Parser state a -> state -> Maybe (a, state)
parse ControlParser Control
pControl ByteString
c of
             Maybe (Control, ByteString)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left (Message -> SourcePos -> ParseError
newErrorMessage (String -> Message
Message (String
"Failed to parse " forall a. [a] -> [a] -> [a]
++ String
fp)) (String -> Int -> Int -> SourcePos
newPos String
fp Int
0 Int
0)))
             (Just (Control
cntl,ByteString
_)) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Control
cntl)
    parseControlFromHandle :: String -> Handle -> IO (Either ParseError Control)
parseControlFromHandle String
sourceName Handle
handle =
        forall e a. Exception e => IO a -> IO (Either e a)
E.try (Handle -> IO ByteString
C.hGetContents Handle
handle) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (SomeException
e :: E.SomeException) -> forall a. HasCallStack => String -> a
error (String
"parseControlFromHandle ByteString: Failure parsing " forall a. [a] -> [a] -> [a]
++ String
sourceName forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
ControlFunctions a =>
String -> a -> Either ParseError (Control' a)
parseControl String
sourceName)
    parseControl :: String -> ByteString -> Either ParseError Control
parseControl String
sourceName ByteString
c =
        do case forall state a. Parser state a -> state -> Maybe (a, state)
parse ControlParser Control
pControl ByteString
c of
             Maybe (Control, ByteString)
Nothing -> forall a b. a -> Either a b
Left (Message -> SourcePos -> ParseError
newErrorMessage (String -> Message
Message (String
"Failed to parse " forall a. [a] -> [a] -> [a]
++ String
sourceName)) (String -> Int -> Int -> SourcePos
newPos String
sourceName Int
0 Int
0))
             Just (Control
cntl,ByteString
_) -> forall a b. b -> Either a b
Right Control
cntl
    lookupP :: String -> Paragraph -> Maybe Field
lookupP String
fieldName (Paragraph [Field]
fields) =
        let pFieldName :: ByteString
pFieldName = String -> ByteString
C.pack (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
fieldName) in
        forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (Field (ByteString
fieldName',ByteString
_)) -> (Char -> Char) -> ByteString -> ByteString
C.map Char -> Char
toLower ByteString
fieldName' forall a. Eq a => a -> a -> Bool
== ByteString
pFieldName) [Field]
fields
    -- NOTE: probably inefficient
    stripWS :: ByteString -> ByteString
stripWS = ByteString -> ByteString
C.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
C.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
strip
        where strip :: ByteString -> ByteString
strip = (Char -> Bool) -> ByteString -> ByteString
C.dropWhile (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
' ', Char
'\t'])
    protectFieldText :: ByteString -> ByteString
protectFieldText = ByteString -> ByteString
protectFieldText'
    asString :: ByteString -> String
asString = ByteString -> String
C.unpack

protectFieldText' :: C.ByteString -> C.ByteString
protectFieldText' :: ByteString -> ByteString
protectFieldText' ByteString
s =
    case ByteString -> [ByteString]
C.lines ByteString
s of
      [] -> forall a. Monoid a => a
mempty
      (ByteString
l : [ByteString]
ls) -> (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
C.unlines forall a b. (a -> b) -> a -> b
$ ByteString
l forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
protect [ByteString]
ls
    where
      dropWhileEnd :: (Char -> Bool) -> C.ByteString -> C.ByteString
      dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd Char -> Bool
func = ByteString -> ByteString
C.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
C.dropWhile Char -> Bool
func forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
C.reverse
      protect :: C.ByteString -> C.ByteString
      protect :: ByteString -> ByteString
protect ByteString
l = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\ Char
c -> if Char -> Bool
isHorizSpace Char
c then ByteString
l else Char -> ByteString -> ByteString
C.cons Char
' ' ByteString
l) ((Char -> Bool) -> ByteString -> Maybe Char
C.find (forall a b. a -> b -> a
const Bool
True :: Char -> Bool) ByteString
l)
      isHorizSpace :: Char -> Bool
isHorizSpace Char
c = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
c String
" \t"

{-
main =
    do [fp] <- getArgs
       C.readFile fp >>= \c -> maybe (putStrLn "failed.") (print . length . fst) (parse pControl c)
-}
-- * Helper Functions

safeIndex :: C.ByteString -> Int -> Maybe Char
ByteString
bs safeIndex :: ByteString -> Int -> Maybe Char
`safeIndex` Int
i = if Int
i forall a. Ord a => a -> a -> Bool
< ByteString -> Int
C.length ByteString
bs then forall a. a -> Maybe a
Just (ByteString
bs ByteString -> Int -> Char
`C.index` Int
i) else forall a. Maybe a
Nothing

-- * Parser

data Result a
    = Ok a
    | Fail
    | Empty
      deriving Int -> Result a -> ShowS
forall a. Show a => Int -> Result a -> ShowS
forall a. Show a => [Result a] -> ShowS
forall a. Show a => Result a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result a] -> ShowS
$cshowList :: forall a. Show a => [Result a] -> ShowS
show :: Result a -> String
$cshow :: forall a. Show a => Result a -> String
showsPrec :: Int -> Result a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Result a -> ShowS
Show

-- m2r :: Maybe a -> Result a
-- m2r (Just a) = Ok a
-- m2r Nothing = Empty

r2m :: Result a -> Maybe a
r2m :: forall a. Result a -> Maybe a
r2m (Ok a
a) = forall a. a -> Maybe a
Just a
a
r2m Result a
_ = forall a. Maybe a
Nothing

newtype Parser state a = Parser { forall state a. Parser state a -> state -> Result (a, state)
unParser :: (state -> Result (a, state)) }

instance Functor (Parser state) where
    fmap :: forall a b. (a -> b) -> Parser state a -> Parser state b
fmap a -> b
f Parser state a
m =
        forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ state
state ->
            let r :: Result (a, state)
r = (forall state a. Parser state a -> state -> Result (a, state)
unParser Parser state a
m) state
state in
            case Result (a, state)
r of
              Ok (a
a,state
state') -> forall a. a -> Result a
Ok (a -> b
f a
a,state
state')
              Result (a, state)
Empty -> forall a. Result a
Empty
              Result (a, state)
Fail -> forall a. Result a
Fail

instance Applicative (Parser state) where
    pure :: forall a. a -> Parser state a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a b.
Parser state (a -> b) -> Parser state a -> Parser state b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative (Parser state) where
    empty :: forall a. Parser state a
empty =
        forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \state
state ->
            (forall state a. Parser state a -> state -> Result (a, state)
unParser forall (m :: * -> *) a. MonadPlus m => m a
mzero) state
state
    <|> :: forall a. Parser state a -> Parser state a -> Parser state a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance Monad (Parser state) where
    return :: forall a. a -> Parser state a
return a
a = forall state a. (state -> Result (a, state)) -> Parser state a
Parser (\state
s -> forall a. a -> Result a
Ok (a
a,state
s))
    Parser state a
m >>= :: forall a b.
Parser state a -> (a -> Parser state b) -> Parser state b
>>= a -> Parser state b
f =
        forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \state
state ->
            let r :: Result (a, state)
r = (forall state a. Parser state a -> state -> Result (a, state)
unParser Parser state a
m) state
state in
            case Result (a, state)
r of
              Ok (a
a,state
state') ->
                  case forall state a. Parser state a -> state -> Result (a, state)
unParser (a -> Parser state b
f a
a) forall a b. (a -> b) -> a -> b
$ state
state' of
                    Result (b, state)
Empty -> forall a. Result a
Fail
                    Result (b, state)
o -> Result (b, state)
o
              Result (a, state)
Empty -> forall a. Result a
Empty
              Result (a, state)
Fail -> forall a. Result a
Fail

instance MonadPlus (Parser state) where
    mzero :: forall a. Parser state a
mzero = forall state a. (state -> Result (a, state)) -> Parser state a
Parser (forall a b. a -> b -> a
const forall a. Result a
Empty)
    mplus :: forall a. Parser state a -> Parser state a -> Parser state a
mplus (Parser state -> Result (a, state)
p1) (Parser state -> Result (a, state)
p2) =
        forall state a. (state -> Result (a, state)) -> Parser state a
Parser (\state
s -> case state -> Result (a, state)
p1 state
s of
                        Result (a, state)
Empty -> state -> Result (a, state)
p2 state
s
                        Result (a, state)
o -> Result (a, state)
o
               )

--       Parser (\s -> maybe (p2 s) (Just) (p1 s))


_pSucceed :: a -> Parser state a
_pSucceed :: forall a state. a -> Parser state a
_pSucceed = forall (m :: * -> *) a. Monad m => a -> m a
return

_pFail :: Parser state a
_pFail :: forall state a. Parser state a
_pFail = forall state a. (state -> Result (a, state)) -> Parser state a
Parser (forall a b. a -> b -> a
const forall a. Result a
Empty)


satisfy :: (Char -> Bool) -> Parser C.ByteString Char
satisfy :: (Char -> Bool) -> Parser ByteString Char
satisfy Char -> Bool
f =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs ->
        if ByteString -> Bool
C.null ByteString
bs
        then forall a. Result a
Empty
        else let (Char
s,ByteString
ss) = (ByteString -> Char
C.head ByteString
bs, HasCallStack => ByteString -> ByteString
C.tail ByteString
bs) in
             if (Char -> Bool
f Char
s)
                then forall a. a -> Result a
Ok (Char
s,ByteString
ss)
                else forall a. Result a
Empty

pChar :: Char -> Parser C.ByteString Char
pChar :: Char -> Parser ByteString Char
pChar Char
c = (Char -> Bool) -> Parser ByteString Char
satisfy (forall a. Eq a => a -> a -> Bool
(==) Char
c)


_try :: Parser state a -> Parser state a
_try :: forall state a. Parser state a -> Parser state a
_try (Parser state -> Result (a, state)
p) =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \state
bs -> case (state -> Result (a, state)
p state
bs) of
                      Result (a, state)
Fail -> forall a. Result a
Empty
                      Result (a, state)
o -> Result (a, state)
o

pEOF :: Parser C.ByteString ()
pEOF :: Parser ByteString ()
pEOF =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> if ByteString -> Bool
C.null ByteString
bs then forall a. a -> Result a
Ok ((),ByteString
bs) else forall a. Result a
Empty

pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString
pTakeWhile :: (Char -> Bool) -> ControlParser ByteString
pTakeWhile Char -> Bool
f =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> forall a. a -> Result a
Ok ((Char -> Bool) -> ByteString -> (ByteString, ByteString)
C.span Char -> Bool
f ByteString
bs)

_pSkipWhile :: (Char -> Bool) -> Parser C.ByteString ()
_pSkipWhile :: (Char -> Bool) -> Parser ByteString ()
_pSkipWhile Char -> Bool
p =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \ByteString
bs -> forall a. a -> Result a
Ok ((), (Char -> Bool) -> ByteString -> ByteString
C.dropWhile Char -> Bool
p ByteString
bs)

pMany ::  Parser st a -> Parser st [a]
pMany :: forall st a. Parser st a -> Parser st [a]
pMany Parser st a
p
    = forall {a}. ([a] -> a) -> Parser st a
scan forall a. a -> a
id
    where
      scan :: ([a] -> a) -> Parser st a
scan [a] -> a
f = do a
x <- Parser st a
p
                  ([a] -> a) -> Parser st a
scan (\[a]
tail -> [a] -> a
f (a
xforall a. a -> [a] -> [a]
:[a]
tail))
               forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> a
f [])

notEmpty :: Parser st C.ByteString -> Parser st C.ByteString
notEmpty :: forall st. Parser st ByteString -> Parser st ByteString
notEmpty (Parser st -> Result (ByteString, st)
p) =
    forall state a. (state -> Result (a, state)) -> Parser state a
Parser forall a b. (a -> b) -> a -> b
$ \st
s -> case st -> Result (ByteString, st)
p st
s of
                     o :: Result (ByteString, st)
o@(Ok (ByteString
a, st
_s)) ->
                         if ByteString -> Bool
C.null ByteString
a
                         then forall a. Result a
Empty
                         else Result (ByteString, st)
o
                     Result (ByteString, st)
x -> Result (ByteString, st)
x

pMany1 :: Parser st a -> Parser st [a]
pMany1 :: forall st a. Parser st a -> Parser st [a]
pMany1 Parser st a
p =
    do a
x <- Parser st a
p
       [a]
xs <- forall st a. Parser st a -> Parser st [a]
pMany Parser st a
p
       forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall a. a -> [a] -> [a]
:[a]
xs)

pSkipMany :: Parser st a -> Parser st ()
pSkipMany :: forall st a. Parser st a -> Parser st ()
pSkipMany Parser st a
p = Parser st ()
scan
    where
      scan :: Parser st ()
scan = (Parser st a
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser st ()
scan) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return ()

_pSkipMany1 :: Parser st a -> Parser st ()
_pSkipMany1 :: forall st a. Parser st a -> Parser st ()
_pSkipMany1 Parser st a
p = Parser st a
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall st a. Parser st a -> Parser st ()
pSkipMany Parser st a
p

parse :: Parser state a -> state -> Maybe (a, state)
parse :: forall state a. Parser state a -> state -> Maybe (a, state)
parse Parser state a
p state
s = forall a. Result a -> Maybe a
r2m ((forall state a. Parser state a -> state -> Result (a, state)
unParser Parser state a
p) state
s)