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 Network.URI as N
import Data.SMTP.Types.URI
import Data.SMTP.Account
import Text.StringConvert
import Data.List.Split
import Control.Monad

parseURI :: Parser URI
parseURI = do
  stringCI "fCMTP://"
  remURI <- A.takeWhile N.isAllowedInURI
  let u' = do
        u <- N.parseURI $ "fCMTP://" ++ s remURI
        a <- N.uriAuthority u
        return (u, a)
  case u' of
    Nothing -> fail "Not a valid URI"
    Just (uri, auth) -> do
      let au = N.uriUserInfo $ auth
          ah = N.uriRegName auth
      ac <- case A.parseOnly parseAccount (s $ au++ah) of
        Left e -> fail e
        Right ac -> return ac
      let (p, r) = break (==':') . N.uriPath $ uri
          pp = splitOn "/" p
          qq = if null . N.uriQuery $ uri
               then []
               else map (\(x, y) -> (drop 1 x, drop 1 y)) . map (break (=='=')) . splitOn "&" . N.uriQuery $ uri
      unless (null . N.uriPort $ auth) $ fail "fCMTP URIs must not determine a port"
      return $ URI ac (Path pp) (Just . Revision . drop 1 $ r) (map (\(x, y) -> Parameter x y) qq)