-- Copyright (c) 2020  Herbert Valerio Riedel <hvr@gnu.org>
--
--  This file is free software: you may copy, redistribute and/or modify it
--  under the terms of the GNU General Public License as published by the
--  Free Software Foundation, either version 2 of the License, or (at your
--  option) any later version.
--
--  This file is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program (see `LICENSE`).  If not, see
--  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>.

{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}

-- internal module
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


-- | Haskell representation of the table below as defined in <https://tools.ietf.org/search/rfc4514#section-3 RFC4514 Section 3>.
--
-- +--------+-----------------------------------------------+
-- | String | X.500 AttributeType                           |
-- +========+===============================================+
-- | CN     | commonName (2.5.4.3)                          |
-- | L      | localityName (2.5.4.7)                        |
-- | ST     | stateOrProvinceName (2.5.4.8)                 |
-- | O      | organizationName (2.5.4.10)                   |
-- | OU     | organizationalUnitName (2.5.4.11)             |
-- | C      | countryName (2.5.4.6)                         |
-- | STREET | streetAddress (2.5.4.9)                       |
-- | DC     | domainComponent (0.9.2342.19200300.100.1.25)  |
-- | UID    | userId (0.9.2342.19200300.100.1.1)            |
-- +--------+-----------------------------------------------+
--
-- @since 0.1.1
rfc4514coreAttributes :: [(KeyString,OID)]
rfc4514coreAttributes :: [(KeyString, OID)]
rfc4514coreAttributes =
    [ ("CN"     {- commonName             -} , [Natural] -> OID
oid [2,5,4,3]                    )
    , ("L"      {- localityName           -} , [Natural] -> OID
oid [2,5,4,7]                    )
    , ("ST"     {- stateOrProvinceName    -} , [Natural] -> OID
oid [2,5,4,8]                    )
    , ("O"      {- organizationName       -} , [Natural] -> OID
oid [2,5,4,10]                   )
    , ("OU"     {- organizationalUnitName -} , [Natural] -> OID
oid [2,5,4,11]                   )
    , ("C"      {- countryName            -} , [Natural] -> OID
oid [2,5,4,6]                    )
    , ("STREET" {- streetAddress          -} , [Natural] -> OID
oid [2,5,4,9]                    )
    , ("DC"     {- domainComponent        -} , [Natural] -> OID
oid [0,9,2342,19200300,100,1,25] )
    , ("UID"    {- userId                 -} , [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)

-- | Decoded non-normalizing string representation of @DistinguishedName@
--
-- > DistinguishedName ::= RDNSequence
-- >
-- > RDNSequence ::= SEQUENCE OF RelativeDistinguishedName
-- >
-- > RelativeDistinguishedName ::= SET SIZE (1..MAX) OF
-- >     AttributeTypeAndValue
-- >
-- > AttributeTypeAndValue ::= SEQUENCE {
-- >     type  AttributeType,
-- >     value AttributeValue }
--
-- Raw ASN.1 Hex-encoded @AttributeValue@s are represented as 'OCTET_STRING' (which implies they MUST not be a size-0 'OCTET_STRING') whereas 'ShortText' is used for textually encoded (possibly containing escaped characters) values.
--
-- As defined in RFC4514, the RDNSequence is serialized in reverse order.
--
-- @since 0.1.1
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 -- optional
  where
    -- distinguishedName = [ relativeDistinguishedName *( COMMA relativeDistinguishedName ) ]
    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 ','

    -- relativeDistinguishedName = attributeTypeAndValue *( PLUS attributeTypeAndValue )
    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 '+'

    -- attributeTypeAndValue = attributeType EQUALS attributeValue
    -- attributeType = descr / numericoid
    -- attributeValue = string / hexstring

    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)

    -- ; The following characters are to be escaped when they appear
    -- ; in the value to be encoded: ESC, one of <escaped>, leading
    -- ; SHARP or SPACE, trailing SPACE, and NULL.
    -- string = [ ( leadchar / pair ) [ *( stringchar / pair ) ( trailchar / pair ) ] ]
    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
          -- since the grammar above doesn't lend itself to be expressed directly with Parsec
          -- combinators, we defer the unescaped-trailing-space check to keep things simple...
          [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)

    -- leadchar = LUTF1 / UTFMB
    -- LUTF1 = %x01-1F / %x21 / %x24-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F
    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

    -- trailchar  = TUTF1 / UTFMB
    -- TUTF1 = %x01-1F / %x21 / %x23-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F

    -- stringchar = SUTF1 / UTFMB
    -- SUTF1 = %x01-21        / %x23-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F
    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

    -- pair = ESC ( ESC / special / hexpair )
    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)

    -- special = escaped / SPACE / SHARP / EQUALS
    -- escaped = DQUOTE / PLUS / COMMA / SEMI / LANGLE / RANGLE
    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

    -- hexstring = SHARP 1*hexpair
    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 } -- unescaped character
       | CEsc { unescape :: !Char } -- backslash escaped character
       | CHex { unescape :: !Char } -- hex pairs encoded utf8 code-point
       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)

-- ; Any UTF-8 [RFC3629] encoded Unicode [Unicode] character
p'hexpairsUtf8 :: Stream s Identity Char => Parsec s () Char
p'hexpairsUtf8 :: Parsec s () Char
p'hexpairsUtf8 = do
    -- UTF8    = UTF1 / UTFMB
    -- UTFMB   = UTF2 / UTF3 / UTF4
    Word8
o0 <- Parsec s () Word8
forall s. Stream s Identity Char => Parsec s () Word8
p'hexpair
    case () of
        -- UTF1    = %x00-7F
      _ | 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)

        -- UTF2    = %xC2-DF UTF0
        | 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')

        -- UTF3    = %xE0 %xA0-BF UTF0 / %xE1-EC 2(UTF0) / %xED %x80-9F UTF0 / %xEE-EF 2(UTF0)
        | 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 -- NB: 0xed excluded due to preceding case
            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')

        -- UTF4    = %xF0 %x90-BF 2(UTF0) / %xF1-F3 3(UTF0) / %xF4 %x80-8F 2(UTF0)
        | 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')

        -- everything else is not a valid UTF8 encoded code-point
        | Bool
otherwise -> Parsec s () Char
forall a. ParsecT s () Identity a
utf8fail

  where
    -- UTF0    = %x80-BF
    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"

-- hexpair = HEX HEX
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