-- Copyright (c) 2020 Herbert Valerio Riedel -- -- 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 -- . {-# 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 . -- -- +--------+-----------------------------------------------+ -- | 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 = [ ("CN" {- commonName -} , oid [2,5,4,3] ) , ("L" {- localityName -} , oid [2,5,4,7] ) , ("ST" {- stateOrProvinceName -} , oid [2,5,4,8] ) , ("O" {- organizationName -} , oid [2,5,4,10] ) , ("OU" {- organizationalUnitName -} , oid [2,5,4,11] ) , ("C" {- countryName -} , oid [2,5,4,6] ) , ("STREET" {- streetAddress -} , oid [2,5,4,9] ) , ("DC" {- domainComponent -} , oid [0,9,2342,19200300,100,1,25] ) , ("UID" {- userId -} , oid [0,9,2342,19200300,100,1,1] ) ] where oid = \(n:ns) -> OID (n :| 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 (Eq,Show) instance StringRepr DistinguishedName where asBuilder = r'DistinguishedName asParsec = p'DistinguishedName r'DistinguishedName :: DistinguishedName -> Builder r'DistinguishedName (DistinguishedName rdns) = case L.reverse rdns of [] -> mempty r:rs -> sepby r'rdn ',' (r :| rs) where r'rdn = sepby r'atav '+' r'atav (k,v) = either asBuilder asBuilder k <> B.singleton '=' <> either r'hexval r'textval v r'hexval = mconcat . (B.singleton '#' :) . map r'word8hex . BS.unpack r'word8hex x | x < 0x10 = B.singleton '0' <> B.hexadecimal x | otherwise = B.hexadecimal x r'textval t | needEscape t = B.fromString $ goEsc $ TS.unpack t | otherwise = b'ShortText t goEsc [] = "" goEsc (' ':rest) = '\\':' ':goEsc1 rest goEsc ('#':rest) = '\\':'#':goEsc1 rest goEsc rest = goEsc1 rest goEsc1 [] = "" goEsc1 " " = "\\ " goEsc1 (c:rest) | c == '\0' = '\\':'0':'0':goEsc1 rest | needEsc1 c = '\\':c:goEsc1 rest | otherwise = c:goEsc1 rest needEscape t | TS.null t = False | Just c <- TS.indexMaybe t 0 , c == '#' || c == ' ' = True | Just c <- TS.indexEndMaybe t 0 , c == ' ' = True | TS.any (\c -> needEsc1 c || c == '\0') t = True | otherwise = False needEsc1 '"' = True needEsc1 '+' = True needEsc1 ',' = True needEsc1 ';' = True needEsc1 '<' = True needEsc1 '>' = True needEsc1 '\\' = True needEsc1 _ = False sepby rend c (x :| xs) = rend x <> go xs where go [] = mempty go (y:ys) = B.singleton c <> rend y <> go ys p'DistinguishedName :: Stream s Identity Char => Parsec s () DistinguishedName p'DistinguishedName = DistinguishedName . L.reverse <$> p'distinguishedName -- optional where -- distinguishedName = [ relativeDistinguishedName *( COMMA relativeDistinguishedName ) ] p'distinguishedName = p'relativeDistinguishedName `sepBy` char ',' -- relativeDistinguishedName = attributeTypeAndValue *( PLUS attributeTypeAndValue ) p'relativeDistinguishedName = p'attributeTypeAndValue `sepBy1'` char '+' -- attributeTypeAndValue = attributeType EQUALS attributeValue -- attributeType = descr / numericoid -- attributeValue = string / hexstring p'attributeTypeAndValue = do ty <- p'DescrOrOID _ <- char '=' va <- (Left <$> p'hexstring) <|> (Right <$> p'string) pure (ty,va) -- ; The following characters are to be escaped when they appear -- ; in the value to be encoded: ESC, one of , leading -- ; SHARP or SPACE, trailing SPACE, and NULL. -- string = [ ( leadchar / pair ) [ *( stringchar / pair ) ( trailchar / pair ) ] ] p'string = do mc0 <- optionMaybe $ (C <$> satisfy isLeadchar) <|> p'pair case mc0 of Nothing -> pure mempty Just 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... cs <- many ((C <$> satisfy isStringchar) <|> p'pair) case cs of [] -> pure () _:_ -> when (last cs == C ' ') $ fail "trailing unescaped SPACE encountered in " pure $ TS.fromString $ map unescape (c0:cs) -- leadchar = LUTF1 / UTFMB -- LUTF1 = %x01-1F / %x21 / %x24-2A / %x2D-3A / %x3D / %x3F-5B / %x5D-7F isLeadchar c = case c of '\x00' -> False '\x20' -> False -- ' ' '\x22' -> False -- '"' '\x23' -> False -- '#' '\x2B' -> False -- '+' '\x2C' -> False -- ',' '\x3B' -> False -- ';' '\x3C' -> False -- '<' '\x3E' -> False -- '>' '\x5C' -> False -- '\\' _ -> 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 c = case c of '\x00' -> False '\x22' -> False -- '"' '\x2B' -> False -- '+' '\x2C' -> False -- ',' '\x3B' -> False -- ';' '\x3C' -> False -- '<' '\x3E' -> False -- '>' '\x5C' -> False -- '\\' _ -> True -- pair = ESC ( ESC / special / hexpair ) p'pair = do _ <- char '\\' (CEsc <$> satisfy isEscOrSpecial) <|> (CHex <$> p'hexpairsUtf8) -- special = escaped / SPACE / SHARP / EQUALS -- escaped = DQUOTE / PLUS / COMMA / SEMI / LANGLE / RANGLE isEscOrSpecial c = case c of '\\' -> True '"' -> True '+' -> True ',' -> True ';' -> True '<' -> True '>' -> True ' ' -> True '#' -> True '=' -> True _ -> False -- hexstring = SHARP 1*hexpair p'hexstring = do _ <- char '#' octets <- many1 p'hexpair pure $ BS.pack octets data C = C { unescape :: !Char } -- unescaped character | CEsc { unescape :: !Char } -- backslash escaped character | CHex { unescape :: !Char } -- hex pairs encoded utf8 code-point deriving (Show,Eq) -- ; Any UTF-8 [RFC3629] encoded Unicode [Unicode] character p'hexpairsUtf8 :: Stream s Identity Char => Parsec s () Char p'hexpairsUtf8 = do -- UTF8 = UTF1 / UTFMB -- UTFMB = UTF2 / UTF3 / UTF4 o0 <- p'hexpair case () of -- UTF1 = %x00-7F _ | o0 <= 0x7f -> pure $! chr (fromIntegral o0) -- UTF2 = %xC2-DF UTF0 | o0 `inside` (0xc2,0xdf) -> do let o0' = fromIntegral (o0 .&. 0x1f) `unsafeShiftL` 6 o1' <- p'utf0 pure $! chr (o0' .|. o1') -- UTF3 = %xE0 %xA0-BF UTF0 / %xE1-EC 2(UTF0) / %xED %x80-9F UTF0 / %xEE-EF 2(UTF0) | o0 == 0xe0 -> do let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12 o1' <- (`unsafeShiftL` 6) <$> p'utf0' 0xa0 0xbf o2' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2') | o0 == 0xed -> do let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12 o1' <- (`unsafeShiftL` 6) <$> p'utf0' 0x80 0x9f o2' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2') | o0 `inside` (0xe1,0xef) -> do -- NB: 0xed excluded due to preceding case let o0' = fromIntegral (o0 .&. 0x0f) `unsafeShiftL` 12 o1' <- (`unsafeShiftL` 6) <$> p'utf0 o2' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2') -- UTF4 = %xF0 %x90-BF 2(UTF0) / %xF1-F3 3(UTF0) / %xF4 %x80-8F 2(UTF0) | o0 == 0xf0 -> do let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18 o1' <- (`unsafeShiftL` 12) <$> p'utf0' 0x90 0xbf o2' <- (`unsafeShiftL` 6) <$> p'utf0 o3' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2' .|. o3') | o0 `inside` (0xf1,0xf3) -> do let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18 o1' <- (`unsafeShiftL` 12) <$> p'utf0 o2' <- (`unsafeShiftL` 6) <$> p'utf0 o3' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2' .|. o3') | o0 == 0xf4 -> do let o0' = fromIntegral (o0 .&. 0x07) `unsafeShiftL` 18 o1' <- (`unsafeShiftL` 12) <$> p'utf0' 0x80 0x8f o2' <- (`unsafeShiftL` 6) <$> p'utf0 o3' <- p'utf0 pure $! chr (o0' .|. o1' .|. o2' .|. o3') -- everything else is not a valid UTF8 encoded code-point | otherwise -> utf8fail where -- UTF0 = %x80-BF p'utf0 = p'utf0' 0x80 0xbf p'utf0' lb ub = do _ <- char '\\' o <- p'hexpair unless (o `inside` (lb,ub)) $ utf8fail pure $ (fromIntegral $ o .&. 0x3f) utf8fail = fail "unexpected hex-encoded UTF8 octet" -- hexpair = HEX HEX p'hexpair :: Stream s Identity Char => Parsec s () Word8 p'hexpair = ((\hi lo -> hi*16 + lo) <$> p'HEX <*> p'HEX) p'HEX :: Stream s Identity Char => Parsec s () Word8 p'HEX = (fromIntegral :: Int -> Word8) . go . fromEnum <$> hexDigit where go n | n `inside` (0x30,0x39) = n - 0x30 | n `inside` (0x61,0x66) = n - (0x61 - 10) | n `inside` (0x41,0x46) = n - (0x41 - 10) | otherwise = impossible b'ShortText :: ShortText -> Builder b'ShortText = fromText . TS.toText