LDAPv3 0.1.0.0 → 0.1.1.0

raw patch · 12 files changed

+1125/−59 lines, 12 filesdep ~quickcheck-instancesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: quickcheck-instances

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• LDAPv3.cabal +6/−3
• src/Common.hs +9/−0
• src/Data/ASN1/Prim.hs +1/−2
• src/LDAPv3/ASN1String.hs +555/−0
• src/LDAPv3/AttributeDescription.hs +25/−5
• src/LDAPv3/DistinguishedName.hs +342/−0
• src/LDAPv3/SearchFilter.hs +9/−0
• src/LDAPv3/StringRepr.hs +13/−47
• src/LDAPv3/StringRepr/Class.hs +40/−0
• test/Arbitrary.hs +56/−0
• test/main.hs +64/−2

@@ -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.

@@ -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 <https://en.wikipedia.org/wiki/ASN.1 ASN.1> encoding for the purpose of implementing network clients and servers is supported via 'Binary' instances (see <//hackage.haskell.org/package/binary 'binary' package>).   .-  Moreover, this library also implements /String Representation of Search Filters/ as per <https://tools.ietf.org/html/rfc4515 RFC4515> (see "LDAPv3.StringRepr")+  Moreover, this library also implements /String Representation of Search Filters/ as per <https://tools.ietf.org/html/rfc4515 RFC4515> and /String Representation of Distinguished Names/ as per <https://tools.ietf.org/html/rfc4514 RFC4514> (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

@@ -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

@@ -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

@@ -0,0 +1,555 @@+-- 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 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'

@@ -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

@@ -0,0 +1,342 @@+-- 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 =+    [ ("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 <escaped>, 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 <string>"++          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

@@ -19,6 +19,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | String representation of LDAPv3 search 'Filter's as defined by <https://tools.ietf.org/html/rfc4515 RFC4515>. -- -- @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 <https://tools.ietf.org/html/rfc4515 RFC4515> text representation -- renderFilter :: Filter -> Text

@@ -14,10 +14,11 @@ --  along with this program (see `LICENSE`).  If not, see --  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>. -{-# LANGUAGE FlexibleContexts #-}---- | String representation of LDAPv3 search 'Filter's as defined by <https://tools.ietf.org/html/rfc4515 RFC4515>.+-- | String representation of --+-- * LDAPv3 search 'Filter's as defined by <https://tools.ietf.org/html/rfc4515 RFC4515>+-- * LDAPv3 'DistinguishedName's as defined by <https://tools.ietf.org/html/rfc4514 RFC4514>+-- -- @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 <https://tools.ietf.org/html/rfc4515 RFC4515>.------ @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

@@ -0,0 +1,40 @@+-- Copyright (c) 2019  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 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 <https://tools.ietf.org/html/rfc4515 RFC4515>.+--+-- @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) #-}

@@ -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']

@@ -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   ]  ----------------------------------------------------------------------------------------------------