Http.hs

-- |This is an auxiliary parser utilities for parsing things related
-- on HTTP protocol.
--
-- In general you don't have to use this module directly.
module Network.HTTP.Lucu.Parser.Http
    ( isCtl
    , isSeparator
    , isChar
    , isToken
    , listOf
    , token
    , lws
    , text
    , separator
    , quotedStr
    , qvalue
    )
    where

import           Data.List
import           Network.HTTP.Lucu.Parser

-- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= @c@ < 0x7F@.
isCtl :: Char -> Bool
isCtl c
    | c <  '\x1f' = True
    | c >= '\x7f' = True
    | otherwise   = False

-- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
-- separators.
isSeparator :: Char -> Bool
isSeparator '('  = True
isSeparator ')'  = True
isSeparator '<'  = True
isSeparator '>'  = True
isSeparator '@'  = True
isSeparator ','  = True
isSeparator ';'  = True
isSeparator ':'  = True
isSeparator '\\' = True
isSeparator '"'  = True
isSeparator '/'  = True
isSeparator '['  = True
isSeparator ']'  = True
isSeparator '?'  = True
isSeparator '='  = True
isSeparator '{'  = True
isSeparator '}'  = True
isSeparator ' '  = True
isSeparator '\t' = True
isSeparator _    = False

-- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
isChar :: Char -> Bool
isChar c
    | c <= '\x7f' = True
    | otherwise   = False

-- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
-- c)@
isToken :: Char -> Bool
isToken c = c `seq`
            not (isCtl c || isSeparator c)

-- |@'listOf' p@ is similar to @'Network.HTTP.Lucu.Parser.sepBy' p
-- ('Network.HTTP.Lucu.Parser.char' \',\')@ but it allows any
-- occurrences of LWS before and after each tokens.
listOf :: Parser a -> Parser [a]
listOf p = p `seq`
           do many lws
              sepBy p $! do many lws
                            char ','
                            many lws

-- |'token' is equivalent to @'Network.HTTP.Lucu.Parser.many1' $
-- 'Network.HTTP.Lucu.Parser.satisfy' 'isToken'@
token :: Parser String
token = many1 $! satisfy isToken

-- |'lws' is an HTTP LWS: @'Network.HTTP.Lucu.Parser.crlf'?
-- ('Network.HTTP.Lucu.Parser.sp' | 'Network.HTTP.Lucu.Parser.ht')+@
lws :: Parser String
lws = do s  <- option "" crlf
         xs <- many1 (sp <|> ht)
         return (s ++ xs)

-- |'text' accepts one character which doesn't satisfy 'isCtl'.
text :: Parser Char
text = satisfy (not . isCtl)

-- |'separator' accepts one character which satisfies 'isSeparator'.
separator :: Parser Char
separator = satisfy isSeparator

-- |'quotedStr' accepts a string surrounded by double quotation
-- marks. Quotes can be escaped by backslashes.
quotedStr :: Parser String
quotedStr = do char '"'
               xs <- many (qdtext <|> quotedPair)
               char '"'
               return $ foldr (++) "" xs
    where
      qdtext = do c <- satisfy (/= '"')
                  return [c]

      quotedPair = do char '\\'
                      c <- satisfy isChar
                      return [c]

-- |'qvalue' accepts a so-called qvalue.
qvalue :: Parser Double
qvalue = do x  <- char '0'
            xs <- option ""
                  $ do y  <- char '.'
                       ys <- many digit -- 本當は三文字までに制限
                       return (y:ys)
            return $ read (x:xs)
         <|>
         do x  <- char '1'
            xs <- option ""
                  $ do y  <- char '.'
                       ys <- many (char '0') -- 本當は三文字までに制限
                       return (y:ys)
            return $ read (x:xs)