module Debian.Control.ByteString
( Control'(..)
, Paragraph'(..)
, Field'(..)
, Control
, Paragraph
, Field
, ControlFunctions(..)
, mergeControls
, fieldValue
, removeField
, prependFields
, appendFields
, renameField
, modifyField
, raiseFields
) where
import qualified Control.Exception as E
import "mtl" Control.Monad.State
import Data.Char(chr,ord,toLower)
import Data.List
import Data.Word
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe
import Text.ParserCombinators.Parsec.Error
import Text.ParserCombinators.Parsec.Pos
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BB
import qualified Data.ByteString.Internal as BB
import qualified Data.ByteString.Char8 as C
import Debian.Control.Common
type Control = Control' C.ByteString
type Paragraph = Paragraph' C.ByteString
type Field = Field' C.ByteString
type ControlParser a = Parser C.ByteString a
pKey :: ControlParser C.ByteString
pKey = notEmpty $ pTakeWhile (\c -> (c /= ':') && (c /= '\n'))
pValue :: ControlParser C.ByteString
pValue = pTakeWhile2 (\a b -> not (endOfValue a b))
where
endOfValue :: Char -> Maybe Char -> Bool
endOfValue '\n' Nothing = True
endOfValue '\n' (Just ' ') = False
endOfValue '\n' (Just '\t') = False
endOfValue '\n' (Just '#') = False
endOfValue '\n' _ = True
endOfValue _ _ = False
pField :: ControlParser Field
pField =
do k <- pKey
_ <- pChar ':'
v <- pValue
(pChar '\n' >> return ()) <|> pEOF
return (Field (k,v))
pComment :: ControlParser Field
pComment =
do c1 <- pChar '#'
text <- pTakeWhile2 (\ a b -> not (endOfComment a b))
return . Comment $ (B.append (B.singleton . c2w $ c1) text)
where
endOfComment '\n' Nothing = True
endOfComment '\n' (Just '#') = False
endOfComment '\n' _ = True
endOfComment _ _ = False
pParagraph :: ControlParser Paragraph
pParagraph =
do f <- pMany1 (pComment <|> pField)
pSkipMany (pChar '\n')
return (Paragraph f)
pControl :: ControlParser Control
pControl =
do pSkipMany (pChar '\n')
c <- pMany pParagraph
return (Control c)
instance ControlFunctions C.ByteString where
parseControlFromFile fp =
do c <- C.readFile fp
case parse pControl c of
Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0)))
(Just (cntl,_)) -> return (Right cntl)
parseControlFromHandle sourceName handle =
E.try (C.hGetContents handle) >>=
either (\ (e :: E.SomeException) -> error ("parseControlFromHandle ByteString: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName)
parseControl sourceName c =
do case parse pControl c of
Nothing -> Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0))
Just (cntl,_) -> Right cntl
lookupP fieldName (Paragraph fields) =
let pFieldName = C.pack (map toLower fieldName) in
find (\ (Field (fieldName',_)) -> C.map toLower fieldName' == pFieldName) fields
stripWS = C.reverse . strip . C.reverse . strip
where strip = C.dropWhile (flip elem " \t")
asString = C.unpack
_takeWhile2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> B.ByteString
_takeWhile2 f ps = BB.unsafeTake (findIndex2OrEnd (\w1 w2 -> not (f w1 w2)) ps) ps
break2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)
break2 p ps = case findIndex2OrEnd p ps of n -> Just (BB.unsafeTake n ps, BB.unsafeDrop n ps)
span2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe (B.ByteString, B.ByteString)
span2 p ps = break2 (\a b -> not (p a b)) ps
findIndex2OrEnd :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Int
findIndex2OrEnd k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
where
go a b | a `seq` b `seq` False = undefined
go ptr n | n >= l = return l
| otherwise = do w1 <- peek ptr
w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing
if k w1 w2
then return n
else go (ptr `plusPtr` 1) (n+1)
_findIndex2 :: (Word8 -> Maybe Word8 -> Bool) -> B.ByteString -> Maybe Int
_findIndex2 k (BB.PS x s l) = unsafePerformIO $ withForeignPtr x $ \f -> go (f `plusPtr` s) 0
where
go a b | a `seq` b `seq` False = undefined
go ptr n | n >= l = return Nothing
| otherwise = do w1 <- peek ptr
w2 <- if (n + 1 < l) then (peek (ptr `plusPtr` 1) >>= return . Just) else return Nothing
if k w1 w2
then return (Just n)
else go (ptr `plusPtr` 1) (n+1)
w2c :: Word8 -> Char
w2c = chr . fromIntegral
c2w :: Char -> Word8
c2w = fromIntegral . ord
data Result a
= Ok a
| Fail
| Empty
deriving Show
m2r :: Maybe a -> Result a
m2r (Just a) = Ok a
m2r Nothing = Empty
r2m :: Result a -> Maybe a
r2m (Ok a) = Just a
r2m _ = Nothing
newtype Parser state a = Parser { unParser :: (state -> Result (a, state)) }
instance Monad (Parser state) where
return a = Parser (\s -> Ok (a,s))
m >>= f =
Parser $ \state ->
let r = (unParser m) state in
case r of
Ok (a,state') ->
case unParser (f a) $ state' of
Empty -> Fail
o -> o
Empty -> Empty
Fail -> Fail
instance MonadPlus (Parser state) where
mzero = Parser (const Empty)
mplus (Parser p1) (Parser p2) =
Parser (\s -> case p1 s of
Empty -> p2 s
o -> o
)
_pSucceed :: a -> Parser state a
_pSucceed = return
_pFail :: Parser state a
_pFail = Parser (const Empty)
(<|>) :: Parser state a -> Parser state a -> Parser state a
(<|>) = mplus
satisfy :: (Char -> Bool) -> Parser C.ByteString Char
satisfy f =
Parser $ \bs ->
if C.null bs
then Empty
else let (s,ss) = (C.head bs, C.tail bs) in
if (f s)
then Ok (s,ss)
else Empty
pChar :: Char -> Parser C.ByteString Char
pChar c = satisfy ((==) c)
_try :: Parser state a -> Parser state a
_try (Parser p) =
Parser $ \bs -> case (p bs) of
Fail -> Empty
o -> o
pEOF :: Parser C.ByteString ()
pEOF =
Parser $ \bs -> if C.null bs then Ok ((),bs) else Empty
pTakeWhile2 :: (Char -> Maybe Char -> Bool) -> Parser C.ByteString C.ByteString
pTakeWhile2 f =
Parser $ \bs -> m2r (span2 (\w1 w2 -> f (w2c w1) (fmap w2c w2)) bs)
pTakeWhile :: (Char -> Bool) -> Parser C.ByteString C.ByteString
pTakeWhile f =
Parser $ \bs -> Ok (B.span (\w -> f (w2c w)) bs)
_pSkipWhile :: (Char -> Bool) -> Parser C.ByteString ()
_pSkipWhile p =
Parser $ \bs -> Ok ((), C.dropWhile p bs)
pMany :: Parser st a -> Parser st [a]
pMany p
= scan id
where
scan f = do x <- p
scan (\tail -> f (x:tail))
<|> return (f [])
notEmpty :: Parser st C.ByteString -> Parser st C.ByteString
notEmpty (Parser p) =
Parser $ \s -> case p s of
o@(Ok (a, _s)) ->
if C.null a
then Empty
else o
x -> x
pMany1 :: Parser st a -> Parser st [a]
pMany1 p =
do x <- p
xs <- pMany p
return (x:xs)
pSkipMany :: Parser st a -> Parser st ()
pSkipMany p = scan
where
scan = (p >> scan) <|> return ()
_pSkipMany1 :: Parser st a -> Parser st ()
_pSkipMany1 p = p >> pSkipMany p
parse :: Parser state a -> state -> Maybe (a, state)
parse p s = r2m ((unParser p) s)