fcmtp-data/src/Data/SMTP/Parser/URI.hs

{-# LANGUAGE OverloadedStrings #-}

module Data.SMTP.Parser.URI (parseURI) where

import Data.Attoparsec.ByteString.Char8
import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.Attoparsec.ByteString as AA
import Data.Word8 (Word8)
import qualified Data.ByteString as BS
import Data.SMTP.Types.URI
import Data.SMTP.Account
import qualified Data.Char as C
import Control.Applicative ((<|>))
import Text.StringConvert

parseURI :: Parser URI
parseURI = do
  stringCI "fCMTP://"
  a <- parseAccount
  u <- A.choice [
    do
      string "/"
      p <- parsePath
      return $ URI a p Nothing,
    return $ URI a (Path []) Nothing
    ]
  r <- parseRevision
  return u{revision=r}

parsePath :: Parser Path
parsePath = Path <$>
  A.many' parseSegment

parseSegment :: Parser String
parseSegment = do
  pp <- A.many' $ A.choice [
    escapeURI <$> A.takeWhile isPathChar,
    do
      A.string "%"
      c0 <- AA.anyWord8
      c1 <- AA.anyWord8
      let n' = do
            n0 <- fromHex c0
            n1 <- fromHex c1
            return $ 16*n0 + n1
      case n' of
        Nothing -> fail "Invalid URI character escaping"
        Just n -> return . BS.pack $ if isUnquoted n
                            then [n]
                            else [asWord8 '%', c0, c1]
    ]
  string "/" <|> return "" -- Segments end on a slash, colon, or end of input
  return . s . BS.concat $ pp
  where
    isPathChar :: Char -> Bool
    isPathChar c = (C.isAscii c && C.isAlphaNum c) || elem c ("_-=[]{}()." :: String)
    escapeURI = BS.pack . normalizePath . BS.unpack
    normalizePath :: [Word8] -> [Word8]
    normalizePath [] = []
    normalizePath (p:pp)
      | isReserved p = p : normalizePath pp
      | isUnquoted p = p : normalizePath pp
      | otherwise = let
        c0 = asWord8 '%'
        c1 = div p 16
        c2 = mod p 16
        in c0:c1:c2: normalizePath pp
    fromHex p
      | p >= asWord8 '0' && p <= asWord8 '9' = Just $ p - asWord8 '0'
      | p >= asWord8 'a' && p <= asWord8 'z' = Just $ 10 + p - asWord8 'a'
      | p >= asWord8 'A' && p <= asWord8 'Z' = Just $ 10 + p - asWord8 'A'
      | otherwise = Nothing
    isReserved :: Word8 -> Bool
    isReserved x = elem x $ fmap asWord8
                   [':', '/', '?', '#', '[', ']', '@', '!', '$', '&',
                    '\'', '(', ')', '*', '+', ',', ';', '=']
    isUnquoted :: Word8 -> Bool
    isUnquoted x =
      inRange x '=' '9' ||
      inRange x 'A' 'Z' ||
      (x == asWord8 '_') ||
      inRange x 'a' 'z'
    inRange x b e = x >= asWord8 b && x <= asWord8 e
    asWord8 :: Char -> Word8
    asWord8 = fromIntegral . C.ord
    

parseRevision :: Parser (Maybe Revision)
parseRevision =
  A.choice [
    do
      string ":"
      Just . Revision . s <$> A.takeWhile isRevisionChar,
    return Nothing
    ]
  where
    isRevisionChar :: Char -> Bool
    isRevisionChar c = C.isAlphaNum c || elem c ("+-_=." :: String)