#if __GLASGOW_HASKELL__
#endif
module Data.URN
( NID
, NSS
, URN (..)
, renderURN
, parseURN
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.List as L
import Data.String
#if defined(__GLASGOW_HASKELL__)
import Data.Data
import Data.Typeable ()
#endif
import Text.Parsec as P
import Text.Parsec.String
import Text.Read
import Numeric
type NID = String
type NSS = String
data URN = URN
{
urnNamespace :: NID
, urnString :: NSS
} deriving
( Eq, Ord
#if defined(__GLASGOW_HASKELL__)
, Typeable, Data
#endif
)
isURNChar, isTrans, isOther, isReserved :: Char -> Bool
isURNChar x = isTrans x || isHexDigit x
isTrans x = isAlphaNum x || isOther x || isReserved x
isOther x = L.elem x "()+,-.:=@;$_!*'"
isReserved x = L.elem x "%/?#"
escape :: String -> String
escape = concatMap f
where
f x
| not (isURNChar x) || x == '%' = '%' : showHex (fromEnum x) ""
| otherwise = [x]
unescape :: String -> Maybe String
unescape ('%' : a : b : xs) = do
n <- readMaybe ['0', 'x', a, b]
xs' <- unescape xs
return $ toEnum n : xs'
unescape ('%' : _) = Nothing
unescape (x : xs) = do
xs' <- unescape xs
return (x : xs')
unescape [] = return []
renderURN :: URN -> String
renderURN urn = "urn:" ++ nid ++ ":" ++ nss
where
nid = L.map toLower (urnNamespace urn)
nss = escape (urnString urn)
parseURN :: String -> Maybe URN
parseURN = either (const Nothing) Just . parse purn ""
where
pscm :: Parser ()
pscm = do
_ <- oneOf "uU"
_ <- oneOf "rR"
_ <- oneOf "nN"
_ <- char ':'
return ()
pnid :: Parser NID
pnid = do
c <- satisfy isAlphaNum
cs <- some $ satisfy (\ x -> isAlphaNum x || x == '-')
let nid = L.map toLower (c : cs)
guard (nid /= "urn")
return nid
pnss :: Parser NSS
pnss = do
str <- P.many (satisfy isURNChar)
case unescape str of
Nothing -> fail "parseURN: bad NSS escaping"
Just nss -> return nss
purn :: Parser URN
purn = pscm >> URN <$> pnid <* char ':' <*> pnss
instance IsString URN where
fromString t = case parseURN t of
Nothing -> error $ "fromString: unable to parse URN: " ++ show t
Just urn -> urn
instance Show URN where
showsPrec _ = showString . renderURN
instance Read URN where
readsPrec _ xs =
case parseURN urnStr of
Nothing -> []
Just urn -> [(urn, rest)]
where
(urnStr, rest) = span (not . (== ' ')) xs