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

module Data.SMTP.Types.URI where

import qualified Network.URI as N
import Data.SMTP.Account
import qualified Data.SMTP.Seal as Seal
import Data.List

import qualified Text.StringConvert as SC
import qualified Data.Attoparsec.Text as A

newtype Path = Path [String] deriving (Eq, Ord, Read, Show)
data Revision = NoRevision | Revision String deriving (Eq, Ord, Read, Show)
data Parameter = Parameter String String deriving (Eq, Ord, Read, Show)

data URI = URI {account :: Account, path :: Path, revision :: Revision, parameters :: [Parameter]} 
         deriving (Eq, Ord)

{- |
Returns the entire path of the URI.
-}
fullPath :: URI -> String
fullPath URI{path=Path p} = intercalate "/" $ map uriEncode p

{- |
Returns the entire path of the URI, except for the leading slash (/).
-}
relativePath :: URI -> String
relativePath URI{path=Path p} = intercalate "/" . map uriEncode $ drop 1 p

-- | Entire textual representation of the URI
fullURI :: URI -> String
fullURI u@(URI{account=a, revision=r, parameters=pp}) =
  concat $ ["FCMTP://", SC.s . fullAccount $ a, fullPath u] ++ (
    case r of
      NoRevision -> []
      Revision r' -> [":", r']
    ) ++ (
    if null pp
    then []
    else ["?", intercalate "&" $ map formatParameter pp]
    )
  where
    formatParameter (Parameter nm vl) = concat [uriEncode nm, "=", uriEncode vl]

uriEncode :: String -> String
uriEncode = N.escapeURIString N.isUnescapedInURIComponent
    
instance Show URI where
  show = fullURI

-- | Retrieves a parameter from the URI by key name
getParameter :: String -> URI -> Maybe String
getParameter p u = case map (\(Parameter _ vl) -> vl) .
                        filter (\(Parameter nm _) -> nm == p) $
                        parameters u of
                     [] -> Nothing
                     (v:_) -> Just v

getSeal :: URI -> Maybe Seal.Seal
getSeal u = do
  bare <- getParameter Seal.sealURIParam u
  right2Just . A.parseOnly Seal.parseURISeal $ SC.s bare
  where
    right2Just (Left _) = Nothing
    right2Just (Right v) = Just v

-- | Return revision string or a default value
fromRevision :: String -> Revision -> String
fromRevision d NoRevision = d
fromRevision _ (Revision r) = r

-- | Appends a new segment at the end of the path
appendPath :: Path -> String -> Path
appendPath (Path pp) e = Path $ pp ++ [e]