{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module LDAPv3.DistinguishedName
( DistinguishedName(..)
, rfc4514coreAttributes
) where
import Common hiding (Option, many, option, some, (<|>))
import LDAPv3.AttributeDescription
import LDAPv3.Message (OCTET_STRING)
import LDAPv3.StringRepr.Class
import qualified Data.ByteString as BS
import Data.Char (chr)
import Data.List as L
import Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Short as TS
import Text.Parsec as P
rfc4514coreAttributes :: [(KeyString,OID)]
rfc4514coreAttributes :: [(KeyString, OID)]
rfc4514coreAttributes =
[ ("CN" , [Natural] -> OID
oid [2,5,4,3] )
, ("L" , [Natural] -> OID
oid [2,5,4,7] )
, ("ST" , [Natural] -> OID
oid [2,5,4,8] )
, ("O" , [Natural] -> OID
oid [2,5,4,10] )
, ("OU" , [Natural] -> OID
oid [2,5,4,11] )
, ("C" , [Natural] -> OID
oid [2,5,4,6] )
, ("STREET" , [Natural] -> OID
oid [2,5,4,9] )
, ("DC" , [Natural] -> OID
oid [0,9,2342,19200300,100,1,25] )
, ("UID" , [Natural] -> OID
oid [0,9,2342,19200300,100,1,1] )
]
where
oid :: [Natural] -> OID
oid = \(n :: Natural
n:ns :: [Natural]
ns) -> NonEmpty Natural -> OID
OID (Natural
n Natural -> [Natural] -> NonEmpty Natural
forall a. a -> [a] -> NonEmpty a
:| [Natural]
ns)
newtype DistinguishedName = DistinguishedName [NonEmpty (Either KeyString OID,Either OCTET_STRING ShortText)]
deriving (DistinguishedName -> DistinguishedName -> Bool
(DistinguishedName -> DistinguishedName -> Bool)
-> (DistinguishedName -> DistinguishedName -> Bool)
-> Eq DistinguishedName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DistinguishedName -> DistinguishedName -> Bool
$c/= :: DistinguishedName -> DistinguishedName -> Bool
== :: DistinguishedName -> DistinguishedName -> Bool
$c== :: DistinguishedName -> DistinguishedName -> Bool
Eq,Int -> DistinguishedName -> ShowS
[DistinguishedName] -> ShowS
DistinguishedName -> String
(Int -> DistinguishedName -> ShowS)
-> (DistinguishedName -> String)
-> ([DistinguishedName] -> ShowS)
-> Show DistinguishedName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DistinguishedName] -> ShowS
$cshowList :: [DistinguishedName] -> ShowS
show :: DistinguishedName -> String
$cshow :: DistinguishedName -> String
showsPrec :: Int -> DistinguishedName -> ShowS
$cshowsPrec :: Int -> DistinguishedName -> ShowS
Show)
instance StringRepr DistinguishedName where
asBuilder :: DistinguishedName -> Builder
asBuilder = DistinguishedName -> Builder
r'DistinguishedName
asParsec :: Parsec s () DistinguishedName
asParsec = Parsec s () DistinguishedName
forall s. Stream s Identity Char => Parsec s () DistinguishedName
p'DistinguishedName
r'DistinguishedName :: DistinguishedName -> Builder
r'DistinguishedName :: DistinguishedName -> Builder
r'DistinguishedName (DistinguishedName rdns :: [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
rdns) = case [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
forall a. [a] -> [a]
L.reverse [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
rdns of
[] -> Builder
forall a. Monoid a => a
mempty
r :: NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
r:rs :: [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
rs -> (NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
-> Builder)
-> Char
-> NonEmpty
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
-> Builder
forall t. (t -> Builder) -> Char -> NonEmpty t -> Builder
sepby NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
-> Builder
r'rdn ',' (NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
r NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
-> [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> NonEmpty
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
forall a. a -> [a] -> NonEmpty a
:| [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
rs)
where
r'rdn :: NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
-> Builder
r'rdn = ((Either KeyString OID, Either OCTET_STRING ShortText) -> Builder)
-> Char
-> NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)
-> Builder
forall t. (t -> Builder) -> Char -> NonEmpty t -> Builder
sepby (Either KeyString OID, Either OCTET_STRING ShortText) -> Builder
forall a a.
(StringRepr a, StringRepr a) =>
(Either a a, Either OCTET_STRING ShortText) -> Builder
r'atav '+'
r'atav :: (Either a a, Either OCTET_STRING ShortText) -> Builder
r'atav (k :: Either a a
k,v :: Either OCTET_STRING ShortText
v) = (a -> Builder) -> (a -> Builder) -> Either a a -> Builder
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> Builder
forall a. StringRepr a => a -> Builder
asBuilder a -> Builder
forall a. StringRepr a => a -> Builder
asBuilder Either a a
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
B.singleton '=' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (OCTET_STRING -> Builder)
-> (ShortText -> Builder)
-> Either OCTET_STRING ShortText
-> Builder
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either OCTET_STRING -> Builder
r'hexval ShortText -> Builder
r'textval Either OCTET_STRING ShortText
v
r'hexval :: OCTET_STRING -> Builder
r'hexval = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> (OCTET_STRING -> [Builder]) -> OCTET_STRING -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Builder
B.singleton '#' Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
:) ([Builder] -> [Builder])
-> (OCTET_STRING -> [Builder]) -> OCTET_STRING -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Builder) -> [Word8] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Builder
forall a. Integral a => a -> Builder
r'word8hex ([Word8] -> [Builder])
-> (OCTET_STRING -> [Word8]) -> OCTET_STRING -> [Builder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OCTET_STRING -> [Word8]
BS.unpack
r'word8hex :: a -> Builder
r'word8hex x :: a
x
| a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< 0x10 = Char -> Builder
B.singleton '0' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> a -> Builder
forall a. Integral a => a -> Builder
B.hexadecimal a
x
| Bool
otherwise = a -> Builder
forall a. Integral a => a -> Builder
B.hexadecimal a
x
r'textval :: ShortText -> Builder
r'textval t :: ShortText
t
| ShortText -> Bool
needEscape ShortText
t = String -> Builder
B.fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ ShowS
goEsc ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ShortText -> String
TS.unpack ShortText
t
| Bool
otherwise = ShortText -> Builder
b'ShortText ShortText
t
goEsc :: ShowS
goEsc [] = ""
goEsc (' ':rest :: String
rest) = '\\'Char -> ShowS
forall a. a -> [a] -> [a]
:' 'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
goEsc1 String
rest
goEsc ('#':rest :: String
rest) = '\\'Char -> ShowS
forall a. a -> [a] -> [a]
:'#'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
goEsc1 String
rest
goEsc rest :: String
rest = ShowS
goEsc1 String
rest
goEsc1 :: ShowS
goEsc1 [] = ""
goEsc1 " " = "\\ "
goEsc1 (c :: Char
c:rest :: String
rest)
| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\0' = '\\'Char -> ShowS
forall a. a -> [a] -> [a]
:'0'Char -> ShowS
forall a. a -> [a] -> [a]
:'0'Char -> ShowS
forall a. a -> [a] -> [a]
:ShowS
goEsc1 String
rest
| Char -> Bool
needEsc1 Char
c = '\\'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
goEsc1 String
rest
| Bool
otherwise = Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:ShowS
goEsc1 String
rest
needEscape :: ShortText -> Bool
needEscape t :: ShortText
t
| ShortText -> Bool
TS.null ShortText
t = Bool
False
| Just c :: Char
c <- ShortText -> Int -> Maybe Char
TS.indexMaybe ShortText
t 0
, Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' = Bool
True
| Just c :: Char
c <- ShortText -> Int -> Maybe Char
TS.indexEndMaybe ShortText
t 0
, Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' ' = Bool
True
| (Char -> Bool) -> ShortText -> Bool
TS.any (\c :: Char
c -> Char -> Bool
needEsc1 Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\0') ShortText
t = Bool
True
| Bool
otherwise = Bool
False
needEsc1 :: Char -> Bool
needEsc1 '"' = Bool
True
needEsc1 '+' = Bool
True
needEsc1 ',' = Bool
True
needEsc1 ';' = Bool
True
needEsc1 '<' = Bool
True
needEsc1 '>' = Bool
True
needEsc1 '\\' = Bool
True
needEsc1 _ = Bool
False
sepby :: (t -> Builder) -> Char -> NonEmpty t -> Builder
sepby rend :: t -> Builder
rend c :: Char
c (x :: t
x :| xs :: [t]
xs) = t -> Builder
rend t
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [t] -> Builder
go [t]
xs
where
go :: [t] -> Builder
go [] = Builder
forall a. Monoid a => a
mempty
go (y :: t
y:ys :: [t]
ys) = Char -> Builder
B.singleton Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> t -> Builder
rend t
y Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [t] -> Builder
go [t]
ys
p'DistinguishedName :: Stream s Identity Char => Parsec s () DistinguishedName
p'DistinguishedName :: Parsec s () DistinguishedName
p'DistinguishedName = [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> DistinguishedName
DistinguishedName ([NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> DistinguishedName)
-> ([NonEmpty
(Either KeyString OID, Either OCTET_STRING ShortText)]
-> [NonEmpty
(Either KeyString OID, Either OCTET_STRING ShortText)])
-> [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> DistinguishedName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> [NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
forall a. [a] -> [a]
L.reverse ([NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> DistinguishedName)
-> ParsecT
s
()
Identity
[NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
-> Parsec s () DistinguishedName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT
s
()
Identity
[NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
p'distinguishedName
where
p'distinguishedName :: ParsecT
s
()
Identity
[NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
p'distinguishedName = ParsecT
s
()
Identity
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
p'relativeDistinguishedName ParsecT
s
()
Identity
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
-> ParsecT s () Identity Char
-> ParsecT
s
()
Identity
[NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char ','
p'relativeDistinguishedName :: ParsecT
s
()
Identity
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
p'relativeDistinguishedName = ParsecT
s () Identity (Either KeyString OID, Either OCTET_STRING ShortText)
p'attributeTypeAndValue ParsecT
s () Identity (Either KeyString OID, Either OCTET_STRING ShortText)
-> ParsecT s () Identity Char
-> ParsecT
s
()
Identity
(NonEmpty (Either KeyString OID, Either OCTET_STRING ShortText))
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m (NonEmpty a)
`sepBy1'` Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '+'
p'attributeTypeAndValue :: ParsecT
s () Identity (Either KeyString OID, Either OCTET_STRING ShortText)
p'attributeTypeAndValue = do
Either KeyString OID
ty <- Parsec s () (Either KeyString OID)
forall s.
Stream s Identity Char =>
Parsec s () (Either KeyString OID)
p'DescrOrOID
Char
_ <- Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '='
Either OCTET_STRING ShortText
va <- (OCTET_STRING -> Either OCTET_STRING ShortText
forall a b. a -> Either a b
Left (OCTET_STRING -> Either OCTET_STRING ShortText)
-> ParsecT s () Identity OCTET_STRING
-> ParsecT s () Identity (Either OCTET_STRING ShortText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity OCTET_STRING
p'hexstring) ParsecT s () Identity (Either OCTET_STRING ShortText)
-> ParsecT s () Identity (Either OCTET_STRING ShortText)
-> ParsecT s () Identity (Either OCTET_STRING ShortText)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (ShortText -> Either OCTET_STRING ShortText
forall a b. b -> Either a b
Right (ShortText -> Either OCTET_STRING ShortText)
-> ParsecT s () Identity ShortText
-> ParsecT s () Identity (Either OCTET_STRING ShortText)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity ShortText
p'string)
(Either KeyString OID, Either OCTET_STRING ShortText)
-> ParsecT
s () Identity (Either KeyString OID, Either OCTET_STRING ShortText)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either KeyString OID
ty,Either OCTET_STRING ShortText
va)
p'string :: ParsecT s () Identity ShortText
p'string = do
Maybe C
mc0 <- ParsecT s () Identity C -> ParsecT s () Identity (Maybe C)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (ParsecT s () Identity C -> ParsecT s () Identity (Maybe C))
-> ParsecT s () Identity C -> ParsecT s () Identity (Maybe C)
forall a b. (a -> b) -> a -> b
$ (Char -> C
C (Char -> C)
-> ParsecT s () Identity Char -> ParsecT s () Identity C
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isLeadchar) ParsecT s () Identity C
-> ParsecT s () Identity C -> ParsecT s () Identity C
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s () Identity C
p'pair
case Maybe C
mc0 of
Nothing -> ShortText -> ParsecT s () Identity ShortText
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
forall a. Monoid a => a
mempty
Just c0 :: C
c0 -> do
[C]
cs <- ParsecT s () Identity C -> ParsecT s () Identity [C]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Char -> C
C (Char -> C)
-> ParsecT s () Identity Char -> ParsecT s () Identity C
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isStringchar) ParsecT s () Identity C
-> ParsecT s () Identity C -> ParsecT s () Identity C
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT s () Identity C
p'pair)
case [C]
cs of
[] -> () -> ParsecT s () Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
_:_ -> Bool -> ParsecT s () Identity () -> ParsecT s () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([C] -> C
forall a. [a] -> a
last [C]
cs C -> C -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> C
C ' ') (ParsecT s () Identity () -> ParsecT s () Identity ())
-> ParsecT s () Identity () -> ParsecT s () Identity ()
forall a b. (a -> b) -> a -> b
$ String -> ParsecT s () Identity ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "trailing unescaped SPACE encountered in <string>"
ShortText -> ParsecT s () Identity ShortText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShortText -> ParsecT s () Identity ShortText)
-> ShortText -> ParsecT s () Identity ShortText
forall a b. (a -> b) -> a -> b
$ String -> ShortText
TS.fromString (String -> ShortText) -> String -> ShortText
forall a b. (a -> b) -> a -> b
$ (C -> Char) -> [C] -> String
forall a b. (a -> b) -> [a] -> [b]
map C -> Char
unescape (C
c0C -> [C] -> [C]
forall a. a -> [a] -> [a]
:[C]
cs)
isLeadchar :: Char -> Bool
isLeadchar c :: Char
c = case Char
c of
'\x00' -> Bool
False
'\x20' -> Bool
False
'\x22' -> Bool
False
'\x23' -> Bool
False
'\x2B' -> Bool
False
'\x2C' -> Bool
False
'\x3B' -> Bool
False
'\x3C' -> Bool
False
'\x3E' -> Bool
False
'\x5C' -> Bool
False
_ -> Bool
True
isStringchar :: Char -> Bool
isStringchar c :: Char
c = case Char
c of
'\x00' -> Bool
False
'\x22' -> Bool
False
'\x2B' -> Bool
False
'\x2C' -> Bool
False
'\x3B' -> Bool
False
'\x3C' -> Bool
False
'\x3E' -> Bool
False
'\x5C' -> Bool
False
_ -> Bool
True
p'pair :: ParsecT s () Identity C
p'pair = do
Char
_ <- Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '\\'
(Char -> C
CEsc (Char -> C)
-> ParsecT s () Identity Char -> ParsecT s () Identity C
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy Char -> Bool
isEscOrSpecial) ParsecT s () Identity C
-> ParsecT s () Identity C -> ParsecT s () Identity C
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Char -> C
CHex (Char -> C)
-> ParsecT s () Identity Char -> ParsecT s () Identity C
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Char
forall s. Stream s Identity Char => Parsec s () Char
p'hexpairsUtf8)
isEscOrSpecial :: Char -> Bool
isEscOrSpecial c :: Char
c = case Char
c of
'\\' -> Bool
True
'"' -> Bool
True
'+' -> Bool
True
',' -> Bool
True
';' -> Bool
True
'<' -> Bool
True
'>' -> Bool
True
' ' -> Bool
True
'#' -> Bool
True
'=' -> Bool
True
_ -> Bool
False
p'hexstring :: ParsecT s () Identity OCTET_STRING
p'hexstring = do
Char
_ <- Char -> ParsecT s () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '#'
[Word8]
octets <- ParsecT s () Identity Word8 -> ParsecT s () Identity [Word8]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT s () Identity Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'hexpair
OCTET_STRING -> ParsecT s () Identity OCTET_STRING
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OCTET_STRING -> ParsecT s () Identity OCTET_STRING)
-> OCTET_STRING -> ParsecT s () Identity OCTET_STRING
forall a b. (a -> b) -> a -> b
$ [Word8] -> OCTET_STRING
BS.pack [Word8]
octets
data C = C { C -> Char
unescape :: !Char }
| CEsc { unescape :: !Char }
| CHex { unescape :: !Char }
deriving (Int -> C -> ShowS
[C] -> ShowS
C -> String
(Int -> C -> ShowS) -> (C -> String) -> ([C] -> ShowS) -> Show C
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [C] -> ShowS
$cshowList :: [C] -> ShowS
show :: C -> String
$cshow :: C -> String
showsPrec :: Int -> C -> ShowS
$cshowsPrec :: Int -> C -> ShowS
Show,C -> C -> Bool
(C -> C -> Bool) -> (C -> C -> Bool) -> Eq C
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: C -> C -> Bool
$c/= :: C -> C -> Bool
== :: C -> C -> Bool
$c== :: C -> C -> Bool
Eq)
p'hexpairsUtf8 :: Stream s Identity Char => Parsec s () Char
p'hexpairsUtf8 :: Parsec s () Char
p'hexpairsUtf8 = do
Word8
o0 <- Parsec s () Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'hexpair
case () of
_ | Word8
o0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 0x7f -> Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
o0)
| Word8
o0 Word8 -> (Word8, Word8) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0xc2,0xdf) -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6
Int
o1' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1')
| Word8
o0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0xe0 -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x0f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> ParsecT s () Identity Int
forall b. Num b => Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' 0xa0 0xbf
Int
o2' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2')
| Word8
o0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0xed -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x0f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> ParsecT s () Identity Int
forall b. Num b => Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' 0x80 0x9f
Int
o2' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2')
| Word8
o0 Word8 -> (Word8, Word8) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0xe1,0xef) -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x0f) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Int
p'utf0
Int
o2' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2')
| Word8
o0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0xf0 -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x07) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 18
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> ParsecT s () Identity Int
forall b. Num b => Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' 0x90 0xbf
Int
o2' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Int
p'utf0
Int
o3' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o3')
| Word8
o0 Word8 -> (Word8, Word8) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0xf1,0xf3) -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x07) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 18
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Int
p'utf0
Int
o2' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Int
p'utf0
Int
o3' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o3')
| Word8
o0 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0xf4 -> do
let o0' :: Int
o0' = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
o0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x07) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 18
Int
o1' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 12) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word8 -> ParsecT s () Identity Int
forall b. Num b => Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' 0x80 0x8f
Int
o2' <- (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` 6) (Int -> Int)
-> ParsecT s () Identity Int -> ParsecT s () Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Int
p'utf0
Int
o3' <- ParsecT s () Identity Int
p'utf0
Char -> Parsec s () Char
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Parsec s () Char) -> Char -> Parsec s () Char
forall a b. (a -> b) -> a -> b
$! Int -> Char
chr (Int
o0' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o1' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o2' Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
o3')
| Bool
otherwise -> Parsec s () Char
forall a. ParsecT s () Identity a
utf8fail
where
p'utf0 :: ParsecT s () Identity Int
p'utf0 = Word8 -> Word8 -> ParsecT s () Identity Int
forall b. Num b => Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' 0x80 0xbf
p'utf0' :: Word8 -> Word8 -> ParsecT s () Identity b
p'utf0' lb :: Word8
lb ub :: Word8
ub = do
Char
_ <- Char -> Parsec s () Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '\\'
Word8
o <- Parsec s () Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'hexpair
Bool -> ParsecT s () Identity () -> ParsecT s () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
o Word8 -> (Word8, Word8) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (Word8
lb,Word8
ub)) (ParsecT s () Identity () -> ParsecT s () Identity ())
-> ParsecT s () Identity () -> ParsecT s () Identity ()
forall a b. (a -> b) -> a -> b
$ ParsecT s () Identity ()
forall a. ParsecT s () Identity a
utf8fail
b -> ParsecT s () Identity b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> ParsecT s () Identity b) -> b -> ParsecT s () Identity b
forall a b. (a -> b) -> a -> b
$ (Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> b) -> Word8 -> b
forall a b. (a -> b) -> a -> b
$ Word8
o Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x3f)
utf8fail :: ParsecT s () Identity a
utf8fail = String -> ParsecT s () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unexpected hex-encoded UTF8 octet"
p'hexpair :: Stream s Identity Char => Parsec s () Word8
p'hexpair :: Parsec s () Word8
p'hexpair = ((\hi :: Word8
hi lo :: Word8
lo -> Word8
hiWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
*16 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
lo) (Word8 -> Word8 -> Word8)
-> Parsec s () Word8 -> ParsecT s () Identity (Word8 -> Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec s () Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'HEX ParsecT s () Identity (Word8 -> Word8)
-> Parsec s () Word8 -> Parsec s () Word8
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec s () Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'HEX)
p'HEX :: Stream s Identity Char => Parsec s () Word8
p'HEX :: Parsec s () Word8
p'HEX = (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word8) (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. (Ord a, Num a) => a -> a
go (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum (Char -> Word8) -> ParsecT s () Identity Char -> Parsec s () Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
hexDigit
where
go :: a -> a
go n :: a
n
| a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x30,0x39) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- 0x30
| a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x61,0x66) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- (0x61 a -> a -> a
forall a. Num a => a -> a -> a
- 10)
| a
n a -> (a, a) -> Bool
forall a. Ord a => a -> (a, a) -> Bool
`inside` (0x41,0x46) = a
n a -> a -> a
forall a. Num a => a -> a -> a
- (0x41 a -> a -> a
forall a. Num a => a -> a -> a
- 10)
| Bool
otherwise = a
forall a. a
impossible
b'ShortText :: ShortText -> Builder
b'ShortText :: ShortText -> Builder
b'ShortText = Text -> Builder
fromText (Text -> Builder) -> (ShortText -> Text) -> ShortText -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> Text
TS.toText