diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ See also http://pvp.haskell.org/faq +### 0.1.1.0 + +- Add support for _String Representation of Distinguished Names_ as per RFC4514 +- Add support for encoding/decoding common ASN.1 string types from their ASN.1 BER representation + ## 0.1.0.0 Major API restructuring getting rid of `newtype` annotation wrappers in exposed API. diff --git a/LDAPv3.cabal b/LDAPv3.cabal --- a/LDAPv3.cabal +++ b/LDAPv3.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: LDAPv3 -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Lightweight Directory Access Protocol (LDAP) version 3 license: GPL-2.0-or-later @@ -16,7 +16,7 @@ . Serializing and deserializing to and from the wire encoding for the purpose of implementing network clients and servers is supported via 'Binary' instances (see ). . - Moreover, this library also implements /String Representation of Search Filters/ as per (see "LDAPv3.StringRepr") + Moreover, this library also implements /String Representation of Search Filters/ as per and /String Representation of Distinguished Names/ as per (see "LDAPv3.StringRepr" for details). extra-source-files: ChangeLog.md @@ -76,13 +76,16 @@ exposed-modules: LDAPv3.Message LDAPv3.StringRepr + LDAPv3.ASN1String other-modules: Common Data.Int.Subtypes Data.ASN1 Data.ASN1.Prim LDAPv3.AttributeDescription + LDAPv3.DistinguishedName LDAPv3.SearchFilter + LDAPv3.StringRepr.Class LDAPv3.ResultCode LDAPv3.Message.Types LDAPv3.Message.Annotated @@ -104,4 +107,4 @@ , tasty-quickcheck ^>= 0.10.1 , tasty-hunit ^>= 0.10.0 , base-encoding ^>= 0.1.0 - , quickcheck-instances ^>= 0.3.22 + , quickcheck-instances ^>= 0.3.22 && < 0.3.26 diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -9,6 +9,7 @@ import Control.Newtype as X (Newtype (..)) import Data.Bits as X import Data.ByteString as X (ByteString) +import Data.ByteString.Short as X (ShortByteString) import Data.Foldable as X (asum) import Data.Functor.Identity as X import Data.Int as X @@ -24,6 +25,8 @@ import GHC.TypeLits as X hiding (Text) import Numeric.Natural as X (Natural) +import qualified Text.Parsec as P + {-# INLINE rwhnf #-} rwhnf :: a -> () rwhnf x = seq x () @@ -36,3 +39,9 @@ impossible :: a impossible = error "The impossible just happened!" + +sepBy1' :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m sep -> P.ParsecT s u m (NonEmpty a) +sepBy1' p set = f <$> P.sepBy1 p set + where + f [] = impossible + f (x:xs) = x:|xs diff --git a/src/Data/ASN1/Prim.hs b/src/Data/ASN1/Prim.hs --- a/src/Data/ASN1/Prim.hs +++ b/src/Data/ASN1/Prim.hs @@ -251,8 +251,7 @@ getVarInteger :: Word64 -> Get Integer getVarInteger sz | sz <= 8 = toInteger <$> getVarInt64 sz - | otherwise = fail "INTEGER: FIXME/TODO" - + | otherwise = fail "unsupported INTEGER size" -- FIXME/TODO putVarInt64 :: Int64 -> PutM Word64 putVarInt64 i = do diff --git a/src/LDAPv3/ASN1String.hs b/src/LDAPv3/ASN1String.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/ASN1String.hs @@ -0,0 +1,555 @@ +-- 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 DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +-- | ASN.1 String Types +-- +-- This modules features types and associated functions for encoding/decoding common ASN.1 string types from their ASN.1 BER representation according to their standard /universal/ ASN.1 tag number. +-- +-- @since 0.1.1 +module LDAPv3.ASN1String + ( ASN1String(..) + + -- * Convenience Sum-type + + , ASN1StringChoice(..) + , asn1StringChoice'encode + , asn1StringChoice'decode + + -- * UTF8String + + , UTF8String(UTF8String, utf8String'toShortText) + + -- * UniversalString + + , UniversalString + + -- * BMPString + + , BMPString + , bmpString'toUcs2CodePoints + , bmpString'fromUcs2CodePoints + + -- * IA5String + + , IA5String + , ia5String'toShortText + , ia5String'fromShortText + + -- * VisibleString + + , VisibleString + , visibleString'toShortText + , visibleString'fromShortText + + -- * PrintableString + + , PrintableString + , printableString'toShortText + , printableString'fromShortText + + -- * NumericString + + , NumericString + , numericString'toShortText + , numericString'fromShortText + ) where + +import Common hiding (Option, many, option, some, (<|>)) + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as SBS +import Data.Char (chr, ord) +import qualified Data.Text.Short as TS + +import Data.ASN1 +import Data.ASN1.Prim + +import qualified Data.Binary as Bin +import qualified Data.Binary.Get as Bin +import qualified Data.Binary.Put as Bin + +-- | Typeclass abstracting over common ASN.1 string operations +-- +-- @since 0.1.1 +class ASN1String a where + -- | Decode ASN.1 string type from its ASN.1 BER encoding + asn1string'decode :: ByteString -> Maybe a + default asn1string'decode :: ASN1 a => ByteString -> Maybe a + asn1string'decode = runGetMaybe (toBinaryGet asn1decode) + + -- | Encode ASN.1 string type to its ASN.1 BER encoding + asn1string'encode :: a -> ByteString + default asn1string'encode :: ASN1 a => a -> ByteString + asn1string'encode = BL.toStrict . Bin.runPut . void . toBinaryPut . asn1encode + + -- | Predicate for determining whether given code-point is allowed by the respective ASN.1 string type + asn1string'supportsCodePoint :: Proxy a -> Char -> Bool + + -- | Convert ASN.1 string type to list of code-points + asn1string'toCodePoints :: a -> [Char] + + -- | Construct ASN.1 string type from list of code-points + -- + -- This returns 'Nothing' if a code-point cannot be expressed in the respective ASN.1 string type. + asn1string'fromCodePoints :: [Char] -> Maybe a + +-- | Convenient Sum-type combining a subset of the standard ASN.1 string-like types +-- +-- See specific string types in "LDAPv3.ASN1String" for details. +data ASN1StringChoice + = ASN1String'OCTET_STRING ShortByteString + | ASN1String'UniversalString UniversalString + | ASN1String'UTF8String ShortText + | ASN1String'BMPString BMPString + | ASN1String'IA5String IA5String + | ASN1String'VisibleString VisibleString + | ASN1String'PrintableString PrintableString + | ASN1String'NumericString NumericString + deriving (Show,Eq) + +-- | Encodes as ASN.1 BER +instance Bin.Binary ASN1StringChoice where + put = void . toBinaryPut . go + where + go (ASN1String'BMPString t) = asn1encode t + go (ASN1String'IA5String t) = asn1encode t + go (ASN1String'NumericString t) = asn1encode t + go (ASN1String'OCTET_STRING b) = asn1encode b + go (ASN1String'PrintableString t) = asn1encode t + go (ASN1String'UTF8String t) = asn1encode (UTF8String t) + go (ASN1String'UniversalString t) = asn1encode t + go (ASN1String'VisibleString t) = asn1encode t + + get = toBinaryGet go + where + go = dec'CHOICE + [ ASN1String'OCTET_STRING <$> asn1decode + , ASN1String'UTF8String . utf8String'toShortText <$> asn1decode + , ASN1String'PrintableString <$> asn1decode + , ASN1String'IA5String <$> asn1decode + , ASN1String'BMPString <$> asn1decode + , ASN1String'UniversalString <$> asn1decode + , ASN1String'VisibleString <$> asn1decode + , ASN1String'NumericString <$> asn1decode + ] + +-- | Encode ASN.1 string choice to its ASN.1 BER encoding +-- +-- @since 0.1.1 +asn1StringChoice'encode :: ASN1StringChoice -> ByteString +asn1StringChoice'encode = BL.toStrict . Bin.runPut . Bin.put + +-- | Decode ASN.1 string choice from its ASN.1 BER encoding +-- +-- @since 0.1.1 +asn1StringChoice'decode :: ByteString -> Maybe ASN1StringChoice +asn1StringChoice'decode = runGetMaybe Bin.get + +---------------------------------------------------------------------------- + +-- | ASN.1 UTF8String +-- +-- > UTF8String ::= [UNIVERSAL 12] IMPLICIT OCTET STRING +-- +-- @since 0.1.1 +newtype UTF8String = UTF8String { utf8String'toShortText :: ShortText } deriving (Eq,Ord) + +instance ASN1String UTF8String where + asn1string'supportsCodePoint _ = not . isSurr + asn1string'toCodePoints (UTF8String t) = TS.unpack t + asn1string'fromCodePoints cps + | all (not . isSurr) cps = Just $! UTF8String (TS.pack cps) + | otherwise = Nothing + +instance Show UTF8String where + show (UTF8String s) = show s + showsPrec p (UTF8String s) = showsPrec p s + +instance ASN1 UTF8String where + asn1defTag _ = Universal 12 + asn1encode (UTF8String t) = asn1encode (IMPLICIT t :: 'UNIVERSAL 12 `IMPLICIT` ShortText) + asn1decode = unwrap <$> asn1decode + where + unwrap :: 'UNIVERSAL 12 `IMPLICIT` ShortText -> UTF8String + unwrap (IMPLICIT t) = UTF8String t + +-- | Encodes as ASN.1 BER +instance Bin.Binary UTF8String where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 PrintableString +-- +-- > PrintableString ::= [UNIVERSAL 19] IMPLICIT OCTET STRING +-- +-- @since 0.1.1 +newtype PrintableString = PrintableString ShortText deriving (Eq,Ord) + +instance ASN1String PrintableString where + asn1string'supportsCodePoint _ = isPrintableChar + asn1string'toCodePoints (PrintableString t) = TS.unpack t + asn1string'fromCodePoints cps + | all isPrintableChar cps = Just $! PrintableString (TS.pack cps) + | otherwise = Nothing + +instance Show PrintableString where + show (PrintableString s) = show s + showsPrec p (PrintableString s) = showsPrec p s + +printableString'fromShortText :: ShortText -> Maybe PrintableString +printableString'fromShortText t + | TS.all isPrintableChar t = Just $! PrintableString t + | otherwise = Nothing + +printableString'fromByteString :: ByteString -> Maybe PrintableString +printableString'fromByteString bs + | BSC.all isPrintableChar bs = PrintableString <$> TS.fromByteString bs + | otherwise = Nothing + +printableString'toShortText :: PrintableString -> ShortText +printableString'toShortText (PrintableString t) = t + +isPrintableChar :: Char -> Bool +isPrintableChar c = case c of + ' ' -> True + '*' -> False + ':' -> True + '=' -> True + '?' -> True + _ | c `inside` ('A','Z') -> True + | c `inside` ('a','z') -> True + | c `inside` ('0','9') -> True + | c `inside` ('\x27','\x2f') -> True -- "'()*+,-./" + | otherwise -> False + +instance ASN1 PrintableString where + asn1defTag _ = Universal 19 + asn1encode (PrintableString t) = asn1encode (IMPLICIT t :: 'UNIVERSAL 19 `IMPLICIT` ShortText) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in PrintableString") Right . printableString'fromByteString) + where + unwrap :: 'UNIVERSAL 19 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary PrintableString where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 NumericString +-- +-- > NumericString ::= [UNIVERSAL 18] IMPLICIT OCTET STRING +-- +-- @since 0.1.1 +newtype NumericString = NumericString ShortText deriving (Eq,Ord) + +instance Show NumericString where + show (NumericString s) = show s + showsPrec p (NumericString s) = showsPrec p s + +instance ASN1String NumericString where + asn1string'supportsCodePoint _ = isNumericChar + asn1string'toCodePoints (NumericString t) = TS.unpack t + asn1string'fromCodePoints cps + | all isNumericChar cps = Just $! NumericString (TS.pack cps) + | otherwise = Nothing + +numericString'fromShortText :: ShortText -> Maybe NumericString +numericString'fromShortText t + | TS.all isNumericChar t = Just $! NumericString t + | otherwise = Nothing + +numericString'fromByteString :: ByteString -> Maybe NumericString +numericString'fromByteString bs + | BSC.all isNumericChar bs = NumericString <$> TS.fromByteString bs + | otherwise = Nothing + +numericString'toShortText :: NumericString -> ShortText +numericString'toShortText (NumericString t) = t + +isNumericChar :: Char -> Bool +isNumericChar ' ' = True +isNumericChar c = c `inside` ('0','9') + +instance ASN1 NumericString where + asn1defTag _ = Universal 18 + asn1encode (NumericString t) = asn1encode (IMPLICIT t :: 'UNIVERSAL 18 `IMPLICIT` ShortText) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in NumericString") Right . numericString'fromByteString) + where + unwrap :: 'UNIVERSAL 18 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary NumericString where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 VisibleString +-- +-- > VisibleString ::= [UNIVERSAL 26] IMPLICIT OCTET STRING +-- +-- @since 0.1.1 +newtype VisibleString = VisibleString ShortText deriving (Eq,Ord) + +instance ASN1String VisibleString where + asn1string'supportsCodePoint _ = isVisibleChar + asn1string'toCodePoints (VisibleString t) = TS.unpack t + asn1string'fromCodePoints cps + | all isVisibleChar cps = Just $! VisibleString (TS.pack cps) + | otherwise = Nothing + +instance Show VisibleString where + show (VisibleString s) = show s + showsPrec p (VisibleString s) = showsPrec p s + +visibleString'fromShortText :: ShortText -> Maybe VisibleString +visibleString'fromShortText t + | TS.all isVisibleChar t = Just $! VisibleString t + | otherwise = Nothing + +visibleString'fromByteString :: ByteString -> Maybe VisibleString +visibleString'fromByteString bs + | BSC.all isVisibleChar bs = VisibleString <$> TS.fromByteString bs + | otherwise = Nothing + +visibleString'toShortText :: VisibleString -> ShortText +visibleString'toShortText (VisibleString t) = t + +isVisibleChar :: Char -> Bool +isVisibleChar c = '\x20' <= c && c <= '\x7e' -- aka 'isPrint && isAscii' + +instance ASN1 VisibleString where + asn1defTag _ = Universal 26 + asn1encode (VisibleString t) = asn1encode (IMPLICIT t :: 'UNIVERSAL 26 `IMPLICIT` ShortText) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in VisibleString") Right . visibleString'fromByteString) + where + unwrap :: 'UNIVERSAL 26 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary VisibleString where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 IA5String +-- +-- > IA5String ::= [UNIVERSAL 22] IMPLICIT OCTET STRING +-- +-- @since 0.1.1 +newtype IA5String = IA5String ShortText deriving (Eq,Ord) + +instance ASN1String IA5String where + asn1string'supportsCodePoint _ = isIA5Char + asn1string'toCodePoints (IA5String t) = TS.unpack t + asn1string'fromCodePoints cps + | all isIA5Char cps = Just $! IA5String (TS.pack cps) + | otherwise = Nothing + +instance Show IA5String where + show (IA5String s) = show s + showsPrec p (IA5String s) = showsPrec p s + +ia5String'fromShortText :: ShortText -> Maybe IA5String +ia5String'fromShortText t + | TS.all isIA5Char t = Just $! IA5String t + | otherwise = Nothing + +ia5String'fromByteString :: ByteString -> Maybe IA5String +ia5String'fromByteString bs + | BSC.all isIA5Char bs = IA5String <$> TS.fromByteString bs + | otherwise = Nothing + +ia5String'toShortText :: IA5String -> ShortText +ia5String'toShortText (IA5String t) = t + +isIA5Char :: Char -> Bool +isIA5Char c = c <= '\x7f' + +instance ASN1 IA5String where + asn1defTag _ = Universal 22 + asn1encode (IA5String t) = asn1encode (IMPLICIT t :: 'UNIVERSAL 22 `IMPLICIT` ShortText) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in IA5String") Right . ia5String'fromByteString) + where + unwrap :: 'UNIVERSAL 22 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary IA5String where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 BMPString +-- +-- > BMPString ::= [UNIVERSAL 30] IMPLICIT OCTET STRING +-- +-- NB: The surrogate-pair range U+D800 through U+DFFF is tolerated and thus the responsibility of code converting to and +-- from 'BMPString' +-- +-- @since 0.1.1 +newtype BMPString = BMPString SBS.ShortByteString deriving (Eq,Ord) + +instance ASN1String BMPString where + asn1string'supportsCodePoint _ = (<= '\xffff') + asn1string'toCodePoints = bmpString'toString + asn1string'fromCodePoints = bmpString'fromString + +instance Show BMPString where + show = show . bmpString'toString + showsPrec p = showsPrec p . bmpString'toString + +bmpString'toUcs2CodePoints :: BMPString -> [Word16] +bmpString'toUcs2CodePoints (BMPString sbs) = go (SBS.unpack sbs) + where + go (h:l:rest) = (fromIntegral h*0x100)+fromIntegral l : go rest + go [] = [] + go [_] = impossible -- forbidden by invariant + +bmpString'fromUcs2CodePoints :: [Word16] -> BMPString +bmpString'fromUcs2CodePoints cps = BMPString (SBS.pack $ go cps) + where + go (cp:rest) = fromIntegral (cp `unsafeShiftR` 8) : fromIntegral (cp .&. 0xff) : go rest + go [] = [] + +-- NB: Surrogate pair code-points (U+D800 through U+DFFF) are transparently emitted as surrogate 'Char' code-points +bmpString'toString :: BMPString -> String +bmpString'toString = map (chr . fromIntegral) . bmpString'toUcs2CodePoints + +-- NB: Surrogate pair code-points (U+D800 through U+DFFF) are not rejected in order for 'bmpString'toString' to be an inverse operation. +bmpString'fromString :: String -> Maybe BMPString +bmpString'fromString s + | all (\c -> c <= '\xffff') s = Just $! bmpString'fromUcs2CodePoints $ map (fromIntegral . ord) s + | otherwise = Nothing + +bmpString'fromByteString :: ByteString -> Maybe BMPString +bmpString'fromByteString bs + | even (BSC.length bs) = Just $! BMPString (SBS.toShort bs) + | otherwise = Nothing + +instance ASN1 BMPString where + asn1defTag _ = Universal 30 + asn1encode (BMPString t) = asn1encode (IMPLICIT (SBS.fromShort t) :: 'UNIVERSAL 30 `IMPLICIT` OCTET_STRING) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in BMPString") Right . bmpString'fromByteString) + where + unwrap :: 'UNIVERSAL 30 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary BMPString where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- + +-- | ASN.1 UniversalString +-- +-- > UniversalString ::= [UNIVERSAL 28] IMPLICIT OCTET STRING +-- +-- NB: The surrogate-pair range U+D800 through U+DFFF is tolerated and thus becomes the responsibility of code converting to and from 'UniversalString' +-- +-- @since 0.1.1 +newtype UniversalString = UniversalString SBS.ShortByteString + deriving (Eq,Ord) + +instance ASN1String UniversalString where + asn1string'supportsCodePoint _ = const True + asn1string'toCodePoints = universalString'toString + asn1string'fromCodePoints = \s -> Just $! universalString'fromString s + +instance Show UniversalString where + show = show . universalString'toString + showsPrec p = showsPrec p . universalString'toString + +-- NB: Surrogate pair code-points (U+D800 through U+DFFF) are transparently emitted as surrogate 'Char' code-points +universalString'toString :: UniversalString -> String +universalString'toString = maybe impossible id . bsToUcs4 . (\(UniversalString x) -> SBS.fromShort x) + +-- NB: Surrogate pair code-points (U+D800 through U+DFFF) are not rejected in order for 'universalString'toString' to be an inverse operation. +universalString'fromString :: String -> UniversalString +universalString'fromString = UniversalString . SBS.toShort . ucs4ToBs + +universalString'fromByteString :: ByteString -> Maybe UniversalString +universalString'fromByteString bs + | Just _ <- bsToUcs4 bs = Just (UniversalString $ SBS.toShort bs) + | otherwise = Nothing + +-- internal +bsToUcs4 :: ByteString -> Maybe [Char] +bsToUcs4 bs + | (n,0) <- BSC.length bs `quotRem` 4 = runGetMaybe (repGet n f) bs + | otherwise = Nothing + where + f = do x <- Bin.getWord32be + guard (x <= 0x10ffff) + pure $! chr (fromIntegral x) + +ucs4ToBs :: [Char] -> ByteString +ucs4ToBs cs = BL.toStrict $ Bin.runPut (mapM_ Bin.putWord32be cs') + where + cs' :: [Word32] + cs' = map (fromIntegral . ord) cs + +instance ASN1 UniversalString where + asn1defTag _ = Universal 28 + asn1encode (UniversalString t) = asn1encode (IMPLICIT (SBS.fromShort t) :: 'UNIVERSAL 28 `IMPLICIT` OCTET_STRING) + asn1decode = (unwrap <$> asn1decode) `transformVia` + (maybe (Left "Invalid code-point in UniversalString") Right . universalString'fromByteString) + where + unwrap :: 'UNIVERSAL 28 `IMPLICIT` OCTET_STRING -> ByteString + unwrap (IMPLICIT t) = t + +-- | Encodes as ASN.1 BER +instance Bin.Binary UniversalString where + get = toBinaryGet asn1decode + put = void . toBinaryPut . asn1encode + +---------------------------------------------------------------------------- +-- helpers + +runGetMaybe :: Bin.Get a -> ByteString -> Maybe a +runGetMaybe g bs = case Bin.runGetOrFail g (BL.fromStrict bs) of + Left _ -> Nothing + Right (rest,_,x) + | BL.null rest -> Just $! x + | otherwise -> Nothing + +repGet :: Int -> Bin.Get a -> Bin.Get [a] +repGet n g = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do { x <- g; x `seq` go (x:xs) (i-1) } + +isSurr :: Char -> Bool +isSurr c = c >= '\xd800' && c <= '\xdfff' diff --git a/src/LDAPv3/AttributeDescription.hs b/src/LDAPv3/AttributeDescription.hs --- a/src/LDAPv3/AttributeDescription.hs +++ b/src/LDAPv3/AttributeDescription.hs @@ -47,10 +47,14 @@ , p'OID , ts'OID , r'OID + + , p'DescrOrOID + ) where import Common hiding (Option, many, option, some, (<|>)) import Data.ASN1 +import LDAPv3.StringRepr.Class import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Short as SBS @@ -102,6 +106,10 @@ asn1decode = asn1decodeParsec "AttributeDescription" p'AttributeDescription asn1encode = asn1encode . ts'AttributeDescription +instance StringRepr AttributeDescription where + asParsec = p'AttributeDescription + renderShortText = ts'AttributeDescription + instance S.IsString AttributeDescription where fromString = _fromString "AttributeDescription" p'AttributeDescription @@ -148,6 +156,10 @@ showsPrec p (Option s) = showsPrec p s show (Option s) = show s +instance StringRepr Option where + asParsec = p'Option + renderShortText = ts'Option + instance S.IsString Option where fromString = _fromString "Option" p'Option @@ -186,6 +198,11 @@ asn1encode oid = asn1encode (BSC.pack (s'OID oid)) asn1decode = asn1decodeParsec "OID" p'OID +instance StringRepr OID where + asBuilder = r'OID + renderShortText = ts'OID + asParsec = p'OID + r'OID :: OID -> Builder r'OID = B.fromString . s'OID @@ -211,11 +228,6 @@ then pure 0 else read . (ldigit:) <$> many digit - sepBy1' p set = f <$> sepBy1 p set - where - f [] = error "the impossible happened" - f (x:xs) = x:|xs - {- | Case-insensitive string used to denote OID short names > keystring = leadkeychar *keychar @@ -242,6 +254,10 @@ instance S.IsString KeyString where fromString = _fromString "KeyString" p'KeyString +instance StringRepr KeyString where + asParsec = p'KeyString + renderShortText = ts'KeyString + ts'KeyString :: KeyString -> ShortText ts'KeyString (KeyString s) = s @@ -279,6 +295,10 @@ instance S.IsString MatchingRuleId where fromString = _fromString "MatchingRuleId" p'MatchingRuleId + +instance StringRepr MatchingRuleId where + asParsec = p'MatchingRuleId + renderShortText = ts'MatchingRuleId ts'MatchingRuleId :: MatchingRuleId -> ShortText ts'MatchingRuleId (MatchingRuleId mrid) = ts'DescrOrOID mrid diff --git a/src/LDAPv3/DistinguishedName.hs b/src/LDAPv3/DistinguishedName.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/DistinguishedName.hs @@ -0,0 +1,342 @@ +-- 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 diff --git a/src/LDAPv3/SearchFilter.hs b/src/LDAPv3/SearchFilter.hs --- a/src/LDAPv3/SearchFilter.hs +++ b/src/LDAPv3/SearchFilter.hs @@ -19,6 +19,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | String representation of LDAPv3 search 'Filter's as defined by . -- -- @since 0.1.0 @@ -30,6 +32,7 @@ import Common hiding (many, option, some, (<|>)) import LDAPv3.AttributeDescription import LDAPv3.Message +import LDAPv3.StringRepr.Class import qualified Data.ByteString as BS import qualified Data.List.NonEmpty as NE @@ -39,6 +42,12 @@ import Data.Text.Lazy.Builder.Int (hexadecimal) import Text.Parsec as P + +-- NB: technically an orphan; we mitigate this by ensuring that all modules by which the 'StringRepr' class is exported +-- imports this module as to avoid making this observable from outside this package. +instance StringRepr Filter where + asBuilder = r'Filter + asParsec = p'Filter -- -- | Render LDAPv3 search 'Filter's into text representation -- renderFilter :: Filter -> Text diff --git a/src/LDAPv3/StringRepr.hs b/src/LDAPv3/StringRepr.hs --- a/src/LDAPv3/StringRepr.hs +++ b/src/LDAPv3/StringRepr.hs @@ -14,10 +14,11 @@ -- along with this program (see `LICENSE`). If not, see -- . -{-# LANGUAGE FlexibleContexts #-} - --- | String representation of LDAPv3 search 'Filter's as defined by . +-- | String representation of -- +-- * LDAPv3 search 'Filter's as defined by +-- * LDAPv3 'DistinguishedName's as defined by +-- -- @since 0.1.0 module LDAPv3.StringRepr ( StringRepr ( asParsec @@ -29,32 +30,22 @@ , parseShortText , parseText , parseString + + -- * Distinguished Names + + , DistinguishedName(DistinguishedName) + , rfc4514coreAttributes ) where import Common hiding (Option, many, option, some, (<|>)) -import qualified Data.Text.Lazy as T (toStrict) -import Data.Text.Lazy.Builder as B import qualified Data.Text.Short as TS import Text.Parsec as P -import LDAPv3.AttributeDescription -import LDAPv3.Message (Filter) -import LDAPv3.SearchFilter - --- | Convert to and from string representations as defined by . --- --- @since 0.1.0 -class StringRepr a where - asParsec :: Stream s Identity Char => Parsec s () a - - asBuilder :: a -> Builder - asBuilder = fromText . TS.toText . renderShortText - - renderShortText :: a -> ShortText - renderShortText = TS.fromText . T.toStrict . B.toLazyText . asBuilder - - {-# MINIMAL asParsec, (renderShortText | asBuilder) #-} +import LDAPv3.AttributeDescription () +import LDAPv3.DistinguishedName (DistinguishedName (..), rfc4514coreAttributes) +import LDAPv3.SearchFilter () +import LDAPv3.StringRepr.Class -- | Convenience 'StringRepr' operation for rendering as 'Text' -- @@ -85,28 +76,3 @@ -- @since 0.1.0 parseString :: StringRepr a => String -> Maybe a parseString = either (const Nothing) Just . parse (asParsec <* eof) "" - -instance StringRepr AttributeDescription where - asParsec = p'AttributeDescription - renderShortText = ts'AttributeDescription - -instance StringRepr Option where - asParsec = p'Option - renderShortText = ts'Option - -instance StringRepr OID where - asBuilder = r'OID - renderShortText = ts'OID - asParsec = p'OID - -instance StringRepr KeyString where - asParsec = p'KeyString - renderShortText = ts'KeyString - -instance StringRepr MatchingRuleId where - asParsec = p'MatchingRuleId - renderShortText = ts'MatchingRuleId - -instance StringRepr Filter where - asBuilder = r'Filter - asParsec = p'Filter diff --git a/src/LDAPv3/StringRepr/Class.hs b/src/LDAPv3/StringRepr/Class.hs new file mode 100644 --- /dev/null +++ b/src/LDAPv3/StringRepr/Class.hs @@ -0,0 +1,40 @@ +-- Copyright (c) 2019 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 FlexibleContexts #-} + +module LDAPv3.StringRepr.Class where + +import Common hiding (Option, many, option, some, (<|>)) + +import qualified Data.Text.Lazy as T (toStrict) +import Data.Text.Lazy.Builder as B +import qualified Data.Text.Short as TS +import Text.Parsec as P + +-- | Convert to and from string representations as defined by . +-- +-- @since 0.1.0 +class StringRepr a where + asParsec :: Stream s Identity Char => Parsec s () a + + asBuilder :: a -> Builder + asBuilder = fromText . TS.toText . renderShortText + + renderShortText :: a -> ShortText + renderShortText = TS.fromText . T.toStrict . B.toLazyText . asBuilder + + {-# MINIMAL asParsec, (renderShortText | asBuilder) #-} diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -18,18 +18,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary () where +import LDAPv3.ASN1String import LDAPv3.Message +import LDAPv3.StringRepr (DistinguishedName(..)) import qualified Data.ByteString as BS import qualified Data.Char as C import Data.Coerce (coerce) import Data.Int import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy(..)) import Data.String (fromString) import qualified Data.Text.Short as TS import Test.QuickCheck.Instances () @@ -286,3 +290,55 @@ instance Arbitrary OID where arbitrary = OID <$> arbitrary + +instance Arbitrary DistinguishedName where + shrink (DistinguishedName rdns) = map DistinguishedName $ genericShrink rdns + + arbitrary = (DistinguishedName <$> arbitrary) `suchThat` nonEmptyOctets + where + nonEmptyOctets (DistinguishedName rdns) = all (all ok) rdns + where + ok = either (not . BS.null) (const True) . snd + +instance Arbitrary ASN1StringChoice where + arbitrary = oneof + [ ASN1String'OCTET_STRING <$> arbitrary + , ASN1String'UniversalString <$> arbitrary + , ASN1String'UTF8String <$> arbitrary + , ASN1String'BMPString <$> arbitrary + , ASN1String'IA5String <$> arbitrary + , ASN1String'VisibleString <$> arbitrary + , ASN1String'PrintableString <$> arbitrary + , ASN1String'NumericString <$> arbitrary + ] + +instance Arbitrary UniversalString where + arbitrary = (asn1string'fromCodePoints <$> arbitrary) `suchThatMap` id + +instance Arbitrary BMPString where + arbitrary = bmpString'fromUcs2CodePoints <$> arbitrary + +instance Arbitrary IA5String where + arbitrary = a'ia5subtype + +instance Arbitrary VisibleString where + arbitrary = a'ia5subtype + +instance Arbitrary LDAPv3.ASN1String.PrintableString where + arbitrary = a'ia5subtype + +instance Arbitrary NumericString where + arbitrary = a'ia5subtype + +a'ia5subtype :: forall s . ASN1String s => Gen s +a'ia5subtype = do + s <- asn1string'fromCodePoints <$> listOf a'char + case s of + Nothing -> error "internal error in ia5subtype generator" + Just x -> pure x + where + a'hasChar = asn1string'supportsCodePoint (Proxy :: Proxy s) + a'char = choose (min'char, max'char) `suchThat` a'hasChar + + max'char = last $ filter a'hasChar ['\0'..'\x7f'] + min'char = head $ filter a'hasChar ['\0'..'\x7f'] diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -20,6 +20,7 @@ module Main (main) where +import LDAPv3.ASN1String import LDAPv3.Message import LDAPv3.StringRepr @@ -41,9 +42,9 @@ main :: IO () main = defaultMain tests -tests, qcPropsRFC4511, qcPropsRFC4515, unitTestsRFC4511, unitTestsRFC4515 :: TestTree +tests, qcPropsRFC4511, qcPropsRFC4515, unitTestsRFC4511, unitTestsRFC4515, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String :: TestTree -tests = testGroup "Tests" [unitTestsRFC4515, unitTestsRFC4511, qcPropsRFC4515, qcPropsRFC4511] +tests = testGroup "Tests" [unitTestsRFC4515, unitTestsRFC4511, qcPropsRFC4515, qcPropsRFC4511, unitTestsRFC4514, qcPropsRFC4514, qcPropsASN1String] ---------------------------------------------------------------------------------------------------- @@ -673,6 +674,67 @@ ) ) ] + ] + +---------------------------------------------------------------------------------------------------- + +unitTestsRFC4514 = testGroup "Golden tests (RFC4514)" + [ testGroup tlabel $ + [ testCase "parseDN" $ parseShortText ref_string @?= Just ref_dn + , testCase "renderDN" $ renderShortText ref_dn @?= ref_string2 + ] ++ + [ testCase "parseDN #2" $ parseShortText ref_string2 @?= Just ref_dn + | ref_string2 /= ref_string + ] + | (tlabel,(ref_string,ref_string2),ref_dn) <- + [ + ( "RFC4514 example #1" + , dup"UID=jsmith,DC=example,DC=net" + , DistinguishedName [(Left "DC",Right "net") :| [],(Left "DC",Right "example") :| [],(Left "UID",Right "jsmith") :| []] + ) + , + ( "RFC4514 example #2" + , dup"OU=Sales+CN=J. Smith,DC=example,DC=net" + , DistinguishedName [(Left "DC",Right "net") :| [],(Left "DC",Right "example") :| [],(Left "OU",Right "Sales") :| [(Left "CN",Right "J. Smith")]] + ) + , + ( "RFC4514 example #3" + , ( "CN=James\\ \\22Jim\\22\\20Smith\\2c III,DC=example,DC=net" + , "CN=James \\\"Jim\\\" Smith\\, III,DC=example,DC=net" + ) + , DistinguishedName [(Left "DC",Right "net") :| [],(Left "DC",Right "example") :| [],(Left "CN",Right "James \"Jim\" Smith, III") :| []] + ) + , + ( "RFC4514 example #4" + , ( "CN=Before\\0dAfter,DC=example,DC=net" + , "CN=Before\rAfter,DC=example,DC=net" + ) + , DistinguishedName [(Left "DC",Right "net") :| [],(Left "DC",Right "example") :| [],(Left "CN",Right "Before\rAfter") :| []] + ) + , + ( "RFC4514 example #5" + , dup"1.3.6.1.4.1.1466.0=#04024869" + , DistinguishedName [(Right (OID (1 :| [3,6,1,4,1,1466,0])),Left "\EOT\STXHi") :| []] + ) + + , + ( "RFC4514 example #6" + , ( "CN=Lu\\C4\\8Di\\c4\\87\\00" + , "CN=Lu\269i\263\\00" + ) + , DistinguishedName [(Left "CN",Right "Lu\269i\263\NUL") :| []] + ) + ] + ] + +qcPropsRFC4514 = testGroup "Properties (RFC4514)" + [ QC.testProperty "parse/render DN roundtrip" $ + \f -> parseShortText (renderShortText (f :: DistinguishedName)) === Just f + ] + +qcPropsASN1String = testGroup "Properties (ASN1String)" + [ QC.testProperty "encode/decode ASN1StringChoice roundtrip" $ + \s -> asn1StringChoice'decode (asn1StringChoice'encode (s :: ASN1StringChoice)) === Just s ] ----------------------------------------------------------------------------------------------------