-- HTTP parsing utilities
-- Copyright   :  (c) Peter Thiemann 2001,2002
--                (c) Bjorn Bringert 2005-2006
module Network.MoHWS.ParserUtility where

import Network.MoHWS.Utility (splitBy, )

import qualified Data.List.Reverse.StrictSpine as Rev
import Data.Char (chr, )
import Data.List ((\\), )
import System.IO (Handle, hGetLine, )
import Text.ParserCombinators.Parsec
          (GenParser, Parser, char, string,
           (<|>), try, oneOf, noneOf, option, skipMany, many, many1, )

import Control.Monad (liftM2, )


pSP :: Parser Char
pSP :: Parser Char
pSP = Char -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
' '

-- | RFC 822 LWSP-char
pWS1 :: Parser Char
pWS1 :: Parser Char
pWS1 = [Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
" \t"

crLf :: String
crLf :: [Char]
crLf = [Char]
"\r\n"

-- | RFC 2616 CRLF
pCRLF :: Parser String
pCRLF :: Parser [Char]
pCRLF = Parser [Char] -> Parser [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\r\n" Parser [Char] -> Parser [Char] -> Parser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\n\r") Parser [Char] -> Parser [Char] -> Parser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\n" Parser [Char] -> Parser [Char] -> Parser [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [Char] -> Parser [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"\r"

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme Parser a
p = do a
x <- Parser a
p; Parser Char -> ParsecT [Char] () Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany Parser Char
pWS1; a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | One line
lineString :: Parser String
lineString :: Parser [Char]
lineString = Parser Char -> Parser [Char]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ([Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"\n\r")

headerNameChar :: Parser Char
headerNameChar :: Parser Char
headerNameChar = [Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"\n\r:"

especials, tokenchar :: [Char]
especials :: [Char]
especials = [Char]
"()<>@,;:\\\"/[]?.="
tokenchar :: [Char]
tokenchar = [Char]
"!\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" [Char] -> [Char] -> [Char]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Char]
especials

pToken :: Parser String
pToken :: Parser [Char]
pToken = Parser Char -> Parser [Char]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ([Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
tokenchar)

textChars :: [Char]
textChars :: [Char]
textChars = (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr ([Int
1..Int
9] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
11,Int
12] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
14..Int
127])

pText :: Parser Char
pText :: Parser Char
pText = [Char] -> Parser Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
oneOf [Char]
textChars


-- parse the list format described in RFC 2616, section 2.1
parseList :: String -> [String]
parseList :: [Char] -> [[Char]]
parseList = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
trimLWS ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [[a]]
splitBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
',')

dropLeadingLWS :: String -> String
dropLeadingLWS :: [Char] -> [Char]
dropLeadingLWS = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isLWSChar

trimLWS :: String -> String
trimLWS :: [Char] -> [Char]
trimLWS = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
Rev.dropWhile Char -> Bool
isLWSChar ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropLeadingLWS

isLWSChar :: Char -> Bool
isLWSChar :: Char -> Bool
isLWSChar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'


-- Read input up to the first empty line
getUntilEmptyLine :: Handle -> IO String
getUntilEmptyLine :: Handle -> IO [Char]
getUntilEmptyLine Handle
h =
    do [Char]
l <- Handle -> IO [Char]
hGetLine Handle
h
       if [Char] -> Bool
emptyLine [Char]
l
         then [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"\n"
         else Handle -> IO [Char]
getUntilEmptyLine Handle
h IO [Char] -> ([Char] -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> IO [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> ([Char] -> [Char]) -> [Char] -> IO [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char]
l[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'\n'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:))

emptyLine :: String -> Bool
emptyLine :: [Char] -> Bool
emptyLine [Char]
"\r" = Bool
True
emptyLine [Char]
""   = Bool
True
emptyLine [Char]
_    = Bool
False


countBetween :: Int -> Int -> GenParser tok st a -> GenParser tok st [a]
countBetween :: Int -> Int -> GenParser tok st a -> GenParser tok st [a]
countBetween Int
0 Int
0 GenParser tok st a
_ = [a] -> GenParser tok st [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
countBetween Int
0 Int
ma GenParser tok st a
p = [a] -> GenParser tok st [a] -> GenParser tok st [a]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] ((a -> [a] -> [a])
-> GenParser tok st a
-> GenParser tok st [a]
-> GenParser tok st [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) GenParser tok st a
p (Int -> Int -> GenParser tok st a -> GenParser tok st [a]
forall tok st a.
Int -> Int -> GenParser tok st a -> GenParser tok st [a]
countBetween Int
0 (Int
maInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) GenParser tok st a
p))
countBetween Int
mi Int
ma GenParser tok st a
p = (a -> [a] -> [a])
-> GenParser tok st a
-> GenParser tok st [a]
-> GenParser tok st [a]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) GenParser tok st a
p (Int -> Int -> GenParser tok st a -> GenParser tok st [a]
forall tok st a.
Int -> Int -> GenParser tok st a -> GenParser tok st [a]
countBetween (Int
miInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
maInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) GenParser tok st a
p)